Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

More code cleanup

  - remove a couple of performance-dangerous uses of /dev/urandom

  - code prettification

  - bump master to 0.7.1
  • Loading branch information...
commit 1e3cfe3c2df8884e6bde01fcbd22827b9c03d6b8 1 parent 635004f
@gregorycollins gregorycollins authored
View
22 .gitignore
@@ -1,17 +1,19 @@
-*~
-dist/
-*.tix
-.hpc
-*.log
-*.prof
+#*#
+**/.DS_Store
*.hi
+*.log
*.o
+*.prof
*.swp
-#*#
+*.tix
+*~
.#*
.DS_Store
-**/.DS_Store
-docs/templates/out
+.hpc
cabal-dev/
-test/test-cabal-dev
+dist/
+docs/templates/out
sitekey.txt
+test/non-cabal-appdir
+test/test-cabal-dev
+test/test-snap-exe
View
4 snap.cabal
@@ -1,5 +1,5 @@
name: snap
-version: 0.7
+version: 0.7.1
synopsis: Snap: A Haskell Web Framework: project starter executable and glue code library
description: Snap Framework project starter executable and glue code library
license: BSD3
@@ -115,7 +115,7 @@ Library
data-lens-template >= 2.1 && < 2.2,
filepath >= 1.1 && < 1.3,
hashable >= 1.1 && < 1.2,
- heist >= 0.7 && < 0.8,
+ heist >= 0.7 && < 0.9,
logict >= 0.4.2 && < 0.6,
mtl > 2.0 && < 2.1,
mwc-random >= 0.8 && < 0.11,
View
28 src/Snap/Snaplet/Auth.hs
@@ -1,22 +1,21 @@
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-|
-
- This module contains all the central authentication functionality.
-
- It exports a number of high-level functions to be used directly in your
- application handlers.
-
- We also export a number of mid-level functions that should be helpful when
- you are integrating with another way of confirming the authentication of
- login requests.
-
--}
+------------------------------------------------------------------------------
+-- |
+--
+-- This module contains all the central authentication functionality.
+--
+-- It exports a number of high-level functions to be used directly in your
+-- application handlers.
+--
+-- We also export a number of mid-level functions that should be helpful when
+-- you are integrating with another way of confirming the authentication of
+-- login requests.
+--
module Snap.Snaplet.Auth
(
-
-- * Higher Level Handler Functions
createUser
, usernameExists
@@ -67,6 +66,7 @@ module Snap.Snaplet.Auth
)
where
+------------------------------------------------------------------------------
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Auth.Handlers
import Snap.Snaplet.Auth.SpliceHelpers
View
39 src/Snap/Snaplet/Auth/AuthManager.hs
@@ -1,21 +1,21 @@
+------------------------------------------------------------------------------
+-- | Internal module exporting AuthManager implementation.
+--
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.Auth.AuthManager
-
-(
- -- * AuthManager Datatype
+ ( -- * AuthManager Datatype
AuthManager(..)
- -- * Backend Typeclass
- , IAuthBackend(..)
+ -- * Backend Typeclass
+ , IAuthBackend(..)
- -- * Context-free Operations
- , buildAuthUser
-
-) where
+ -- * Context-free Operations
+ , buildAuthUser
+ ) where
------------------------------------------------------------------------------
import Data.ByteString (ByteString)
@@ -26,8 +26,10 @@ import Web.ClientSession
import Snap.Snaplet
import Snap.Snaplet.Session
+import Snap.Snaplet.Session.Common
import Snap.Snaplet.Auth.Types
+
------------------------------------------------------------------------------
-- | Creates a new user from a username and password.
--
@@ -65,28 +67,31 @@ class IAuthBackend r where
------------------------------------------------------------------------------
-- | Abstract data type holding all necessary information for auth operation
data AuthManager b = forall r. IAuthBackend r => AuthManager {
- backend :: r
+ backend :: r
-- ^ Storage back-end
- , session :: Lens b (Snaplet SessionManager)
+ , session :: Lens b (Snaplet SessionManager)
-- ^ A lens pointer to a SessionManager
- , activeUser :: Maybe AuthUser
+ , activeUser :: Maybe AuthUser
-- ^ A per-request logged-in user cache
- , minPasswdLen :: Int
+ , minPasswdLen :: Int
-- ^ Password length range
- , rememberCookieName :: ByteString
+ , rememberCookieName :: ByteString
-- ^ Cookie name for the remember token
- , rememberPeriod :: Maybe Int
+ , rememberPeriod :: Maybe Int
-- ^ Remember period in seconds. Defaults to 2 weeks.
- , siteKey :: Key
+ , siteKey :: Key
-- ^ A unique encryption key used to encrypt remember cookie
- , lockout :: Maybe (Int, NominalDiffTime)
+ , lockout :: Maybe (Int, NominalDiffTime)
-- ^ Lockout after x tries, re-allow entry after y seconds
+
+ , randomNumberGenerator :: RNG
+ -- ^ Random number generator
}
View
37 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -32,6 +32,7 @@ import Snap.Snaplet
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Session
+import Snap.Snaplet.Session.Common
@@ -45,23 +46,25 @@ initJsonFileAuthManager :: AuthSettings
-> FilePath
-- ^ Where to store user data as JSON
-> SnapletInit b (AuthManager b)
-initJsonFileAuthManager s l db =
- makeSnaplet
- "JsonFileAuthManager"
- "A snaplet providing user authentication using a JSON-file backend"
- Nothing $ liftIO $ do
- key <- getKey (asSiteKey s)
- jsonMgr <- mkJsonAuthMgr db
- return $! AuthManager {
- backend = jsonMgr
- , session = l
- , activeUser = Nothing
- , minPasswdLen = asMinPasswdLen s
- , rememberCookieName = asRememberCookieName s
- , rememberPeriod = asRememberPeriod s
- , siteKey = key
- , lockout = asLockout s
- }
+initJsonFileAuthManager s l db = do
+ makeSnaplet
+ "JsonFileAuthManager"
+ "A snaplet providing user authentication using a JSON-file backend"
+ Nothing $ liftIO $ do
+ rng <- liftIO mkRNG
+ key <- getKey (asSiteKey s)
+ jsonMgr <- mkJsonAuthMgr db
+ return $! AuthManager {
+ backend = jsonMgr
+ , session = l
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen s
+ , rememberCookieName = asRememberCookieName s
+ , rememberPeriod = asRememberPeriod s
+ , siteKey = key
+ , lockout = asLockout s
+ , randomNumberGenerator = rng
+ }
------------------------------------------------------------------------------
View
12 src/Snap/Snaplet/Auth/Handlers.hs
@@ -93,7 +93,9 @@ loginByUsername unm pwd shouldRemember = do
----------------------------------------------------------------------
matched user
| shouldRemember = do
- token <- liftIO $ randomToken 64
+ token <- gets randomNumberGenerator >>=
+ liftIO . randomToken 64
+
setRememberToken sk cn rp token
let user' = user {
@@ -151,7 +153,7 @@ currentUser = cacheOrLookup $ withBackend $ \r -> do
-- | Convenience wrapper around 'rememberUser' that returns a bool result
--
isLoggedIn :: Handler b (AuthManager b) Bool
-isLoggedIn = isJust `fmap` currentUser
+isLoggedIn = isJust <$> currentUser
------------------------------------------------------------------------------
@@ -223,7 +225,7 @@ markAuthSuccess u = withBackend $ \r ->
--------------------------------------------------------------------------
updateIp u' = do
- ip <- rqRemoteAddr `fmap` getRequest
+ ip <- rqRemoteAddr <$> getRequest
return $ u' { userLastLoginIp = userCurrentLoginIp u'
, userCurrentLoginIp = Just ip }
@@ -394,7 +396,7 @@ registerUser
-> ByteString -- ^ Password field
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
- l <- fmap decodeUtf8 `fmap` getParam lf
+ l <- fmap decodeUtf8 <$> getParam lf
p <- getParam pf
case liftM2 (,) l p of
Nothing -> throw PasswordMissing
@@ -478,5 +480,5 @@ withBackend ::
-- ^ The function to run with the handler.
-> Handler b (AuthManager v) a
withBackend f = join $ do
- (AuthManager backend_ _ _ _ _ _ _ _) <- get
+ (AuthManager backend_ _ _ _ _ _ _ _ _) <- get
return $ f backend_
View
2  src/Snap/Snaplet/Auth/Types.hs
@@ -139,7 +139,7 @@ defAuthUser = AuthUser
-- clear-text; it will be encrypted into a 'Encrypted'.
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword au pass = do
- pw <- Encrypted `fmap` (makePassword pass defaultStrength)
+ pw <- Encrypted <$> makePassword pass defaultStrength
return $! au { userPassword = Just pw }
View
21 src/Snap/Snaplet/Heist.hs
@@ -1,9 +1,7 @@
-{-|
-
-The Heist snaplet makes it easy to add Heist to your application and use it in
-other snaplets.
-
--}
+------------------------------------------------------------------------------
+-- | The Heist snaplet makes it easy to add Heist to your application and use
+-- it in other snaplets.
+--
module Snap.Snaplet.Heist
(
@@ -44,17 +42,20 @@ module Snap.Snaplet.Heist
, clearHeistCache
) where
+------------------------------------------------------------------------------
import Prelude hiding (id, (.))
import Data.ByteString (ByteString)
import Data.Lens.Lazy
import Data.Text (Text)
import Text.Templating.Heist
-
+------------------------------------------------------------------------------
import Snap.Snaplet
-
import qualified Snap.Snaplet.HeistNoClass as Unclassed
-import Snap.Snaplet.HeistNoClass (Heist, heistInit
- ,heistInit', clearHeistCache)
+import Snap.Snaplet.HeistNoClass ( Heist
+ , heistInit
+ , heistInit'
+ , clearHeistCache
+ )
------------------------------------------------------------------------------
View
59 src/Snap/Snaplet/HeistNoClass.hs
@@ -68,6 +68,7 @@ import Snap.Util.FileServe
-- include this in your application state and use 'heistInit' to initialize
-- it. The type parameter b will typically be the base state type for your
-- application.
+--
data Heist b = Heist
{ _heistTS :: TemplateState (Handler b b)
, _heistCTS :: CacheTagState
@@ -85,24 +86,26 @@ changeTS f (Heist ts cts) = Heist (f ts) cts
-- | Clears data stored by the cache tag. The cache tag automatically reloads
-- its data when the specified TTL expires, but sometimes you may want to
-- trigger a manual reload. This function lets you do that.
+--
clearHeistCache :: Heist b -> IO ()
clearHeistCache = clearCacheTagState . _heistCTS
-------------------------------------------------------------------------------
--- SnapletSplice functions
-------------------------------------------------------------------------------
-
+ -----------------------------
+ -- SnapletSplice functions --
+ -----------------------------
------------------------------------------------------------------------------
-- | This instance is here because we don't want the heist package to depend
-- on anything from snap packages.
+--
instance MonadSnap m => MonadSnap (HeistT m) where
liftSnap = lift . liftSnap
------------------------------------------------------------------------------
-- | Monad for working with Heist's API from within a snaplet.
+--
newtype SnapletHeist b v a = SnapletHeist
(ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)
deriving ( Monad
@@ -119,17 +122,20 @@ newtype SnapletHeist b v a = SnapletHeist
------------------------------------------------------------------------------
-- | Type alias for convenience.
+--
type SnapletSplice b v = SnapletHeist b v Template
------------------------------------------------------------------------------
-- | Runs the SnapletSplice.
+--
runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))
-> SnapletHeist b v a
-> HeistT (Handler b b) a
runSnapletSplice l (SnapletHeist m) = runReaderT m l
+------------------------------------------------------------------------------
withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v'))
-> SnapletHeist b v' a
-> SnapletHeist b v a
@@ -139,12 +145,14 @@ withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m
------------------------------------------------------------------------------
-- | Lifts a HeistT action into SnapletHeist. Use this with all the functions
-- from the Heist API.
+--
liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a
liftHeist = SnapletHeist . lift
------------------------------------------------------------------------------
-- | Common idiom for the combination of liftHandler and withTop.
+--
liftWith :: (Lens (Snaplet b) (Snaplet v'))
-> Handler b v' a
-> SnapletHeist b v a
@@ -153,6 +161,7 @@ liftWith l = liftHeist . lift . withTop' l
------------------------------------------------------------------------------
-- | Lifts a Handler into SnapletHeist.
+--
liftHandler :: Handler b v a -> SnapletHeist b v a
liftHandler m = do
l <- ask
@@ -161,10 +170,12 @@ liftHandler m = do
------------------------------------------------------------------------------
-- | Lifts a (Handler b b) into SnapletHeist.
+--
liftAppHandler :: Handler b b a -> SnapletHeist b v a
liftAppHandler = liftHeist . lift
+------------------------------------------------------------------------------
instance MonadState v (SnapletHeist b v) where
get = do
l <- ask
@@ -178,6 +189,7 @@ instance MonadState v (SnapletHeist b v) where
------------------------------------------------------------------------------
-- | MonadSnaplet instance gives us access to the snaplet infrastructure.
+--
instance MonadSnaplet SnapletHeist where
getLens = ask
with' l = withSS (l .)
@@ -190,6 +202,7 @@ instance MonadSnaplet SnapletHeist where
------------------------------------------------------------------------------
-- | SnapletSplices version of bindSplices.
+--
bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))
-> [(Text, SnapletSplice b v)]
-> TemplateState (Handler b b)
@@ -198,17 +211,16 @@ bindSnapletSplices l splices =
bindSplices $ map (second $ runSnapletSplice l) splices
-------------------------------------------------------------------------------
--- Initializer functions
-------------------------------------------------------------------------------
-
+ ---------------------------
+ -- Initializer functions --
+ ---------------------------
------------------------------------------------------------------------------
-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper
-- around `heistInit'` that uses the default `emptyTemplateState` from Heist
-- and sets up routes for all the templates.
-heistInit :: FilePath
- -- ^ Path to templates
+--
+heistInit :: FilePath -- ^ Path to templates
-> SnapletInit b (Heist b)
heistInit templateDir = do
makeSnaplet "heist" "" Nothing $ do
@@ -221,6 +233,7 @@ heistInit templateDir = do
-- | A lower level 'Initializer' for 'Heist'. This initializer requires you
-- to specify the initial TemplateState. It also does not add any routes for
-- templates, allowing you complete control over which templates get routed.
+--
heistInit' :: FilePath
-- ^ Path to templates
-> TemplateState (Handler b b)
@@ -234,6 +247,7 @@ heistInit' templateDir initialTemplateState =
------------------------------------------------------------------------------
-- | Internal worker function used by variantsof heistInit. This is necessary
-- because of the divide between SnapletInit and Initializer.
+--
heistInitWorker :: FilePath
-> TemplateState (Handler b b)
-> Initializer b v (Heist b)
@@ -251,6 +265,7 @@ heistInitWorker templateDir initialTemplateState = do
return $ Heist ts cts
+------------------------------------------------------------------------------
addTemplates :: ByteString
-- ^ Path to templates (also the url prefix for their routes)
-> Initializer b (Heist b) ()
@@ -259,6 +274,7 @@ addTemplates urlPrefix = do
addTemplatesAt urlPrefix (snapletPath </> "templates")
+------------------------------------------------------------------------------
addTemplatesAt :: ByteString
-- ^ URL prefix for template routes
-> FilePath
@@ -279,6 +295,7 @@ addTemplatesAt urlPrefix templateDir = do
(`mappend` addTemplatePathPrefix urlPrefix ts)
+------------------------------------------------------------------------------
modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Initializer b v ()
@@ -287,24 +304,28 @@ modifyHeistTS' heist f = do
withTop' heist $ addPostInitHook $ return . changeTS f
+------------------------------------------------------------------------------
modifyHeistTS :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Initializer b v ()
modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f
+------------------------------------------------------------------------------
withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> a)
-> Handler b v a
withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)
+------------------------------------------------------------------------------
withHeistTS :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> a)
-> Handler b v a
withHeistTS heist f = withHeistTS' (subSnaplet heist) f
+------------------------------------------------------------------------------
addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Initializer b v ()
@@ -314,16 +335,16 @@ addSplices' heist splices = do
return . changeTS (bindSnapletSplices _lens splices)
+------------------------------------------------------------------------------
addSplices :: (Lens b (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
-------------------------------------------------------------------------------
--- Handler functions
-------------------------------------------------------------------------------
-
+ -----------------------
+ -- Handler functions --
+ -----------------------
------------------------------------------------------------------------------
-- | Internal helper function for rendering.
@@ -339,12 +360,14 @@ renderHelper c t = do
writeBuilder b
+------------------------------------------------------------------------------
render :: ByteString
-- ^ Name of the template
-> Handler b (Heist b) ()
render t = renderHelper Nothing t
+------------------------------------------------------------------------------
renderAs :: ByteString
-- ^ Content type
-> ByteString
@@ -353,17 +376,20 @@ renderAs :: ByteString
renderAs ct t = renderHelper (Just ct) t
+------------------------------------------------------------------------------
heistServe :: Handler b (Heist b) ()
heistServe =
ifTop (render "index") <|> (render . B.pack =<< getSafePath)
+------------------------------------------------------------------------------
heistServeSingle :: ByteString
-> Handler b (Heist b) ()
heistServeSingle t =
render t <|> error ("Template " ++ show t ++ " not found.")
+------------------------------------------------------------------------------
heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Handler b v a
@@ -376,6 +402,7 @@ heistLocal' heist f m = do
return res
+------------------------------------------------------------------------------
heistLocal :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Handler b v a
@@ -383,6 +410,7 @@ heistLocal :: (Lens b (Snaplet (Heist b)))
heistLocal heist f m = heistLocal' (subSnaplet heist) f m
+------------------------------------------------------------------------------
withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Handler b v a
@@ -392,6 +420,7 @@ withSplices' heist splices m = do
heistLocal' heist (bindSnapletSplices _lens splices) m
+------------------------------------------------------------------------------
withSplices :: (Lens b (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Handler b v a
@@ -399,6 +428,7 @@ withSplices :: (Lens b (Snaplet (Heist b)))
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
+------------------------------------------------------------------------------
renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> ByteString
-> [(Text, SnapletSplice b v)]
@@ -407,6 +437,7 @@ renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
+------------------------------------------------------------------------------
renderWithSplices :: (Lens b (Snaplet (Heist b)))
-> ByteString
-> [(Text, SnapletSplice b v)]
View
91 src/Snap/Snaplet/Session.hs
@@ -1,7 +1,5 @@
module Snap.Snaplet.Session
-
-(
- SessionManager
+ ( SessionManager
, withSession
, commitSession
, setInSession
@@ -11,97 +9,116 @@ module Snap.Snaplet.Session
, sessionToList
, resetSession
, touchSession
+ ) where
-) where
-
+------------------------------------------------------------------------------
import Control.Monad.State
import Data.Lens.Lazy
import Data.Text (Text)
-
-import Snap.Snaplet
import Snap.Core
-
+------------------------------------------------------------------------------
+import Snap.Snaplet
import Snap.Snaplet.Session.SessionManager
( SessionManager(..), ISessionManager(..) )
import qualified Snap.Snaplet.Session.SessionManager as SM
+------------------------------------------------------------------------------
-
+------------------------------------------------------------------------------
-- | Wrap around a handler, committing any changes in the session at the end
-withSession :: (Lens b (Snaplet SessionManager))
+--
+withSession :: Lens b (Snaplet SessionManager)
-> Handler b v a
-> Handler b v a
withSession l h = do
- a <- h
- withTop l commitSession
- return a
+ a <- h
+ withTop l commitSession
+ return a
+------------------------------------------------------------------------------
-- | Commit changes to session within the current request cycle
+--
commitSession :: Handler b SessionManager ()
commitSession = do
- SessionManager b <- loadSession
- liftSnap $ commit b
+ SessionManager b <- loadSession
+ liftSnap $ commit b
+------------------------------------------------------------------------------
-- | Set a key-value pair in the current session
+--
setInSession :: Text -> Text -> Handler b SessionManager ()
setInSession k v = do
- SessionManager r <- loadSession
- let r' = SM.insert k v r
- put $ SessionManager r'
+ SessionManager r <- loadSession
+ let r' = SM.insert k v r
+ put $ SessionManager r'
+------------------------------------------------------------------------------
-- | Get a key from the current session
+--
getFromSession :: Text -> Handler b SessionManager (Maybe Text)
getFromSession k = do
- SessionManager r <- loadSession
- return $ SM.lookup k r
+ SessionManager r <- loadSession
+ return $ SM.lookup k r
+------------------------------------------------------------------------------
-- | Remove a key from the current session
+--
deleteFromSession :: Text -> Handler b SessionManager ()
deleteFromSession k = do
- SessionManager r <- loadSession
- let r' = SM.delete k r
- put $ SessionManager r'
+ SessionManager r <- loadSession
+ let r' = SM.delete k r
+ put $ SessionManager r'
+------------------------------------------------------------------------------
-- | Returns a CSRF Token unique to the current session
+--
csrfToken :: Handler b SessionManager Text
csrfToken = do
- mgr@(SessionManager r) <- loadSession
- put mgr
- return $ SM.csrf r
+ mgr@(SessionManager r) <- loadSession
+ put mgr
+ return $ SM.csrf r
+------------------------------------------------------------------------------
-- | Return session contents as an association list
+--
sessionToList :: Handler b SessionManager [(Text, Text)]
sessionToList = do
- SessionManager r <- loadSession
- return $ SM.toList r
+ SessionManager r <- loadSession
+ return $ SM.toList r
+------------------------------------------------------------------------------
-- | Deletes the session cookie, effectively resetting the session
+--
resetSession :: Handler b SessionManager ()
resetSession = do
- SessionManager r <- loadSession
- r' <- liftSnap $ SM.reset r
- put $ SessionManager r'
+ SessionManager r <- loadSession
+ r' <- liftSnap $ SM.reset r
+ put $ SessionManager r'
+------------------------------------------------------------------------------
-- | Touch the session so the timeout gets refreshed
+--
touchSession :: Handler b SessionManager ()
touchSession = do
- SessionManager r <- loadSession
- let r' = SM.touch r
- put $ SessionManager r'
+ SessionManager r <- loadSession
+ let r' = SM.touch r
+ put $ SessionManager r'
+------------------------------------------------------------------------------
-- | Load the session into the manager
+--
loadSession :: Handler b SessionManager SessionManager
loadSession = do
- SessionManager r <- get
- r' <- liftSnap $ load r
- return $ SessionManager r'
+ SessionManager r <- get
+ r' <- liftSnap $ load r
+ return $ SessionManager r'
View
217 src/Snap/Snaplet/Session/Backends/CookieSession.hs
@@ -1,11 +1,14 @@
+------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Snap.Snaplet.Session.Backends.CookieSession
+ ( initCookieSessionManager
+ ) where
-( initCookieSessionManager ) where
-
+------------------------------------------------------------------------------
+import Control.Applicative
import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Generics
@@ -15,146 +18,172 @@ import Data.Hashable (Hashable)
import Data.Serialize (Serialize)
import qualified Data.Serialize as S
import Data.Text (Text)
-import Web.ClientSession
-
import Snap.Core (Snap)
+import Web.ClientSession
+------------------------------------------------------------------------------
import Snap.Snaplet
-import Snap.Snaplet.Session.Common (mkCSRFToken)
+import Snap.Snaplet.Session.Common
import Snap.Snaplet.Session.SessionManager
import Snap.Snaplet.Session.SecureCookie
+------------------------------------------------------------------------------
-- | Session data are kept in a 'HashMap' for this backend
+--
type Session = HashMap Text Text
+------------------------------------------------------------------------------
-- | This is what the 'Payload' will be for the CookieSession backend
+--
data CookieSession = CookieSession
- { csCSRFToken :: Text
- , csSession :: Session
-} deriving (Eq, Show)
+ { csCSRFToken :: Text
+ , csSession :: Session
+ }
+ deriving (Eq, Show)
+------------------------------------------------------------------------------
instance Serialize CookieSession where
- put (CookieSession a b) = S.put (a,b)
- get = (\(a,b) -> CookieSession a b) `fmap` S.get
+ put (CookieSession a b) = S.put (a,b)
+ get = uncurry CookieSession <$> S.get
-instance (Serialize k, Serialize v, Hashable k, Eq k) =>
- Serialize (HashMap k v) where
- put = S.put . HM.toList
- get = HM.fromList `fmap` S.get
+instance (Serialize k, Serialize v, Hashable k,
+ Eq k) => Serialize (HashMap k v) where
+ put = S.put . HM.toList
+ get = HM.fromList <$> S.get
-mkCookieSession :: IO CookieSession
-mkCookieSession = do
- t <- liftIO $ mkCSRFToken
- return $ CookieSession t HM.empty
+------------------------------------------------------------------------------
+mkCookieSession :: RNG -> IO CookieSession
+mkCookieSession rng = do
+ t <- liftIO $ mkCSRFToken rng
+ return $ CookieSession t HM.empty
+------------------------------------------------------------------------------
-- | The manager data type to be stuffed into 'SessionManager'
+--
data CookieSessionManager = CookieSessionManager {
- session :: Maybe CookieSession
- -- ^ Per request cache for 'CookieSession'
-
- , siteKey :: Key
- -- ^ A long encryption key used for secure cookie transport
-
- , cookieName :: ByteString
- -- ^ Cookie name for the session system
-
- , timeOut :: Maybe Int
- -- ^ Session cookies will be considered "stale" after this many seconds.
-} deriving (Show,Typeable)
-
-
+ session :: Maybe CookieSession
+ -- ^ Per request cache for 'CookieSession'
+ , siteKey :: Key
+ -- ^ A long encryption key used for secure cookie transport
+ , cookieName :: ByteString
+ -- ^ Cookie name for the session system
+ , timeOut :: Maybe Int
+ -- ^ Session cookies will be considered "stale" after this many
+ -- seconds.
+ , randomNumberGenerator :: RNG
+ -- ^ handle to a random number generator
+} deriving (Typeable)
+
+
+------------------------------------------------------------------------------
loadDefSession :: CookieSessionManager -> IO CookieSessionManager
-loadDefSession mgr@(CookieSessionManager ses _ _ _) = do
- case ses of
- Nothing -> do
- ses' <- mkCookieSession
- return $ mgr { session = Just ses' }
- Just _ -> return mgr
+loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) =
+ case ses of
+ Nothing -> do ses' <- mkCookieSession rng
+ return $! mgr { session = Just ses' }
+ Just _ -> return mgr
+------------------------------------------------------------------------------
modSession :: (Session -> Session) -> CookieSession -> CookieSession
modSession f (CookieSession t ses) = CookieSession t (f ses)
+------------------------------------------------------------------------------
-- | Initialize a cookie-backed session, returning a 'SessionManager' to be
-- stuffed inside your application's state. This 'SessionManager' will enable
-- the use of all session storage functionality defined in
-- 'Snap.Snaplet.Session'
+--
initCookieSessionManager
- :: FilePath -- ^ Path to site-wide encryption key
- -> ByteString -- ^ Session cookie name
- -> Maybe Int -- ^ Session time-out (replay attack protection)
- -> SnapletInit b SessionManager
+ :: FilePath -- ^ Path to site-wide encryption key
+ -> ByteString -- ^ Session cookie name
+ -> Maybe Int -- ^ Session time-out (replay attack protection)
+ -> SnapletInit b SessionManager
initCookieSessionManager fp cn to =
- makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies."
- Nothing $ liftIO $ do
- key <- getKey fp
- return . SessionManager $ CookieSessionManager Nothing key cn to
+ makeSnaplet "CookieSession"
+ "A snaplet providing sessions via HTTP cookies."
+ Nothing $ liftIO $ do
+ key <- getKey fp
+ rng <- liftIO mkRNG
+ return $! SessionManager $ CookieSessionManager Nothing key cn to rng
+------------------------------------------------------------------------------
instance ISessionManager CookieSessionManager where
- load mgr@(CookieSessionManager r _ _ _) = do
- case r of
- Just _ -> return mgr
- Nothing -> do
- pl <- getPayload mgr
- case pl of
- Nothing -> liftIO $ loadDefSession mgr
- Just (Payload x) -> do
- let c = S.decode x
- case c of
- Left _ -> liftIO $ loadDefSession mgr
- Right cs -> return $ mgr { session = Just cs }
-
- commit mgr@(CookieSessionManager r _ _ _) = do
- pl <- case r of
- Just r' -> return . Payload $ S.encode r'
- Nothing -> liftIO mkCookieSession >>= return . Payload . S.encode
- setPayload mgr pl
-
- reset mgr = do
- cs <- liftIO mkCookieSession
- return $ mgr { session = Just cs }
-
- touch = id
-
- insert k v mgr@(CookieSessionManager r _ _ _) = case r of
- Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }
- Nothing -> mgr
-
- lookup k (CookieSessionManager r _ _ _) = r >>= HM.lookup k . csSession
-
- delete k mgr@(CookieSessionManager r _ _ _) = case r of
- Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }
- Nothing -> mgr
-
- csrf (CookieSessionManager r _ _ _) = case r of
- Just r' -> csCSRFToken r'
- Nothing -> ""
-
- toList (CookieSessionManager r _ _ _) = case r of
- Just r' -> HM.toList . csSession $ r'
- Nothing -> []
-
-
+ --------------------------------------------------------------------------
+ load mgr@(CookieSessionManager r _ _ _ _) =
+ case r of
+ Just _ -> return mgr
+ Nothing -> do
+ pl <- getPayload mgr
+ case pl of
+ Nothing -> liftIO $ loadDefSession mgr
+ Just (Payload x) -> do
+ let c = S.decode x
+ case c of
+ Left _ -> liftIO $ loadDefSession mgr
+ Right cs -> return $ mgr { session = Just cs }
+
+ --------------------------------------------------------------------------
+ commit mgr@(CookieSessionManager r _ _ _ rng) = do
+ pl <- case r of
+ Just r' -> return . Payload $ S.encode r'
+ Nothing -> liftIO (mkCookieSession rng) >>=
+ return . Payload . S.encode
+ setPayload mgr pl
+
+ --------------------------------------------------------------------------
+ reset mgr = do
+ cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr)
+ return $ mgr { session = Just cs }
+
+ --------------------------------------------------------------------------
+ touch = id
+
+ --------------------------------------------------------------------------
+ insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of
+ Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }
+ Nothing -> mgr
+
+ --------------------------------------------------------------------------
+ lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession
+
+ --------------------------------------------------------------------------
+ delete k mgr@(CookieSessionManager r _ _ _ _) = case r of
+ Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }
+ Nothing -> mgr
+
+ --------------------------------------------------------------------------
+ csrf (CookieSessionManager r _ _ _ _) = case r of
+ Just r' -> csCSRFToken r'
+ Nothing -> ""
+
+ --------------------------------------------------------------------------
+ toList (CookieSessionManager r _ _ _ _) = case r of
+ Just r' -> HM.toList . csSession $ r'
+ Nothing -> []
+
+
+------------------------------------------------------------------------------
-- | A session payload to be stored in a SecureCookie.
newtype Payload = Payload ByteString
deriving (Eq, Show, Ord, Serialize)
+------------------------------------------------------------------------------
-- | Get the current client-side value
getPayload :: CookieSessionManager -> Snap (Maybe Payload)
getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)
+------------------------------------------------------------------------------
-- | Set the client-side value
setPayload :: CookieSessionManager -> Payload -> Snap ()
-setPayload mgr x =
- setSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) x
-
-
+setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr)
+ (timeOut mgr) x
View
63 src/Snap/Snaplet/Session/Common.hs
@@ -1,41 +1,66 @@
-{-|
-
- This module contains functionality common among multiple back-ends.
-
--}
-
-module Snap.Snaplet.Session.Common where
+------------------------------------------------------------------------------
+-- | This module contains functionality common among multiple back-ends.
+--
+module Snap.Snaplet.Session.Common
+ ( RNG
+ , mkRNG
+ , withRNG
+ , randomToken
+ , mkCSRFToken
+ ) where
-import Numeric
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Trans
import Data.Serialize
import qualified Data.Serialize as S
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as T
import Data.Text (Text)
+import Numeric
import System.Random.MWC
------------------------------------------------------------------------------
+newtype RNG = RNG (MVar GenIO)
+
+------------------------------------------------------------------------------
+withRNG :: RNG
+ -> (GenIO -> IO a)
+ -> IO a
+withRNG (RNG rng) m = withMVar rng m
+
+
+------------------------------------------------------------------------------
+mkRNG :: IO RNG
+mkRNG = withSystemRandom (newMVar >=> return . RNG)
+
+
+------------------------------------------------------------------------------
-- | Generates a random salt of given length
-randomToken :: Int -> IO ByteString
-randomToken n =
- let
- mk :: GenIO -> IO Int
- mk gen = uniformR (0,15) gen
- in do
- is <- withSystemRandom $ \gen -> sequence . take n . repeat $ mk gen
+--
+randomToken :: Int -> RNG -> IO ByteString
+randomToken n rng = do
+ is <- withRNG rng $ \gen -> sequence . take n . repeat $ mk gen
return . B.pack . concat . map (flip showHex "") $ is
+ where
+ mk :: GenIO -> IO Int
+ mk = uniformR (0,15)
------------------------------------------------------------------------------
-- | Generate a randomized CSRF token
-mkCSRFToken :: IO Text
-mkCSRFToken = T.decodeUtf8 `fmap` randomToken 40
+--
+mkCSRFToken :: RNG -> IO Text
+mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng
+------------------------------------------------------------------------------
instance Serialize Text where
- put = S.put . T.encodeUtf8
- get = T.decodeUtf8 `fmap` S.get
+ put = S.put . T.encodeUtf8
+ get = T.decodeUtf8 <$> S.get
View
56 src/Snap/Snaplet/Session/SecureCookie.hs
@@ -1,34 +1,29 @@
{-# LANGUAGE OverloadedStrings #-}
-{-|
-
- This is a support module meant to back all session back-end implementations.
-
- It gives us an encrypted and timestamped cookie that can store an arbitrary
- serializable payload. For security, it will:
-
- * Encrypt its payload together with a timestamp.
-
- * Check the timestamp for session expiration everytime you read from the
- cookie. This will limit intercept-and-replay attacks by disallowing
- cookies older than the timeout threshold.
-
--}
+------------------------------------------------------------------------------
+-- | This is a support module meant to back all session back-end
+-- implementations.
+--
+-- It gives us an encrypted and timestamped cookie that can store an arbitrary
+-- serializable payload. For security, it will:
+--
+-- * Encrypt its payload together with a timestamp.
+--
+-- * Check the timestamp for session expiration everytime you read from the
+-- cookie. This will limit intercept-and-replay attacks by disallowing
+-- cookies older than the timeout threshold.
module Snap.Snaplet.Session.SecureCookie where
+------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
-
import Data.ByteString (ByteString)
import Data.Time
import Data.Time.Clock.POSIX
-
import Data.Serialize
-import Web.ClientSession
-
import Snap.Core
-
+import Web.ClientSession
------------------------------------------------------------------------------
@@ -52,17 +47,17 @@ getSecureCookie :: (MonadSnap m, Serialize t)
-> m (Maybe t)
getSecureCookie name key timeout = do
rqCookie <- getCookie name
- rspCookie <- getResponseCookie name `fmap` getResponse
+ rspCookie <- getResponseCookie name <$> getResponse
let ck = rspCookie `mplus` rqCookie
let val = fmap cookieValue ck >>= decrypt key >>= return . decode
let val' = val >>= either (const Nothing) Just
case val' of
Nothing -> return Nothing
Just (ts, t) -> do
- to <- checkTimeout timeout ts
- return $ case to of
- True -> Nothing
- False -> Just t
+ to <- checkTimeout timeout ts
+ return $ case to of
+ True -> Nothing
+ False -> Just t
------------------------------------------------------------------------------
@@ -85,12 +80,11 @@ setSecureCookie name key to val = do
-- | Validate session against timeout policy.
--
-- * If timeout is set to 'Nothing', never trigger a time-out.
--- * Othwerwise, do a regular time-out check based on current time and given
--- timestamp.
+--
+-- * Otherwise, do a regular time-out check based on current time and given
+-- timestamp.
checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool
checkTimeout Nothing _ = return False
-checkTimeout (Just x) t0 =
- let x' = fromIntegral x
- in do
- t1 <- liftIO getCurrentTime
- return $ t1 > addUTCTime x' t0
+checkTimeout (Just x) t0 = do
+ t1 <- liftIO getCurrentTime
+ return $ t1 > addUTCTime (fromIntegral x) t0
Please sign in to comment.
Something went wrong with that request. Please try again.