From 1e130087cb412ce25e768346a9676a88426bed11 Mon Sep 17 00:00:00 2001 From: tusharad Date: Wed, 4 Dec 2024 02:24:02 +0530 Subject: [PATCH 1/5] Implemented user sessions #317 --- Web/Scotty.hs | 11 ++- Web/Scotty/Session.hs | 186 +++++++++++++++++++++++++++++++++++++++++ Web/Scotty/Trans.hs | 9 +- examples/session.hs | 31 +++++++ scotty.cabal | 4 +- test/Web/ScottySpec.hs | 15 ++++ 6 files changed, 252 insertions(+), 4 deletions(-) create mode 100644 Web/Scotty/Session.hs create mode 100644 examples/session.hs diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 415c8a1..45ea4f7 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -55,7 +55,11 @@ module Web.Scotty , ScottyM, ActionM, RoutePattern, File, Content(..), Kilobytes, ErrorHandler, Handler(..) , ScottyState, defaultScottyState -- ** Functions from Cookie module - , setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie + , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie + -- ** Session Management + , Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions ) where import qualified Web.Scotty.Trans as Trans @@ -76,7 +80,10 @@ import qualified Network.Wai.Parse as W import Web.FormUrlEncoded (FromForm) import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..)) import UnliftIO.Exception (Handler(..), catch) -import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie) +import Web.Scotty.Cookie (setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie) +import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) {- $setup >>> :{ diff --git a/Web/Scotty/Session.hs b/Web/Scotty/Session.hs new file mode 100644 index 0000000..431021f --- /dev/null +++ b/Web/Scotty/Session.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Web.Scotty.Cookie +Copyright : (c) 2014, 2015 Mārtiņš Mačs, + (c) 2023 Marco Zocca + +License : BSD-3-Clause +Maintainer : +Stability : experimental +Portability : GHC + +This module provides session management functionality for Scotty web applications. + +==Example usage: + +@ +\{\-\# LANGUAGE OverloadedStrings \#\-\} + +import Web.Scotty +import Web.Scotty.Session +import Control.Monad.IO.Class (liftIO) +main :: IO () +main = do + -- Create a session jar + sessionJar <- createSessionJar + scotty 3000 $ do + -- Route to create a session + get "/create" $ do + sess <- createUserSession sessionJar "user data" + html $ "Session created with ID: " <> sessId sess + -- Route to read a session + get "/read" $ do + mSession <- getUserSession sessionJar + case mSession of + Nothing -> html "No session found or session expired." + Just sess -> html $ "Session content: " <> sessContent sess +@ +-} +module Web.Scotty.Session ( + Session (..), + SessionId, + SessionJar, + + -- * Create Session Jar + createSessionJar, + + -- * Create session + createUserSession, + createSession, + + -- * Read session + readUserSession, + readSession, + getUserSession, + getSession, + + -- * Add session + addSession, + + -- * Delte session + deleteSession, + + -- * Helper functions + maintainSessions, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) +import System.Random (randomRIO) +import Web.Scotty.Action (ActionT) +import Web.Scotty.Cookie + +-- | Type alias for session identifiers. +type SessionId = T.Text + +-- | Represents a session containing an ID, expiration time, and content. +data Session a = Session + { sessId :: SessionId + -- ^ Unique identifier for the session. + , sessExpiresAt :: UTCTime + -- ^ Expiration time of the session. + , sessContent :: a + -- ^ Content stored in the session. + } + deriving (Eq, Show) + +-- | Type for session storage, a transactional variable containing a map of session IDs to sessions. +type SessionJar a = TVar (HM.HashMap SessionId (Session a)) + +-- | Creates a new session jar and starts a background thread to maintain it. +createSessionJar :: IO (SessionJar a) +createSessionJar = do + storage <- liftIO $ newTVarIO HM.empty + _ <- liftIO $ forkIO $ maintainSessions storage + return storage + +-- | Continuously removes expired sessions from the session jar. +maintainSessions :: SessionJar a -> IO () +maintainSessions sessionJar = + do + now <- getCurrentTime + let stillValid sess = sessExpiresAt sess > now + atomically $ modifyTVar sessionJar $ \m -> HM.filter stillValid m + threadDelay 1000000 + maintainSessions sessionJar + +-- | Adds a new session to the session jar. +addSession :: SessionJar a -> Session a -> IO () +addSession sessionJar sess = + atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m + +-- | Retrieves a session by its ID from the session jar. +getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Maybe (Session a)) +getSession sessionJar sId = + do + s <- liftIO $ readTVarIO sessionJar + return $ HM.lookup sId s + +-- | Deletes a session by its ID from the session jar. +deleteSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m () +deleteSession sessionJar sId = + liftIO $ + atomically $ + modifyTVar sessionJar $ + HM.delete sId + +{- | Retrieves the current user's session based on the "sess_id" cookie. +| Returns 'Nothing' if the session is expired or does not exist. +-} +getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Maybe (Session a)) +getUserSession sessionJar = do + mSid <- getCookie "sess_id" + case mSid of + Nothing -> return Nothing + Just sid -> do + mSession <- lookupSession sid + case mSession of + Nothing -> return Nothing + Just sess -> do + now <- liftIO getCurrentTime + if sessExpiresAt sess < now + then do + deleteSession sessionJar (sessId sess) + return Nothing + else return $ Just sess + where + lookupSession = getSession sessionJar + +-- | Reads the content of a session by its ID. +readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Maybe a) +readSession sessionJar sId = do + res <- getSession sessionJar sId + return $ sessContent <$> res + +-- | Reads the content of the current user's session. +readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Maybe a) +readUserSession sessionJar = do + res <- getUserSession sessionJar + return $ sessContent <$> res + +-- | The time-to-live for sessions, in seconds. +sessionTTL :: NominalDiffTime +sessionTTL = fromIntegral 36000 -- in seconds + +-- | Creates a new session for a user, storing the content and setting a cookie. +createUserSession :: (MonadIO m) => SessionJar a -> a -> ActionT m (Session a) +createUserSession sessionJar content = do + sess <- liftIO $ createSession sessionJar content + setSimpleCookie "sess_id" (sessId sess) + return sess + +-- | Creates a new session with a generated ID, sets its expiration, and adds it to the session jar. +createSession :: SessionJar a -> a -> IO (Session a) +createSession sessionJar content = do + sId <- liftIO $ T.pack <$> replicateM 32 (randomRIO ('a', 'z')) + now <- getCurrentTime + let expiresAt = addUTCTime sessionTTL now + sess = Session sId expiresAt content + liftIO $ addSession sessionJar sess + return $ Session sId expiresAt content diff --git a/Web/Scotty/Trans.hs b/Web/Scotty/Trans.hs index b3468ea..fa84136 100644 --- a/Web/Scotty/Trans.hs +++ b/Web/Scotty/Trans.hs @@ -64,7 +64,11 @@ module Web.Scotty.Trans , ScottyT, ActionT , ScottyState, defaultScottyState -- ** Functions from Cookie module - , setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie + , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie + -- ** Session Management + , Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions ) where import Blaze.ByteString.Builder (fromByteString) @@ -90,6 +94,9 @@ import Web.Scotty.Body (newBodyInfo) import UnliftIO.Exception (Handler(..), catch) import Web.Scotty.Cookie (setSimpleCookie,getCookie,getCookies,deleteCookie,makeSimpleCookie) +import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar, + createUserSession, createSession, readUserSession, + readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) -- | Run a scotty application using the warp server. diff --git a/examples/session.hs b/examples/session.hs new file mode 100644 index 0000000..035a28c --- /dev/null +++ b/examples/session.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Web.Scotty +import qualified Data.Text.Lazy as LT +import qualified Data.Text as T + +main :: IO () +main = do + sessionJar <- liftIO createSessionJar :: IO (SessionJar T.Text) + scotty 3000 $ do + -- Login route + get "/login" $ do + username <- queryParam "username" :: ActionM String + password <- queryParam "password" :: ActionM String + if username == "foo" && password == "bar" + then do + _ <- createUserSession sessionJar "foo" + text "Login successful!" + else + text "Invalid username or password." + -- Dashboard route + get "/dashboard" $ do + mUser <- readUserSession sessionJar + case mUser of + Nothing -> text "Hello, user." + Just userName -> text $ "Hello, " <> LT.fromStrict userName <> "." + -- Logout route + get "/logout" $ do + deleteCookie "sess_id" + text "Logged out successfully." \ No newline at end of file diff --git a/scotty.cabal b/scotty.cabal index bd311a2..a347c47 100644 --- a/scotty.cabal +++ b/scotty.cabal @@ -64,6 +64,7 @@ Library Web.Scotty.Trans.Strict Web.Scotty.Internal.Types Web.Scotty.Cookie + Web.Scotty.Session other-modules: Web.Scotty.Action Web.Scotty.Body Web.Scotty.Route @@ -93,7 +94,8 @@ Library unordered-containers >= 0.2.10.0 && < 0.3, wai >= 3.0.0 && < 3.3, wai-extra >= 3.1.14, - warp >= 3.0.13 + warp >= 3.0.13, + random >= 1.0.0.0 if impl(ghc < 8.0) build-depends: fail diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index c6c36df..0b62d56 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -11,6 +11,7 @@ import Data.Char import Data.String import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL +import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as TLE import Data.Time (UTCTime(..)) import Data.Time.Calendar (fromGregorian) @@ -537,6 +538,20 @@ spec = do withApp (Scotty.get "/nested" (nested simpleApp)) $ do it "responds with the expected simpleApp response" $ do get "/nested" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "text/plain"], matchBody = "Hello, Web!"} + + describe "Session Management" $ do + withApp (Scotty.get "/scotty" $ do + sessionJar <- liftIO createSessionJar + sess <- createUserSession sessionJar ("foo" :: T.Text) + mRes <- readSession sessionJar (sessId sess) + case mRes of + Nothing -> Scotty.status status400 + Just res -> do + if res /= "foo" then Scotty.status status400 + else text "all good" + ) $ do + it "Roundtrip of session by adding and fetching a value" $ do + get "/scotty" `shouldRespondWith` 200 -- Unix sockets not available on Windows #if !defined(mingw32_HOST_OS) From 6cad2042f5bc95d673ddc738feeaac8967b48d64 Mon Sep 17 00:00:00 2001 From: tusharad Date: Wed, 4 Dec 2024 02:27:14 +0530 Subject: [PATCH 2/5] Updated changelog --- changelog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/changelog.md b/changelog.md index 102bc49..c203314 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,6 @@ ## next [????.??.??] +* Added sessions. * Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. * Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`. * Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321). From 148e5c734f1a31d9e983fc5e018dbb7c2fe0efeb Mon Sep 17 00:00:00 2001 From: tusharad Date: Tue, 31 Dec 2024 16:55:13 +0530 Subject: [PATCH 3/5] Added SessionStatus in readSession instead of Nothing --- Web/Scotty/Session.hs | 53 +++++++++++++++++++++--------------------- test/Web/ScottySpec.hs | 4 ++-- 2 files changed, 29 insertions(+), 28 deletions(-) diff --git a/Web/Scotty/Session.hs b/Web/Scotty/Session.hs index 431021f..7c718cc 100644 --- a/Web/Scotty/Session.hs +++ b/Web/Scotty/Session.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {- | Module : Web.Scotty.Cookie @@ -33,14 +34,15 @@ main = do get "/read" $ do mSession <- getUserSession sessionJar case mSession of - Nothing -> html "No session found or session expired." - Just sess -> html $ "Session content: " <> sessContent sess + Left _-> html "No session found or session expired." + Right sess -> html $ "Session content: " <> sessContent sess @ -} module Web.Scotty.Session ( Session (..), SessionId, SessionJar, + SessionStatus, -- * Create Session Jar createSessionJar, @@ -79,6 +81,10 @@ import Web.Scotty.Cookie -- | Type alias for session identifiers. type SessionId = T.Text +-- | Status of a session lookup. +data SessionStatus = SessionNotFound | SessionExpired + deriving (Show, Eq) + -- | Represents a session containing an ID, expiration time, and content. data Session a = Session { sessId :: SessionId @@ -96,19 +102,19 @@ type SessionJar a = TVar (HM.HashMap SessionId (Session a)) -- | Creates a new session jar and starts a background thread to maintain it. createSessionJar :: IO (SessionJar a) createSessionJar = do - storage <- liftIO $ newTVarIO HM.empty - _ <- liftIO $ forkIO $ maintainSessions storage + storage <- newTVarIO HM.empty + _ <- forkIO $ maintainSessions storage return storage -- | Continuously removes expired sessions from the session jar. maintainSessions :: SessionJar a -> IO () maintainSessions sessionJar = - do + forever $ do now <- getCurrentTime let stillValid sess = sessExpiresAt sess > now atomically $ modifyTVar sessionJar $ \m -> HM.filter stillValid m threadDelay 1000000 - maintainSessions sessionJar + -- | Adds a new session to the session jar. addSession :: SessionJar a -> Session a -> IO () @@ -116,11 +122,17 @@ addSession sessionJar sess = atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m -- | Retrieves a session by its ID from the session jar. -getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Maybe (Session a)) +getSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus (Session a)) getSession sessionJar sId = do s <- liftIO $ readTVarIO sessionJar - return $ HM.lookup sId s + case HM.lookup sId s of + Nothing -> pure $ Left SessionNotFound + Just sess -> do + now <- liftIO getCurrentTime + if sessExpiresAt sess < now + then deleteSession sessionJar (sessId sess) >> pure (Left SessionExpired) + else pure $ Right sess -- | Deletes a session by its ID from the session jar. deleteSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m () @@ -133,40 +145,29 @@ deleteSession sessionJar sId = {- | Retrieves the current user's session based on the "sess_id" cookie. | Returns 'Nothing' if the session is expired or does not exist. -} -getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Maybe (Session a)) +getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus (Session a)) getUserSession sessionJar = do - mSid <- getCookie "sess_id" - case mSid of - Nothing -> return Nothing - Just sid -> do - mSession <- lookupSession sid - case mSession of - Nothing -> return Nothing - Just sess -> do - now <- liftIO getCurrentTime - if sessExpiresAt sess < now - then do - deleteSession sessionJar (sessId sess) - return Nothing - else return $ Just sess + getCookie "sess_id" >>= \case + Nothing -> pure $ Left SessionNotFound + Just sid -> lookupSession sid where lookupSession = getSession sessionJar -- | Reads the content of a session by its ID. -readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Maybe a) +readSession :: (MonadIO m) => SessionJar a -> SessionId -> ActionT m (Either SessionStatus a) readSession sessionJar sId = do res <- getSession sessionJar sId return $ sessContent <$> res -- | Reads the content of the current user's session. -readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Maybe a) +readUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus a) readUserSession sessionJar = do res <- getUserSession sessionJar return $ sessContent <$> res -- | The time-to-live for sessions, in seconds. sessionTTL :: NominalDiffTime -sessionTTL = fromIntegral 36000 -- in seconds +sessionTTL = 36000 -- in seconds -- | Creates a new session for a user, storing the content and setting a cookie. createUserSession :: (MonadIO m) => SessionJar a -> a -> ActionT m (Session a) diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 0b62d56..18da6b8 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -545,8 +545,8 @@ spec = do sess <- createUserSession sessionJar ("foo" :: T.Text) mRes <- readSession sessionJar (sessId sess) case mRes of - Nothing -> Scotty.status status400 - Just res -> do + Left _ -> Scotty.status status400 + Right res -> do if res /= "foo" then Scotty.status status400 else text "all good" ) $ do From 99684e962ef4f6236a4e835497fc78fc7f7bb59d Mon Sep 17 00:00:00 2001 From: tusharad Date: Sat, 4 Jan 2025 13:49:23 +0530 Subject: [PATCH 4/5] Added ActionM versions of session functions --- Web/Scotty.hs | 43 ++++++++++++++++++++++++++++++++++-------- Web/Scotty/Session.hs | 33 ++++++++++++++++++-------------- changelog.md | 2 +- examples/session.hs | 4 ++-- test/Web/ScottySpec.hs | 2 +- 5 files changed, 58 insertions(+), 26 deletions(-) diff --git a/Web/Scotty.hs b/Web/Scotty.hs index 45ea4f7..2786415 100644 --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -57,9 +57,10 @@ module Web.Scotty -- ** Functions from Cookie module , setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie -- ** Session Management - , Session (..), SessionId, SessionJar, createSessionJar, - createUserSession, createSession, readUserSession, - readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions + , Session (..), SessionId, SessionJar, SessionStatus + , createSessionJar, createUserSession, createSession, addSession + , readSession, getUserSession, getSession, readUserSession + , deleteSession, maintainSessions ) where import qualified Web.Scotty.Trans as Trans @@ -81,9 +82,8 @@ import Web.FormUrlEncoded (FromForm) import Web.Scotty.Internal.Types (ScottyT, ActionT, ErrorHandler, Param, RoutePattern, Options, defaultOptions, File, Kilobytes, ScottyState, defaultScottyState, ScottyException, StatusError(..), Content(..)) import UnliftIO.Exception (Handler(..), catch) import Web.Scotty.Cookie (setSimpleCookie, getCookie, getCookies, deleteCookie, makeSimpleCookie) -import Web.Scotty.Session (Session (..), SessionId, SessionJar, createSessionJar, - createUserSession, createSession, readUserSession, - readSession, getUserSession, getSession, addSession, deleteSession, maintainSessions) +import Web.Scotty.Session (Session (..), SessionId, SessionJar, SessionStatus , createSessionJar, + createSession, addSession, maintainSessions) {- $setup >>> :{ @@ -601,5 +601,32 @@ literal :: String -> RoutePattern literal = Trans.literal - - +-- | Retrieves a session by its ID from the session jar. +getSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus (Session a)) +getSession = Trans.getSession + +-- | Deletes a session by its ID from the session jar. +deleteSession :: SessionJar a -> SessionId -> ActionM () +deleteSession = Trans.deleteSession + +{- | Retrieves the current user's session based on the "sess_id" cookie. +| Returns `Left SessionStatus` if the session is expired or does not exist. +-} +getUserSession :: SessionJar a -> ActionM (Either SessionStatus (Session a)) +getUserSession = Trans.getUserSession + +-- | Reads the content of a session by its ID. +readSession :: SessionJar a -> SessionId -> ActionM (Either SessionStatus a) +readSession = Trans.readSession + +-- | Reads the content of the current user's session. +readUserSession ::SessionJar a -> ActionM (Either SessionStatus a) +readUserSession = Trans.readUserSession + +-- | Creates a new session for a user, storing the content and setting a cookie. +createUserSession :: + SessionJar a -- ^ SessionJar, which can be created by createSessionJar + -> Maybe Int -- ^ Optional expiration time (in seconds) + -> a -- ^ Content + -> ActionM (Session a) +createUserSession = Trans.createUserSession diff --git a/Web/Scotty/Session.hs b/Web/Scotty/Session.hs index 7c718cc..82fb9ed 100644 --- a/Web/Scotty/Session.hs +++ b/Web/Scotty/Session.hs @@ -2,9 +2,9 @@ {-# LANGUAGE LambdaCase #-} {- | -Module : Web.Scotty.Cookie -Copyright : (c) 2014, 2015 Mārtiņš Mačs, - (c) 2023 Marco Zocca +Module : Web.Scotty.Session +Copyright : (c) 2025 Tushar Adhatrao, + (c) 2025 Marco Zocca License : BSD-3-Clause Maintainer : @@ -32,8 +32,8 @@ main = do html $ "Session created with ID: " <> sessId sess -- Route to read a session get "/read" $ do - mSession <- getUserSession sessionJar - case mSession of + eSession <- getUserSession sessionJar + case eSession of Left _-> html "No session found or session expired." Right sess -> html $ "Session content: " <> sessContent sess @ @@ -116,7 +116,7 @@ maintainSessions sessionJar = threadDelay 1000000 --- | Adds a new session to the session jar. +-- | Adds or overwrites a new session to the session jar. addSession :: SessionJar a -> Session a -> IO () addSession sessionJar sess = atomically $ modifyTVar sessionJar $ \m -> HM.insert (sessId sess) sess m @@ -143,7 +143,7 @@ deleteSession sessionJar sId = HM.delete sId {- | Retrieves the current user's session based on the "sess_id" cookie. -| Returns 'Nothing' if the session is expired or does not exist. +| Returns `Left SessionStatus` if the session is expired or does not exist. -} getUserSession :: (MonadIO m) => SessionJar a -> ActionT m (Either SessionStatus (Session a)) getUserSession sessionJar = do @@ -170,18 +170,23 @@ sessionTTL :: NominalDiffTime sessionTTL = 36000 -- in seconds -- | Creates a new session for a user, storing the content and setting a cookie. -createUserSession :: (MonadIO m) => SessionJar a -> a -> ActionT m (Session a) -createUserSession sessionJar content = do - sess <- liftIO $ createSession sessionJar content +createUserSession :: (MonadIO m) => + SessionJar a -- ^ SessionJar, which can be created by createSessionJar + -> Maybe Int -- ^ Optional expiration time (in seconds) + -> a -- ^ Content + -> ActionT m (Session a) +createUserSession sessionJar mbExpirationTime content = do + sess <- liftIO $ createSession sessionJar mbExpirationTime content setSimpleCookie "sess_id" (sessId sess) return sess --- | Creates a new session with a generated ID, sets its expiration, and adds it to the session jar. -createSession :: SessionJar a -> a -> IO (Session a) -createSession sessionJar content = do +-- | Creates a new session with a generated ID, sets its expiration, +-- | and adds it to the session jar. +createSession :: SessionJar a -> Maybe Int -> a -> IO (Session a) +createSession sessionJar mbExpirationTime content = do sId <- liftIO $ T.pack <$> replicateM 32 (randomRIO ('a', 'z')) now <- getCurrentTime - let expiresAt = addUTCTime sessionTTL now + let expiresAt = addUTCTime (maybe sessionTTL fromIntegral mbExpirationTime) now sess = Session sId expiresAt content liftIO $ addSession sessionJar sess return $ Session sId expiresAt content diff --git a/changelog.md b/changelog.md index c203314..1dba44c 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,6 @@ ## next [????.??.??] -* Added sessions. +* Added sessions (#317). * Fixed cookie example from `Cookie` module documentation. `getCookie` Function would return strict variant of `Text`. Will convert it into lazy variant using `fromStrict`. * Exposed simple functions of `Cookie` module via `Web.Scotty` & `Web.Scotty.Trans`. * Add tests for URL encoding of query parameters and form parameters. Add `formData` action for decoding `FromForm` instances (#321). diff --git a/examples/session.hs b/examples/session.hs index 035a28c..45a0205 100644 --- a/examples/session.hs +++ b/examples/session.hs @@ -15,7 +15,7 @@ main = do password <- queryParam "password" :: ActionM String if username == "foo" && password == "bar" then do - _ <- createUserSession sessionJar "foo" + _ <- createUserSession sessionJar Nothing "foo" text "Login successful!" else text "Invalid username or password." @@ -28,4 +28,4 @@ main = do -- Logout route get "/logout" $ do deleteCookie "sess_id" - text "Logged out successfully." \ No newline at end of file + text "Logged out successfully." diff --git a/test/Web/ScottySpec.hs b/test/Web/ScottySpec.hs index 18da6b8..0068eff 100644 --- a/test/Web/ScottySpec.hs +++ b/test/Web/ScottySpec.hs @@ -542,7 +542,7 @@ spec = do describe "Session Management" $ do withApp (Scotty.get "/scotty" $ do sessionJar <- liftIO createSessionJar - sess <- createUserSession sessionJar ("foo" :: T.Text) + sess <- createUserSession sessionJar Nothing ("foo" :: T.Text) mRes <- readSession sessionJar (sessId sess) case mRes of Left _ -> Scotty.status status400 From d789812ab9dfda019012641dcd0b5ad0d9606396 Mon Sep 17 00:00:00 2001 From: tusharad Date: Tue, 7 Jan 2025 13:07:37 +0530 Subject: [PATCH 5/5] Added session example in README --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index a4e2cef..a56393c 100644 --- a/README.md +++ b/README.md @@ -56,6 +56,7 @@ Additionally, the `examples` directory shows a number of concrete use cases, e.g * [configuration](./examples/reader.hs) * [cookies](./examples/cookies.hs) * [file upload](./examples/upload.hs) +* [session](./examples/session.hs) * and more ## More Information