Skip to content
This repository
file 128 lines (106 sloc) 3.922 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
module Snap.Snaplet.Session
  ( SessionManager
  , withSession
  , commitSession
  , setInSession
  , getFromSession
  , deleteFromSession
  , csrfToken
  , sessionToList
  , resetSession
  , touchSession

  -- * Utilities Exported For Convenience
  , module Snap.Snaplet.Session.Common
  , module Snap.Snaplet.Session.SecureCookie
  ) where

------------------------------------------------------------------------------
import Control.Monad.State
import Data.Text (Text)
import Snap.Core
------------------------------------------------------------------------------
import Snap.Snaplet
import Snap.Snaplet.Session.Common
import Snap.Snaplet.Session.SecureCookie
import Snap.Snaplet.Session.SessionManager
                   ( ISessionManager(..), SessionManager(..) )
import qualified Snap.Snaplet.Session.SessionManager as SM
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Wrap around a handler, committing any changes in the session at the end
--
withSession :: SnapletLens b SessionManager
            -> Handler b v a
            -> Handler b v a
withSession l h = do
    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


------------------------------------------------------------------------------
-- | 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'


------------------------------------------------------------------------------
-- | 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


------------------------------------------------------------------------------
-- | 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'


------------------------------------------------------------------------------
-- | 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


------------------------------------------------------------------------------
-- | Return session contents as an association list
--
sessionToList :: Handler b SessionManager [(Text, Text)]
sessionToList = do
    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'


------------------------------------------------------------------------------
-- | 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'


------------------------------------------------------------------------------
-- | Load the session into the manager
--
loadSession :: Handler b SessionManager SessionManager
loadSession = do
    SessionManager r <- get
    r' <- liftSnap $ load r
    return $ SessionManager r'
Something went wrong with that request. Please try again.