module Snap.Snaplet.TypedSession.Client (
ClientSessionManager,
initClientSessions,
module Snap.Snaplet.TypedSession
) where
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Serialize (Serialize)
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Session (getSecureCookie, setSecureCookie)
import Snap.Snaplet.TypedSession
import Web.ClientSession
data ClientSessionManager t = ClientSessionManager {
clientSessionCache :: Maybe t,
clientSessionName :: ByteString,
clientSessionKey :: Key,
clientSessionDefault :: IO t,
clientSessionTimeout :: Maybe Int
}
initClientSessions :: Serialize t
=> FilePath
-> ByteString
-> Maybe Int
-> IO t
-> SnapletInit b (ClientSessionManager t)
initClientSessions fp name timeout defaulter =
makeSnaplet "TypedSession.Client"
"Typed sessions stored in client-side cookies"
Nothing $ liftIO $ do
key <- getKey fp
return $! ClientSessionManager Nothing name key defaulter timeout
getSessionImpl :: Serialize t => Handler b (ClientSessionManager t) t
getSessionImpl = do
mgr <- get
case clientSessionCache mgr of
Just val -> return val
Nothing -> do
mval <- getSecureCookie (clientSessionName mgr)
(clientSessionKey mgr)
(clientSessionTimeout mgr)
case mval of
Just v -> do
put (mgr { clientSessionCache = Just v })
return v
Nothing -> do
v <- liftIO (clientSessionDefault mgr)
setSession v
return v
setSessionImpl :: Serialize t => t -> Handler b (ClientSessionManager t) ()
setSessionImpl val = do
mgr <- get
put (mgr { clientSessionCache = Just val })
setSecureCookie (clientSessionName mgr)
(clientSessionKey mgr)
(clientSessionTimeout mgr)
val
touchSessionImpl :: Serialize t => Handler b (ClientSessionManager t) ()
touchSessionImpl = getSession >>= setSession
clearSessionImpl :: Serialize t => Handler b (ClientSessionManager t) ()
clearSessionImpl = do
mgr <- get
put (mgr { clientSessionCache = Nothing })
expireCookie (clientSessionName mgr) Nothing
instance Serialize t => HasTypedSession (ClientSessionManager t) t where
getSession = getSessionImpl
setSession = setSessionImpl
touchSession = touchSessionImpl
clearSession = clearSessionImpl