diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs index c1f26bb..4290fa2 100644 --- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs +++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs @@ -10,9 +10,9 @@ import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO) import Data.ByteString (ByteString) import Data.Default (def) -import Web.Cookie (parseCookies, SetCookie(..)) import Web.PathPieces (toPathPiece) import Web.ServerSession.Core +import Web.ServerSession.Core.Internal (cookieName) import Yesod.Core (MonadHandler) import Yesod.Core.Handler (setSessionBS) import Yesod.Core.Types (Header(AddCookie), SessionBackend(..)) @@ -20,6 +20,7 @@ import Yesod.Core.Types (Header(AddCookie), SessionBackend(..)) import qualified Data.ByteString.Char8 as B8 import qualified Data.Text.Encoding as TE import qualified Network.Wai as W +import qualified Web.Cookie as C -- | Construct the server-side session backend using @@ -34,51 +35,60 @@ import qualified Network.Wai as W -- -- instance Yesod App where -- ... --- makeSessionBackend = simpleBackend . SqlStorage . appConnPool +-- makeSessionBackend = simpleBackend id . SqlStorage . appConnPool -- -- Do not forget to add migration code to your Application.hs! -- -- Please check serversession-backend-persistent's documentation. -- ... -- @ +-- +-- For example, if you wanted to disable the idle timeout and decrease the +-- absolute timeout to one day, you could change that line to: +-- +-- @ +-- makeSessionBackend = simpleBackend opts . SqlStorage . appConnPool +-- where opts = setIdleTimeout Nothing +-- . setAbsoluteTimeout (Just $ 60*60*24) +-- @ simpleBackend :: (MonadIO m, Storage s) - => s -- ^ Storage backend. + => (State s -> State s) -- ^ Set any options on the @serversession@ state. + -> s -- ^ Storage backend. -> m (Maybe SessionBackend) -- ^ Yesod session backend (always @Just@). -simpleBackend s = do - state <- createState s - let cookieName = "JSESSIONID" -- LOL :) - return $ Just $ backend state cookieName +simpleBackend opts s = + return . Just . backend . opts =<< createState s -- | Construct the server-side session backend using the given --- state and cookie name. +-- state. backend :: Storage s => State s -- ^ @serversession@ state, incl. storage backend. - -> ByteString -- ^ Cookie name. -> SessionBackend -- ^ Yesod session backend. -backend state cookieName = +backend state = SessionBackend { sbLoadSession = \req -> do - let rawSessionId = findSessionId cookieName req + let rawSessionId = findSessionId cookieNameBS req (sessionMap, saveSessionToken) <- loadSession state rawSessionId let save = - fmap ((:[]) . createCookie cookieName) . + fmap ((:[]) . createCookie cookieNameBS) . saveSession state saveSessionToken return (sessionMap, save) } + where + cookieNameBS = TE.encodeUtf8 $ cookieName state -- | Create a cookie for the given session ID. createCookie :: ByteString -> SessionId -> Header -createCookie cookieName key = +createCookie cookieNameBS key = -- Generate a cookie with the final session ID. AddCookie def - { setCookieName = cookieName - , setCookieValue = TE.encodeUtf8 $ toPathPiece key - , setCookiePath = Just "/" - , setCookieExpires = Just undefined - , setCookieDomain = Nothing - , setCookieHttpOnly = True + { C.setCookieName = cookieNameBS + , C.setCookieValue = TE.encodeUtf8 $ toPathPiece key + , C.setCookiePath = Just "/" + , C.setCookieExpires = Just undefined + , C.setCookieDomain = Nothing + , C.setCookieHttpOnly = True } @@ -89,11 +99,11 @@ createCookie cookieName key = -- -- * There is more than one cookie with the given name. findSessionId :: ByteString -> W.Request -> Maybe ByteString -findSessionId cookieName req = do +findSessionId cookieNameBS req = do [raw] <- return $ do ("Cookie", header) <- W.requestHeaders req - (k, v) <- parseCookies header - guard (k == cookieName) + (k, v) <- C.parseCookies header + guard (k == cookieNameBS) return v return raw diff --git a/serversession/src/Web/ServerSession/Core.hs b/serversession/src/Web/ServerSession/Core.hs index 4cbcae6..163b80d 100644 --- a/serversession/src/Web/ServerSession/Core.hs +++ b/serversession/src/Web/ServerSession/Core.hs @@ -15,6 +15,7 @@ module Web.ServerSession.Core , SaveSessionToken , forceInvalidateKey -- ** To be re-exported by frontends + , setCookieName , ForceInvalidate(..) ) where diff --git a/serversession/src/Web/ServerSession/Core/Internal.hs b/serversession/src/Web/ServerSession/Core/Internal.hs index 3ae6ad4..2116c5b 100644 --- a/serversession/src/Web/ServerSession/Core/Internal.hs +++ b/serversession/src/Web/ServerSession/Core/Internal.hs @@ -11,6 +11,7 @@ module Web.ServerSession.Core.Internal , State(..) , createState + , setCookieName , setAuthKey , loadSession , saveSession @@ -30,6 +31,7 @@ import Data.ByteString (ByteString) import Data.Maybe (isJust) import Data.Text (Text) import Data.Time (UTCTime, getCurrentTime) +import Data.Time.Clock (DiffTime, secondsToDiffTime) import Data.Typeable (Typeable) import Web.PathPieces (PathPiece(..)) @@ -157,25 +159,45 @@ class MonadIO (TransactionM s) => Storage s where -- -- * A reference to the storage backend. -- +-- * The name of cookie where the session ID will be saved ('setCookieName'). +-- -- * Authentication session variable ('setAuthKey'). -- +-- * Idle and absolute timeouts ('setIdleTimeout' and 'setAbsoluteTimeout'). +-- -- Create a new 'State' using 'createState'. data State s = State - { generator :: !N.Generator - , storage :: !s - , authKey :: Text + { generator :: !N.Generator + , storage :: !s + , cookieName :: !Text + , authKey :: !Text + , idleTimeout :: !(Maybe DiffTime) + , absoluteTimeout :: !(Maybe DiffTime) } deriving (Typeable) -- | Create a new 'State' for the server-side session backend -- using the given storage backend. createState :: MonadIO m => s -> m (State s) -createState storage = - State - <$> N.new - <*> return storage - <*> return "_ID" +createState sto = do + gen <- N.new + return State + { generator = gen + , storage = sto + , cookieName = "JSESSIONID" + , authKey = "_ID" + , idleTimeout = Just $ secondsToDiffTime $ 60*60*24*7 -- 7 days + , absoluteTimeout = Just $ secondsToDiffTime $ 60*60*24*60 -- 60 days + } + + +-- | Set the name of cookie where the session ID will be saved. +-- Defaults to \"JSESSIONID\", which is a generic cookie name +-- used by many frameworks thus making it harder to fingerprint +-- this implementation. +setCookieName :: Text -> State s -> State s +setCookieName val state = state { cookieName = val } -- | Set the name of the session variable that keeps track of the