From fe0e29e06ea10d193a81709d999a4ecef24942c6 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 25 May 2015 16:26:36 -0300 Subject: [PATCH] Fix serversession-frontend-yesod except for expiration. --- .../Web/ServerSession/Backend/Persistent.hs | 7 +- .../serversession-frontend-yesod.cabal | 26 +---- .../src/Web/ServerSession/Frontend/Yesod.hs | 8 +- .../ServerSession/Frontend/Yesod/Internal.hs | 101 ++++++++++++------ 4 files changed, 86 insertions(+), 56 deletions(-) diff --git a/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs index e562041..d62db20 100644 --- a/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs +++ b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs @@ -22,6 +22,8 @@ -- share [mkPersist sqlSettings, mkSave \"entityDefs\"] -- -- -- On Application.hs +-- import Web.ServerSession.Backend.Persistent (serverSessionDefs) +-- -- mkMigrate \"migrateAll\" (serverSessionDefs ++ entityDefs) -- -- makeFoundation = @@ -30,8 +32,9 @@ -- ... -- @ -- --- If you forget to setup the migration above, this backend will --- fail at runtime as the required table will not exist. +-- If you forget to setup the migration above, this session +-- storage backend will fail at runtime as the required table +-- will not exist. module Web.ServerSession.Backend.Persistent ( SqlStorage(..) , serverSessionDefs diff --git a/serversession-frontend-yesod/serversession-frontend-yesod.cabal b/serversession-frontend-yesod/serversession-frontend-yesod.cabal index 6687ced..960315b 100644 --- a/serversession-frontend-yesod/serversession-frontend-yesod.cabal +++ b/serversession-frontend-yesod/serversession-frontend-yesod.cabal @@ -17,40 +17,22 @@ library hs-source-dirs: src build-depends: base == 4.* - , aeson - , base64-bytestring == 1.0.* , bytestring - , containers , cookie >= 0.4 , data-default - , nonce == 1.0.* , path-pieces - , persistent == 2.1.* - , persistent-template == 2.1.* - , resource-pool , text , time , transformers , wai , yesod-core == 1.4.* + + , serversession == 1.0.* exposed-modules: - Yesod.Persist.Session - Yesod.Persist.Session.Internal.Backend - Yesod.Persist.Session.Internal.Sql - Yesod.Persist.Session.Internal.Types + Web.ServerSession.Frontend.Yesod + Web.ServerSession.Frontend.Yesod.Internal extensions: - DeriveDataTypeable - EmptyDataDecls - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving OverloadedStrings - QuasiQuotes - RecordWildCards - ScopedTypeVariables - TemplateHaskell - TypeFamilies ghc-options: -Wall source-repository head diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs index 1b40a5a..cbb5dd8 100644 --- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs +++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs @@ -1,5 +1,11 @@ module Web.ServerSession.Frontend.Yesod - ( + ( -- * Using server-side sessions + simpleBackend + , backend + -- * Invalidating session IDs + , forceInvalidate + , ForceInvalidate(..) ) where +import Web.ServerSession.Core (ForceInvalidate(..)) import Web.ServerSession.Frontend.Yesod.Internal 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 e4f7ca5..c1f26bb 100644 --- a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs +++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs @@ -1,27 +1,72 @@ module Web.ServerSession.Frontend.Yesod.Internal - ( + ( simpleBackend + , backend + , createCookie + , findSessionId + , forceInvalidate ) where - --- TODO: I'm in a bad shape :(. - - +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 Yesod.Core (MonadHandler) import Yesod.Core.Handler (setSessionBS) -import Yesod.Core.Types (Header(AddCookie), SaveSession, SessionBackend(..), SessionMap) +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 --- | Construct the server-side session backend from the given state. -backend :: Storage s => State s -> SessionBackend -backend state = - SessionBackend { - sbLoadSession = loadSession state "JSESSIONID" -- LOL :) - } +-- | Construct the server-side session backend using +-- the given storage backend. +-- +-- Example usage for the Yesod scaffold using +-- @serversession-backend-persistent@: +-- +-- @ +-- import Web.ServerSession.Backend.Persistent (SqlStorage(..)) +-- import Web.ServerSession.Frontend.Yesod (simpleBackend) +-- +-- instance Yesod App where +-- ... +-- makeSessionBackend = simpleBackend . SqlStorage . appConnPool +-- -- Do not forget to add migration code to your Application.hs! +-- -- Please check serversession-backend-persistent's documentation. +-- ... +-- @ +simpleBackend + :: (MonadIO m, Storage s) + => 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 +-- | Construct the server-side session backend using the given +-- state and cookie name. +backend + :: Storage s + => State s -- ^ @serversession@ state, incl. storage backend. + -> ByteString -- ^ Cookie name. + -> SessionBackend -- ^ Yesod session backend. +backend state cookieName = + SessionBackend { + sbLoadSession = \req -> do + let rawSessionId = findSessionId cookieName req + (sessionMap, saveSessionToken) <- loadSession state rawSessionId + let save = + fmap ((:[]) . createCookie cookieName) . + saveSession state saveSessionToken + return (sessionMap, save) + } + -- | Create a cookie for the given session ID. createCookie :: ByteString -> SessionId -> Header @@ -29,7 +74,7 @@ createCookie cookieName key = -- Generate a cookie with the final session ID. AddCookie def { setCookieName = cookieName - , setCookieValue = TE.encodeUtf8 $ unS key + , setCookieValue = TE.encodeUtf8 $ toPathPiece key , setCookiePath = Just "/" , setCookieExpires = Just undefined , setCookieDomain = Nothing @@ -43,25 +88,14 @@ createCookie cookieName key = -- * There are zero cookies with the given name. -- -- * There is more than one cookie with the given name. --- --- * The cookie's value isn't considered a 'SessionId'. We're --- a bit strict here. -findSessionId :: ByteString -> W.Request -> Maybe SessionId +findSessionId :: ByteString -> W.Request -> Maybe ByteString findSessionId cookieName req = do - let matching = do - ("Cookie", header) <- W.requestHeaders req - (k, v) <- parseCookies header - guard (k == cookieName) - return v - [raw] <- return matching - fromPathPiece (TE.decodeUtf8 raw) - - --- | The session key used by @yesod-auth@ without depending on it. -authKey :: Text -authKey = "_ID" - - + [raw] <- return $ do + ("Cookie", header) <- W.requestHeaders req + (k, v) <- parseCookies header + guard (k == cookieName) + return v + return raw -- | Invalidate the current session ID (and possibly more, check @@ -73,5 +107,10 @@ authKey = "_ID" -- end of the handler processing. This means that later calls to -- 'forceInvalidate' on the same handler will override earlier -- calls. +-- +-- This function works by setting a session variable that is +-- checked when saving the session. The session variable set by +-- this function is then discarded and is not persisted across +-- requests. forceInvalidate :: MonadHandler m => ForceInvalidate -> m () forceInvalidate = setSessionBS forceInvalidateKey . B8.pack . show