Client.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
    This is the client-side cookie-backed implementation of typed
    sessions.  Because all data is stored on the client, this session
    back-end is easier to use in load balanced settings, and session
    timeouts are optional.  All session data is encrypted so that it
    cannot be read by the client itself.  However, it has the
    disadvantage of only being able to store serializable data types.
-}
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


{-|
    The typed session manager that stores session data directly in
    encrypted client-side cookies.
-}
data ClientSessionManager t = ClientSessionManager {
    clientSessionCache   :: Maybe t,
    clientSessionName    :: ByteString,
    clientSessionKey     :: Key,
    clientSessionDefault :: IO t,
    clientSessionTimeout :: Maybe Int
    }


{-|
    Initializer for the cookie-backed typed session snaplet.
-}
initClientSessions :: Serialize t
                   => FilePath   -- ^ Location of an encryption key
                   -> ByteString -- ^ Name for the session cookie
                   -> Maybe Int  -- ^ Optional session timeout in seconds
                   -> IO t       -- ^ Initializer for new sessions
                   -> 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
        -- TODO: Maybe wrap routes with touchSession?


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