Generalize ISessionManager load/commit/reset to use Handler

src/Snap/Snaplet/Auth/AuthManager.hs

@@ -70,7 +70,7 @@ data AuthManager b = forall r. IAuthBackend r => AuthManager {
       backend               :: r
         -- ^ Storage back-end
 
-    , session               :: SnapletLens b SessionManager
+    , session               :: SnapletLens b (SessionManager b)
         -- ^ A lens pointer to a SessionManager
 
     , activeUser            :: Maybe AuthUser

src/Snap/Snaplet/Auth/Backends/JsonFile.hs

@@ -44,7 +44,7 @@ import           Snap.Snaplet.Session
 -- | Initialize a JSON file backed 'AuthManager'
 initJsonFileAuthManager :: AuthSettings
                             -- ^ Authentication settings for your app
-                        -> SnapletLens b SessionManager
+                        -> SnapletLens b (SessionManager b)
                             -- ^ Lens into a 'SessionManager' auth snaplet will
                            -- use
                         -> FilePath

src/Snap/Snaplet/Auth/Handlers.hs

@@ -335,20 +335,20 @@ setRememberToken sk rc rd rp token = setSecureCookie rc rd sk rp token
 ------------------------------------------------------------------------------
 -- | Set the current user's 'UserId' in the active session
 --
-setSessionUserId :: UserId -> Handler b SessionManager ()
+setSessionUserId :: UserId -> Handler b (SessionManager b) ()
 setSessionUserId (UserId t) = setInSession "__user_id" t
 
 
 ------------------------------------------------------------------------------
 -- | Remove 'UserId' from active session, effectively logging the user out.
-removeSessionUserId :: Handler b SessionManager ()
+removeSessionUserId :: Handler b (SessionManager b) ()
 removeSessionUserId = deleteFromSession "__user_id"
 
 
 ------------------------------------------------------------------------------
 -- | Get the current user's 'UserId' from the active session
 --
-getSessionUserId :: Handler b SessionManager (Maybe UserId)
+getSessionUserId :: Handler b (SessionManager b) (Maybe UserId)
 getSessionUserId = do
   uid <- getFromSession "__user_id"
   return $ liftM UserId uid

src/Snap/Snaplet/Session.hs

@@ -18,7 +18,6 @@ module Snap.Snaplet.Session
 ------------------------------------------------------------------------------
 import           Control.Monad.State
 import           Data.Text                           (Text)
-import           Snap.Core
 ------------------------------------------------------------------------------
 import           Snap.Snaplet
 import           Snap.Snaplet.Session.Common
@@ -32,7 +31,7 @@ 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
+withSession :: SnapletLens b (SessionManager b)
             -> Handler b v a
             -> Handler b v a
 withSession l h = do
@@ -44,16 +43,16 @@ withSession l h = do
 ------------------------------------------------------------------------------
 -- | Commit changes to session within the current request cycle
 --
-commitSession :: Handler b SessionManager ()
+commitSession :: Handler b (SessionManager b) ()
 commitSession = do
     SessionManager b <- loadSession
-    liftSnap $ commit b
+    commit b
 
 
 ------------------------------------------------------------------------------
 -- | Set a key-value pair in the current session
 --
-setInSession :: Text -> Text -> Handler b SessionManager ()
+setInSession :: Text -> Text -> Handler b (SessionManager b) ()
 setInSession k v = do
     SessionManager r <- loadSession
     let r' = SM.insert k v r
@@ -63,7 +62,7 @@ setInSession k v = do
 ------------------------------------------------------------------------------
 -- | Get a key from the current session
 --
-getFromSession :: Text -> Handler b SessionManager (Maybe Text)
+getFromSession :: Text -> Handler b (SessionManager b) (Maybe Text)
 getFromSession k = do
     SessionManager r <- loadSession
     return $ SM.lookup k r
@@ -72,7 +71,7 @@ getFromSession k = do
 ------------------------------------------------------------------------------
 -- | Remove a key from the current session
 --
-deleteFromSession :: Text -> Handler b SessionManager ()
+deleteFromSession :: Text -> Handler b (SessionManager b) ()
 deleteFromSession k = do
     SessionManager r <- loadSession
     let r' = SM.delete k r
@@ -82,7 +81,7 @@ deleteFromSession k = do
 ------------------------------------------------------------------------------
 -- | Returns a CSRF Token unique to the current session
 --
-csrfToken :: Handler b SessionManager Text
+csrfToken :: Handler b (SessionManager b) Text
 csrfToken = do
     mgr@(SessionManager r) <- loadSession
     put mgr
@@ -92,7 +91,7 @@ csrfToken = do
 ------------------------------------------------------------------------------
 -- | Return session contents as an association list
 --
-sessionToList :: Handler b SessionManager [(Text, Text)]
+sessionToList :: Handler b (SessionManager b) [(Text, Text)]
 sessionToList = do
     SessionManager r <- loadSession
     return $ SM.toList r
@@ -101,17 +100,17 @@ sessionToList = do
 ------------------------------------------------------------------------------
 -- | Deletes the session cookie, effectively resetting the session
 --
-resetSession :: Handler b SessionManager ()
+resetSession :: Handler b (SessionManager b) ()
 resetSession = do
     SessionManager r <- loadSession
-    r' <- liftSnap $ SM.reset r
+    r' <- SM.reset r
     put $ SessionManager r'
 
 
 ------------------------------------------------------------------------------
 -- | Touch the session so the timeout gets refreshed
 --
-touchSession :: Handler b SessionManager ()
+touchSession :: Handler b (SessionManager b) ()
 touchSession = do
     SessionManager r <- loadSession
     let r' = SM.touch r
@@ -121,9 +120,9 @@ touchSession = do
 ------------------------------------------------------------------------------
 -- | Load the session into the manager
 --
-loadSession :: Handler b SessionManager SessionManager
+loadSession :: Handler b (SessionManager b) (SessionManager b)
 loadSession = do
     SessionManager r <- get
-    r' <- liftSnap $ load r
+    r' <- load r
     return $ SessionManager r'
 

src/Snap/Snaplet/Session/Backends/CookieSession.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TypeApplications           #-}
 
 module Snap.Snaplet.Session.Backends.CookieSession
     ( initCookieSessionManager
@@ -18,7 +19,7 @@ import           Data.Serialize                      (Serialize)
 import qualified Data.Serialize                      as S
 import           Data.Text                           (Text)
 import           Data.Text.Encoding
-import           Snap.Core                           (Snap)
+import           Snap.Core                           (MonadSnap)
 import           Web.ClientSession
 
 #if !MIN_VERSION_base(4,8,0)
@@ -75,7 +76,7 @@ mkCookieSession rng = do
 ------------------------------------------------------------------------------
 -- | The manager data type to be stuffed into 'SessionManager'
 --
-data CookieSessionManager = CookieSessionManager {
+data CookieSessionManager b = CookieSessionManager {
       session               :: Maybe CookieSession
         -- ^ Per request cache for 'CookieSession'
     , siteKey               :: Key
@@ -95,7 +96,7 @@ data CookieSessionManager = CookieSessionManager {
 
 
 ------------------------------------------------------------------------------
-loadDefSession :: CookieSessionManager -> IO CookieSessionManager
+loadDefSession :: CookieSessionManager b -> IO (CookieSessionManager b)
 loadDefSession mgr@(CookieSessionManager ses _ _ _ _ rng) =
     case ses of
       Nothing -> do ses' <- mkCookieSession rng
@@ -115,22 +116,27 @@ modSession f (CookieSession t ses) = CookieSession t (f ses)
 -- 'Snap.Snaplet.Session'
 --
 initCookieSessionManager
-    :: FilePath             -- ^ Path to site-wide encryption key
+    :: forall b.
+       FilePath             -- ^ Path to site-wide encryption key
     -> ByteString           -- ^ Session cookie name
     -> Maybe ByteString     -- ^ Session cookie domain
     -> Maybe Int            -- ^ Session time-out (replay attack protection)
-    -> SnapletInit b SessionManager
+    -> SnapletInit b (SessionManager b)
 initCookieSessionManager fp cn dom to =
     makeSnaplet "CookieSession"
                 "A snaplet providing sessions via HTTP cookies."
                 Nothing $ liftIO $ do
         key <- getKey fp
         rng <- liftIO mkRNG
-        return $! SessionManager $ CookieSessionManager Nothing key cn dom to rng
+        return $! SessionManager @_
+          @(CookieSessionManager (Handler b (SessionManager b)
+                                  (SessionManager b))) $
+          CookieSessionManager Nothing key cn dom to rng
 
 
 ------------------------------------------------------------------------------
-instance ISessionManager CookieSessionManager where
+instance ISessionManager (CookieSessionManager (Handler b (SessionManager b)
+                                                a)) b where
 
     --------------------------------------------------------------------------
     load mgr@(CookieSessionManager r _ _ _ _ _) =
@@ -194,12 +200,12 @@ newtype Payload = Payload ByteString
 
 ------------------------------------------------------------------------------
 -- | Get the current client-side value
-getPayload :: CookieSessionManager -> Snap (Maybe Payload)
+getPayload :: MonadSnap m => CookieSessionManager b -> m (Maybe Payload)
 getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)
 
 
 ------------------------------------------------------------------------------
 -- | Set the client-side value
-setPayload :: CookieSessionManager -> Payload -> Snap ()
+setPayload :: MonadSnap m => CookieSessionManager b -> Payload -> m ()
 setPayload mgr x = setSecureCookie (cookieName mgr) (cookieDomain mgr)
                                    (siteKey mgr) (timeOut mgr) x

src/Snap/Snaplet/Session/SessionManager.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FunctionalDependencies    #-}
 
 {-| This module is meant to be used mainly by Session backend
 developers, who would naturally need access to ISessionManager class
@@ -8,10 +9,10 @@ backend functionality.-}
 module Snap.Snaplet.Session.SessionManager where
 
 -------------------------------------------------------------------------------
-import           Data.Text (Text)
-import           Prelude   hiding (lookup)
+import           Data.Text    (Text)
+import           Prelude      hiding (lookup)
 -------------------------------------------------------------------------------
-import           Snap.Core (Snap)
+import           Snap.Snaplet (Handler)
 -------------------------------------------------------------------------------
 
 
@@ -25,22 +26,22 @@ import           Snap.Core (Snap)
 -- 'initCookieSessionManager' in
 -- 'Snap.Snaplet.Session.Backends.CookieSession' for a built-in option
 -- that would get you started.
-data SessionManager = forall a. ISessionManager a => SessionManager a
+data SessionManager b = forall a. ISessionManager a b => SessionManager a
 
 
-class ISessionManager r where
+class ISessionManager r b | r -> b where
 
   -- | Load a session from given payload.
   --
   -- Will always be called before any other operation. If possible, cache and
   -- do nothing when called multiple times within the same request cycle.
-  load :: r -> Snap r
+  load :: r -> Handler b (SessionManager b) r
 
   -- | Commit session, return a possibly updated paylaod
-  commit :: r -> Snap ()
+  commit :: r -> Handler b (SessionManager b) ()
 
   -- | Reset session
-  reset :: r -> Snap r
+  reset :: r -> Handler b (SessionManager b) r
 
   -- | Touch session
   touch :: r -> r

test/suite/Snap/Snaplet/Test/Common/Types.hs

@@ -19,7 +19,7 @@ data App = App
     , _foo      :: Snaplet FooSnaplet
     , _auth     :: Snaplet (AuthManager App)
     , _bar      :: Snaplet (BarSnaplet App)
-    , _session  :: Snaplet SessionManager
+    , _session  :: Snaplet (SessionManager App)
     , _embedded :: Snaplet EmbeddedSnaplet
     }