Fix serversession-frontend-yesod except for expiration.

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

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

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

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