Permalink
Browse files

pull session functionality into repo with various enhancements

  • Loading branch information...
1 parent 44bd95c commit 8222cbcc9dc990ef0fae0b7ecd3bc41b7fc8f9f6 @ozataman ozataman committed Jan 7, 2011
@@ -0,0 +1,115 @@
+{-|
+
+-}
+
+module Snap.Extension.Session
+ (
+ SessionShell(..)
+ , defSessionShell
+ , Session
+ , MonadSession(..)
+ ) where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.ByteString (ByteString)
+import qualified Data.Map as Map
+
+import Snap.Types
+import Snap.Extension.Session.Types
+import Snap.Extension.Session.Common (randomToken)
+
+
+------------------------------------------------------------------------------
+-- | The 'MonadCookieSession' class.
+class MonadSnap m => MonadSession m where
+
+ ----------------------------------------------------------------------------
+ getSessionShell :: m SessionShell
+
+
+ ----------------------------------------------------------------------------
+ setSessionShell :: SessionShell -> m ()
+
+
+ ----------------------------------------------------------------------------
+ updateSessionShell :: (SessionShell -> SessionShell) -> m ()
+ updateSessionShell f = do
+ ssh <- getSessionShell
+ setSessionShell $ f ssh
+
+
+ ----------------------------------------------------------------------------
+ getSessionUserId :: m (Maybe UserId)
+ getSessionUserId = fmap sesUserId getSessionShell
+
+
+ ----------------------------------------------------------------------------
+ setSessionUserId :: Maybe UserId -> m ()
+ setSessionUserId uid = updateSessionShell f
+ where f s = s { sesUserId = uid }
+
+
+ ----------------------------------------------------------------------------
+ sessionCSRFToken :: m ByteString
+ sessionCSRFToken = do
+ csrf <- liftM sesCSRFToken getSessionShell
+ case csrf of
+ Nothing -> do
+ t <- liftIO randomToken
+ updateSessionShell (\s -> s { sesCSRFToken = Just t })
+ return t
+ Just t -> return t
+
+
+ ----------------------------------------------------------------------------
+ -- | Function to get the session in your app's monad.
+ --
+ -- This will return a @Map ByteString ByteString@ data type, which you can
+ -- then use freely to read/write values.
+ getSession :: m Session
+ getSession = fmap sesSession getSessionShell
+
+
+ ----------------------------------------------------------------------------
+ -- | Set the session in your app's monad.
+ setSession :: Session -> m ()
+ setSession s = updateSessionShell f
+ where f ssh = ssh { sesSession = s }
+
+
+ ------------------------------------------------------------------------------
+ -- | Get a value associated with given key from the 'Session'.
+ getFromSession :: ByteString -> m (Maybe ByteString)
+ getFromSession k = Map.lookup k `liftM` getSession
+
+
+ ------------------------------------------------------------------------------
+ -- | Remove the given key from 'Session'
+ deleteFromSession :: ByteString -> m ()
+ deleteFromSession k = Map.delete k `liftM` getSession >>= setSession
+
+
+ ------------------------------------------------------------------------------
+ -- | Set a value in the 'Session'.
+ setInSession :: ByteString
+ -> ByteString
+ -> m ()
+ setInSession k v = Map.insert k v `liftM` getSession >>= setSession
+
+
+ ----------------------------------------------------------------------------
+ -- | Clear the active session. Uses 'setSession'.
+ clearSession :: m ()
+ clearSession = setSession Map.empty
+
+
+ ----------------------------------------------------------------------------
+ -- | Touch session to reset the timeout. You can chain a handler to call this
+ -- in every authenticated route to keep prolonging the session with each
+ -- request.
+ touchSession :: m ()
+ touchSession = getSession >>= setSession
+
+
+
@@ -0,0 +1,25 @@
+{-|
+
+ This module contains functionality common among multiple back-ends.
+
+-}
+
+module Snap.Extension.Session.Common where
+
+
+import Numeric
+import Random
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+
+
+------------------------------------------------------------------------------
+-- | Generates a random salt.
+randomToken :: IO ByteString
+randomToken = do
+ chars <- sequence $ take 15 $ repeat $
+ randomRIO (0::Int,15) >>= return . flip showHex ""
+ return $ B.pack $ concat chars
+
+
+
@@ -0,0 +1,133 @@
+{-|
+
+ This module provides an implementation of 'Snap.Extension.Session' using
+ secure cookies shuttled back-and-forth between the web server and the user of
+ your application.
+
+ The resulting cookie contents will not be readable to the end-user. However,
+ you should still never put critical information inside the session. Storing
+ a user_id may be fine, but never put, say the remaining balance on an account
+ in a session.
+
+ Note that this method leaves your system open to replay, aka session
+ hi-jacking attacks. To prevent this, consider always on SSL.
+
+-}
+
+module Snap.Extension.Session.CookieSession
+ (
+
+ -- * Important Types
+ Session
+ , UserId(..)
+
+ -- * Key Functionality
+ , MonadSession(
+ getSession
+ , setSession
+ , getFromSession
+ , setInSession
+ , touchSession
+ , clearSession
+ , getSessionUserId
+ , setSessionUserId
+ , sessionCSRFToken)
+
+
+ -- * Cookie-based Session Instance
+ , CookieSessionState(..)
+ , defCookieSessionState
+ , HasCookieSessionState(..)
+ , cookieSessionStateInitializer
+ ) where
+
+import Control.Monad.Reader
+import Data.ByteString (ByteString)
+
+import Web.ClientSession
+
+import Snap.Extension
+import Snap.Extension.Session
+import Snap.Extension.Session.SecureCookie
+import Snap.Extension.Session.Types
+
+
+------------------------------------------------------------------------------
+-- |
+data CookieSessionState = CookieSessionState
+ { csSiteKey :: Key -- ^ Cookie encryption key
+ , csKeyPath :: FilePath -- ^ Where the encryption key is stored
+ , csCookieName :: ByteString -- ^ Cookie name for your app's session
+ , csTimeout :: Maybe Int -- ^ Replay-attack timeout in minutes
+ }
+
+
+------------------------------------------------------------------------------
+-- | 'defCookieSessionState' is a good starting point when initializing your
+-- app. The default configuration is:
+--
+-- > csKeyPath = "site_key.txt"
+-- > csCookieName = "snap-session"
+-- > csTimeout = Just 30
+-- > csAuthToken = True
+defCookieSessionState :: CookieSessionState
+defCookieSessionState = CookieSessionState
+ { csKeyPath = "site_key.txt"
+ , csSiteKey = ""
+ , csCookieName = "snap-session"
+ , csTimeout = Just 30
+ }
+
+
+------------------------------------------------------------------------------
+-- |
+class HasCookieSessionState s where
+
+ ----------------------------------------------------------------------------
+ -- | Getter to get 'CookieSessionState' from your app's state.
+ getCookieSessionState :: s -> CookieSessionState
+
+------------------------------------------------------------------------------
+-- | Initializes the given 'CookieSessionState'. It will read the encryption
+-- key if present, create one at random and save if missing.
+cookieSessionStateInitializer
+ :: CookieSessionState
+ -> Initializer CookieSessionState
+cookieSessionStateInitializer cs = do
+ st <- liftIO $ do
+ k <- getKey (csKeyPath cs)
+ return $ cs { csSiteKey = k }
+ mkInitializer st
+
+
+------------------------------------------------------------------------------
+-- | Register CookieSessionState as an Extension.
+instance InitializerState CookieSessionState where
+ extensionId = const "Session/CookieSession"
+ mkCleanup = const $ return ()
+ mkReload = const $ return ()
+
+
+------------------------------------------------------------------------------
+-- |
+instance HasCookieSessionState s => MonadSession (SnapExtend s) where
+
+ ----------------------------------------------------------------------------
+ -- | Serialize the session, inject into cookie, modify response.
+ setSessionShell t = do
+ cs <- asks getCookieSessionState
+ setSecureCookie (csCookieName cs) (csSiteKey cs) t
+
+
+ ----------------------------------------------------------------------------
+ -- | Read the session from the cookie. If none is present, return default
+ -- (empty) session.
+ getSessionShell = do
+ cs <- asks getCookieSessionState
+ let cn = csCookieName cs
+ let key = csSiteKey cs
+ let timeout = csTimeout cs
+ d <- getSecureCookie cn key timeout
+ return $ maybe defSessionShell id d
+
+
@@ -0,0 +1,93 @@
+{-|
+
+ 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 threshould from being effective in your application.
+
+-}
+
+module Snap.Extension.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.Types
+
+
+
+------------------------------------------------------------------------------
+-- | Serialize UTCTime
+instance Serialize UTCTime where
+ put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)
+ get = posixSecondsToUTCTime . fromInteger <$> get
+
+
+------------------------------------------------------------------------------
+-- | Arbitrary payload with timestamp.
+type SecureCookie t = (UTCTime, t)
+
+
+------------------------------------------------------------------------------
+-- Get the payload back
+getSecureCookie :: (MonadSnap m, Serialize t)
+ => ByteString -- ^ Cookie name
+ -> Key -- ^ Encryption key
+ -> Maybe Int -- ^ Timeout
+ -> m (Maybe t)
+getSecureCookie name key timeout = do
+ rqCookie <- getCookie name
+ rspCookie <- getResponseCookie name `fmap` 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
+
+
+------------------------------------------------------------------------------
+-- | Inject the payload
+setSecureCookie :: (MonadSnap m, Serialize t)
+ => ByteString -- ^ Cookie name
+ -> Key -- ^ Encryption key
+ -> t -- ^ Serializable payload
+ -> m ()
+setSecureCookie name key val = do
+ t <- liftIO getCurrentTime
+ let val' = encrypt key . encode $ (t, val)
+ let nc = Cookie name val' Nothing Nothing (Just "/")
+ modifyResponse $ addResponseCookie nc
+
+
+------------------------------------------------------------------------------
+-- | 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.
+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' * 60) t0
Oops, something went wrong.

0 comments on commit 8222cbc

Please sign in to comment.