From 55fa6cbba0f53d8ccd24bf19e493d143a5e4c7da Mon Sep 17 00:00:00 2001 From: Kari Pahula Date: Tue, 6 May 2025 21:03:49 +0300 Subject: [PATCH] Generalize ISessionManager load/commit/reset to use Handler Add a type variable to SessionManger for Handler's base snaplet. --- src/Snap/Snaplet/Auth/AuthManager.hs | 2 +- src/Snap/Snaplet/Auth/Backends/JsonFile.hs | 2 +- src/Snap/Snaplet/Auth/Handlers.hs | 6 ++--- src/Snap/Snaplet/Session.hs | 27 +++++++++---------- .../Snaplet/Session/Backends/CookieSession.hs | 24 ++++++++++------- src/Snap/Snaplet/Session/SessionManager.hs | 17 ++++++------ test/suite/Snap/Snaplet/Test/Common/Types.hs | 2 +- 7 files changed, 43 insertions(+), 37 deletions(-) diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs index 5550659d..85ab8bfe 100644 --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/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 diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs index 1e9dfa00..43f4cc4e 100644 --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/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 diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs index 1b9de666..17175c44 100644 --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/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 diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs index f85f2278..f125539b 100644 --- a/src/Snap/Snaplet/Session.hs +++ b/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' diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs index 48cc6265..37df9fad 100644 --- a/src/Snap/Snaplet/Session/Backends/CookieSession.hs +++ b/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 diff --git a/src/Snap/Snaplet/Session/SessionManager.hs b/src/Snap/Snaplet/Session/SessionManager.hs index 0364a443..9f183819 100644 --- a/src/Snap/Snaplet/Session/SessionManager.hs +++ b/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 diff --git a/test/suite/Snap/Snaplet/Test/Common/Types.hs b/test/suite/Snap/Snaplet/Test/Common/Types.hs index a9f560ac..dc347ea0 100644 --- a/test/suite/Snap/Snaplet/Test/Common/Types.hs +++ b/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 }