Skip to content
This repository
Newer
Older
100644 104 lines (78 sloc) 2.584 kb
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
1 module Snap.Snaplet.Session
2
3 (
4 SessionManager
5 , withSession
6 , commitSession
7 , setInSession
8 , getFromSession
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
9 , deleteFromSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
10 , csrfToken
11 , sessionToList
12 , resetSession
13 , touchSession
14
15 ) where
16
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
17 import Control.Monad.State
c28c4b4e » mightybyte
2011-08-11 Switched from fclabels to data-lens.
18 import Data.Lens.Lazy
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
19 import Data.Text (Text)
20
21 import Snap.Snaplet
f14faee0 » gregorycollins
2011-08-13 Rename Snap.Types to Snap.Core
22 import Snap.Core
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
23
24 import Snap.Snaplet.Session.SessionManager
25 ( SessionManager(..), ISessionManager(..) )
26 import qualified Snap.Snaplet.Session.SessionManager as SM
27
28
29
30 -- | Wrap around a handler, committing any changes in the session at the end
c28c4b4e » mightybyte
2011-08-11 Switched from fclabels to data-lens.
31 withSession :: (Lens b (Snaplet SessionManager)) -> Handler b v a -> Handler b v a
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
32 withSession l h = do
33 a <- h
bab25799 » mightybyte
2011-07-27 Renamed withChild and withSibling, and removed withBase.
34 withTop l commitSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
35 return a
36
37
38 -- | Commit changes to session within the current request cycle
39 commitSession :: Handler b SessionManager ()
40 commitSession = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
41 SessionManager b <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
42 liftSnap $ commit b
43
44
45 -- | Set a key-value pair in the current session
46 setInSession :: Text -> Text -> Handler b SessionManager ()
47 setInSession k v = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
48 SessionManager r <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
49 let r' = SM.insert k v r
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
50 put $ SessionManager r'
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
51
52
53 -- | Get a key from the current session
54 getFromSession :: Text -> Handler b SessionManager (Maybe Text)
55 getFromSession k = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
56 SessionManager r <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
57 return $ SM.lookup k r
58
59
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
60 -- | Remove a key from the current session
61 deleteFromSession :: Text -> Handler b SessionManager ()
62 deleteFromSession k = do
63 SessionManager r <- loadSession
64 let r' = SM.delete k r
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
65 put $ SessionManager r'
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
66
67
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
68 -- | Returns a CSRF Token unique to the current session
69 csrfToken :: Handler b SessionManager Text
70 csrfToken = do
71 mgr@(SessionManager r) <- loadSession
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
72 put mgr
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
73 return $ SM.csrf r
74
75
76 -- | Return session contents as an association list
77 sessionToList :: Handler b SessionManager [(Text, Text)]
78 sessionToList = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
79 SessionManager r <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
80 return $ SM.toList r
81
82
83 -- | Deletes the session cookie, effectively resetting the session
84 resetSession :: Handler b SessionManager ()
85 resetSession = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
86 SessionManager r <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
87 r' <- liftSnap $ SM.reset r
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
88 put $ SessionManager r'
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
89
90
91 -- | Touch the session so the timeout gets refreshed
92 touchSession :: Handler b SessionManager ()
93 touchSession = do
21cf4fd9 » ozataman
2011-07-31 Add deleteFromSession to Snaplet.Session
94 SessionManager r <- loadSession
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
95 let r' = SM.touch r
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
96 put $ SessionManager r'
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
97
98
99 -- | Load the session into the manager
100 loadSession :: Handler b SessionManager SessionManager
101 loadSession = do
d7873449 » mightybyte
2011-09-29 Change Handler's MonadState instance to use state of v rather than Sn…
102 SessionManager r <- get
b0fadff5 » mightybyte
2011-07-25 Alpha release of new snaplet infrastructure.
103 r' <- liftSnap $ load r
104 return $ SessionManager r'
105
Something went wrong with that request. Please try again.