packages feed

yesod-session-persist (empty) → 0.0.0.0

raw patch · 50 files changed

+2899/−0 lines, 50 filesdep +QuickCheckdep +aesondep +annotated-exception

Dependencies added: QuickCheck, aeson, annotated-exception, base, base64, bytestring, containers, cookie, crypton, exceptions, hspec, http-types, mtl, persistent, random, stm, text, time, transformers, wai, wai-extra, yesod, yesod-core, yesod-session-persist, yesod-test

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+## [_Unreleased_](https://github.com/freckle/yesod-session-persist/compare/v__...main)++## [v0.0.0.0](https://github.com/freckle/yesod-session-persist/tree/v0.0.0.0)++First tagged release.
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2024 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,80 @@+# yesod-session-persist++[![Hackage](https://img.shields.io/hackage/v/yesod-session-persist.svg?style=flat)](https://hackage.haskell.org/package/yesod-session-persist)+[![CI](https://github.com/freckle/yesod-session-persist/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/yesod-session-persist/actions/workflows/ci.yml)++Use this package to construct a Yesod session backend for which sessions are+stored in a database table. You provide a Persistent entity.++## Features++### Key rotation++The key reason to switch from client-side sessions (Yesod's default) to server storage+is to be able to rotate keys and invalidate old credentials.++With client session storage, when a user logs out, you send them a new cookie.+But this does nothing to satisfy a user who is logging out because their session secret may+have been compromised; the old cookie value will still be a working authentication credential.+Being able to _revoke_ authentication credentials requires storing state on the server.++Whenever user's authentication changes (but especially on logging out), users of this library+should use the `rotateSessionKey` action to provoke a key rotation.+This copies any existing session data into a new session with a different secret key,+deleting the session with the old key and thus disabling any outdated credentials that+an attacker may possess.++### Disabling session changes++There may be some unusual circumstances in which you want to disable the effects of session+management -- writes to the session backend and sending of session cookies -- for the+handling of a particular request.+At such times, you can use the `assignSessionFreeze` action to indicate whether the+session should be persisted at the end of the handling of the request.++### Expiration by idle timeout++The most recent access time of each session is stored. After a configurable duration has+elapsed without access, a session is considered to be expired. An expired session is treated+as if it did not exist.++### Expiration by absolute timeout++The creation time of each session is stored. After a configurable duration has elapsed since+the creation time, a session is considered to be expired, regardless of whether it is still+in active use.++### Approximate storage of access time++To avoid excessive database writes, updates which would only increment a session's access+time by a short duration are not performed.+The definition of "a short duration" is configurable; we call it the _timeout resolution_.++## Absent features++### Garbage collection++This library does not proactively seek out expired sessions for deletion from the database.+Thus, in the absence of some other intervention, your session table will grow without bound.++## Prior art++### `serversession`++This package is based on+[serversession](https://hackage.haskell.org/package/serversession) ++[serversession-frontend-yesod](https://hackage.haskell.org/package/serversession-frontend-yesod) ++[serversession-backend-persistent](https://hackage.haskell.org/package/serversession-backend-persistent).++Compared to `serversession`, here we simplify somewhat by concretizing to Yesod and+Persistent rather than supporting multiple frontends and backends.++Their sessions have a concept of "auth ID" specifying who is logged in.+`serversession` uses this to automatically rotate keys when the auth ID changes, and+to provide a means for mass invalidation of all the sessions belonging to a particular user.+We do not borrow this concept, because it does not generalize well to more complex+authentication situations where a session may have been authenticated as multiple principals.++---++[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE)
+ internal/Comparison.hs view
@@ -0,0 +1,14 @@+module Comparison+  ( Comparison (..)+  , differsOn+  ) where++import Internal.Prelude++data Comparison a = Comparison+  { old :: a+  , new :: a+  }++differsOn :: Eq b => (a -> b) -> Comparison a -> Bool+differsOn f Comparison {old, new} = f old /= f new
+ internal/Embedding.hs view
@@ -0,0 +1,41 @@+module Embedding+  ( Embedding (..)+  , embed+  , extract+  , extractIgnoringError+  , dimapEmbedding+  ) where++import Internal.Prelude++-- | Targets a value that is optionally present in some stateful monadic context+data Embedding (con :: (Type -> Type) -> Constraint) e a = Embedding+  { embed :: forall m. con m => Maybe a -> m ()+  -- ^ Sets or clears the value+  , extract :: forall m. (Functor m, con m) => m (Either e (Maybe a))+  -- ^ Removes the value if present, returning what was removed+  }++embed :: con m => Embedding con e a -> Maybe a -> m ()+embed Embedding {embed = x} = x++extract :: (Functor m, con m) => Embedding con e a -> m (Either e (Maybe a))+extract Embedding {extract = x} = x++extractIgnoringError :: (Functor m, con m) => Embedding con e a -> m (Maybe a)+extractIgnoringError e = extract e <&> fromRight Nothing++dimapEmbedding+  :: (a -> Either e b)+  -> (b -> a)+  -> Embedding con e a+  -> Embedding con e b+dimapEmbedding g f Embedding {embed = embed', extract = extract'} =+  Embedding+    { embed = embed' . fmap f+    , extract =+        extract' <&> \case+          Left e -> Left e+          Right Nothing -> Right Nothing+          Right (Just x) -> Just <$> g x+    }
+ internal/Internal/Prelude.hs view
@@ -0,0 +1,86 @@+module Internal.Prelude+  ( module X+  )+where++import Control.Applicative as X (Applicative (..), empty, (<|>))+import Control.Category as X ((>>>))+import Control.Exception as X (Exception, SomeException (..))+import Control.Exception.Annotated as X+  ( checkpointCallStack+  , throwWithCallStack+  )+import Control.Monad as X+  ( Monad (..)+  , guard+  , join+  , replicateM+  , replicateM_+  , when+  , (<=<)+  , (=<<)+  , (>=>)+  )+import Control.Monad.Catch as X (MonadThrow, throwM)+import Control.Monad.Except as X (MonadError, throwError)+import Control.Monad.Fail as X (fail)+import Control.Monad.IO.Class as X (MonadIO (liftIO))+import Control.Monad.Reader as X (ReaderT)+import Control.Monad.Trans as X (MonadTrans (lift))+import Control.Monad.Trans.Identity as X (IdentityT (..))+import Data.Bifunctor as X (bimap)+import Data.Bool as X+import Data.ByteString as X (ByteString)+import Data.Char as X (Char)+import Data.Either as X (Either (..), either, fromRight)+import Data.Eq as X (Eq, (/=), (==))+import Data.Fixed as X (Fixed (MkFixed))+import Data.Foldable as X (all, foldMap, for_, toList, traverse_)+import Data.Function as X (const, flip, id, ($), (&), (.))+import Data.Functor as X (Functor, fmap, void, ($>), (<$>), (<&>))+import Data.Kind as X (Constraint, Type)+import Data.List as X (concat, concatMap, filter)+import Data.List.NonEmpty as X (nonEmpty)+import Data.Map as X (Map)+import Data.Maybe as X+  ( Maybe (..)+  , catMaybes+  , fromMaybe+  , isJust+  , isNothing+  , maybe+  )+import Data.Ord as X (Ord (..))+import Data.Semigroup as X ((<>))+import Data.Sequence as X (Seq)+import Data.Set as X (Set)+import Data.String as X (String)+import Data.Text as X (Text)+import Data.Traversable as X (for)+import Data.Tuple as X (fst, snd, swap)+import Data.Type.Equality as X+import GHC.Stack as X (HasCallStack)+import Numeric.Natural as X (Natural)+import System.IO as X (IO)+import Text.Read as X (Read, readMaybe)+import Text.Show as X (Show, show)+import Prelude as X+  ( Bounded+  , Enum+  , Int+  , Integral+  , fromIntegral+  , minimum+  , negate+  , pred+  , succ+  , truncate+  , ($!)+  , (*)+  , (+)+  , (-)+  , (/)+  )++{-# ANN module ("HLint: ignore Avoid restricted alias" :: String) #-}+{-# ANN module ("HLint: ignore Avoid restricted qualification" :: String) #-}
+ internal/Randomization.hs view
@@ -0,0 +1,51 @@+module Randomization+  ( Randomization (..)+  , deterministicallyRandom+  , DeterministicRandomization (..)+  , hoistRandomization+  , defaultRandomization+  ) where++import Internal.Prelude++import Crypto.Random (ChaChaDRG, DRG (randomBytesGenerate), drgNew)+import Data.IORef (atomicModifyIORef', newIORef)++-- | General means of obtaining randomness+newtype Randomization m = Randomization+  { getRandomBytes :: Natural -> m ByteString+  -- ^ Given a requested number of bytes, this action+  --   should produce a 'ByteString' of that length.+  }++hoistRandomization+  :: (forall a. m a -> m' a) -> Randomization m -> Randomization m'+hoistRandomization f (Randomization g) = Randomization (f . g)++-- | Convert from a deterministic generator to an effectful one+deterministicallyRandom+  :: DeterministicRandomization -> IO (Randomization IO)+deterministicallyRandom =+  liftIO . newIORef >=> pure . \ref ->+    Randomization $ \n ->+      liftIO $ atomicModifyIORef' ref $ \(DeterministicRandomization gen) ->+        swap $ gen n++-- | A deterministic random generator+newtype DeterministicRandomization = DeterministicRandomization+  { nextRandomBytes :: Natural -> (ByteString, DeterministicRandomization)+  -- ^ Given a requested number of bytes, this function should give a+  --   'ByteString' of that length and a new deterministic generator.+  }++-- | Cryptographically secure deterministic randomization seeded from+--   system entropy using @ChaChaDRG@ from the @crypton@ package+defaultRandomization :: IO (Randomization IO)+defaultRandomization =+  deterministicallyRandom . makeDeterministicRandomization =<< liftIO drgNew+ where+  makeDeterministicRandomization :: ChaChaDRG -> DeterministicRandomization+  makeDeterministicRandomization drg =+    DeterministicRandomization $ \n ->+      let (bs, drg') = randomBytesGenerate (fromIntegral n) drg+      in  (bs, makeDeterministicRandomization drg')
+ internal/Session/Freeze.hs view
@@ -0,0 +1,9 @@+module Session.Freeze+  ( SessionFreeze (..)+  ) where++import Internal.Prelude++data SessionFreeze+  = FreezeSessionForCurrentRequest+  deriving stock (Eq, Ord, Show, Read, Bounded, Enum)
+ internal/Session/Key.hs view
@@ -0,0 +1,62 @@+module Session.Key+  ( SessionKey (..)+  , SessionKeyManager (..)+  , makeSessionKeyManager+  , sessionKeyToCookieValue+  , sessionKeyFromCookieValue+  )+where++import Internal.Prelude++import Data.ByteString.Base64.URL qualified as B64URL+import Data.ByteString.Char8 qualified as BS8+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Randomization++data SessionKeyManager m = SessionKeyManager+  { new :: m SessionKey+  -- ^ Generate a new session key+  --+  -- In a production setting, it is critical that this action be+  -- thread-safe and produce a securely random result.+  , check :: SessionKey -> Bool+  -- ^ Validate that a text is something that plausibly could have+  --   been generated by 'new'.+  }++-- | Secret value that is sent to and subsequently furnished by+--   the client to identify the session+newtype SessionKey = SessionKey {text :: Text}+  deriving newtype (Eq, Ord, Show)++makeSessionKeyManager :: Monad m => Randomization m -> SessionKeyManager m+makeSessionKeyManager (Randomization generateRandomBytes) =+  let+    new = SessionKey . B64URL.encodeBase64 <$> generateRandomBytes keyLengthInBytes++    check (SessionKey text) =+      T.length text+        == keyLengthAsText+        && either+          (const False)+          ((== keyLengthInBytes) . BS8.length)+          (B64URL.decodeBase64 $ encodeUtf8 text)+  in+    SessionKeyManager {new, check}++-- We generate 18-byte session keys. This number is rather arbitrary.+keyLengthInBytes :: Integral a => a+keyLengthInBytes = 18++-- 18 bytes in base64 encoding ends up being a text 24 characters+keyLengthAsText :: Integral a => a+keyLengthAsText = 24++sessionKeyToCookieValue :: SessionKey -> ByteString+sessionKeyToCookieValue = (.text) >>> encodeUtf8++sessionKeyFromCookieValue :: ByteString -> Maybe SessionKey+sessionKeyFromCookieValue v =+  decodeUtf8' v & either (const Nothing) Just <&> SessionKey
+ internal/Session/KeyRotation.hs view
@@ -0,0 +1,12 @@+module Session.KeyRotation+  ( KeyRotation (..)+  ) where++import Internal.Prelude++-- | /Key rotation/ means we delete the session on the server+--   and copy the stored data into a new session with a different key.+data KeyRotation+  = -- | Generate a new session key and invalidate the old one+    RotateSessionKey+  deriving stock (Eq, Ord, Show, Read, Bounded, Enum)
+ internal/Session/Timing/Math.hs view
@@ -0,0 +1,37 @@+module Session.Timing.Math+  ( nextExpires+  , isExpired+  ) where++import Internal.Prelude++import Session.Timing.Time+import Session.Timing.Timeout+import Time++-- | Calculate the next point in time where the given session+--   will expire assuming that it sees no activity until then+--+-- Returns 'Nothing' iff the settings do not specify any timeout limits.+nextExpires+  :: Timeout NominalDiffTime+  -> Time UTCTime+  -- ^ A session's timing information+  -> Maybe UTCTime+nextExpires timeout time =+  (fmap minimum . nonEmpty . catMaybes)+    [ flip addUTCTime time.accessed <$> timeout.idle+    , flip addUTCTime time.created <$> timeout.absolute+    ]++-- | Check if a session has expired+isExpired+  :: Timeout NominalDiffTime+  -- ^ Settings+  -> UTCTime+  -- ^ Now+  -> Time UTCTime+  -- ^ A session's timing information+  -> Bool+isExpired timeout now time =+  maybe False (<= now) $ nextExpires timeout time
+ internal/Session/Timing/Options.hs view
@@ -0,0 +1,34 @@+module Session.Timing.Options+  ( TimingOptions (..)+  , defaultTimingOptions+  ) where++import Internal.Prelude++import Session.Timing.Timeout+import Time++-- | Time duration settings+--+-- See 'defaultTimingOptions'.+data TimingOptions a = TimingOptions+  { timeout :: Timeout a+  -- ^ How long sessions are allowed to live+  , resolution :: Maybe a+  -- ^ If @'Just' resolution@, this setting provides an optimization that can prevent+  --   excessive database writes. If the only thing that needs to be updated is the+  --   session's last access time, the write will be skipped if the previously recorded+  --   access time is within @resolution@ long ago.+  }+  deriving stock (Eq, Show)++-- | Default timing options+--+--   - timeout = 'defaultTimeout'+--   - resolution = 10 minutes+defaultTimingOptions :: TimingOptions NominalDiffTime+defaultTimingOptions =+  TimingOptions+    { timeout = defaultTimeout+    , resolution = Just $ minutes 10+    }
+ internal/Session/Timing/Time.hs view
@@ -0,0 +1,18 @@+module Session.Timing.Time+  ( Time (..)+  ) where++import Internal.Prelude++-- | Creation and access times, used to determine session expiration+data Time a = Time+  { created :: a+  -- ^ When the session was created+  --+  -- This is used to apply the absolute timeout.+  , accessed :: a+  -- ^ When the session was last accessed+  --+  -- This is used to apply the idle timeout.+  }+  deriving stock (Eq, Show)
+ internal/Session/Timing/Timeout.hs view
@@ -0,0 +1,41 @@+module Session.Timing.Timeout+  ( Timeout (..)+  , defaultTimeout+  ) where++import Internal.Prelude++import Time++-- | How long sessions are allowed to live+--+-- See 'defaultTimeout'.+data Timeout a = Timeout+  { idle :: Maybe a+  -- ^ The amount of time a session will remain active in case there+  --   is no activity in the session+  --+  -- This is used both on the client side (by setting the cookie expires fields)+  -- and on the server.+  --+  -- Setting to 'Nothing' removes the idle timeout.+  , absolute :: Maybe a+  -- ^ The maximum amount of time a session can be active+  --+  -- This is used both on the client side (by setting the cookie expires fields)+  -- and on the server side.+  --+  -- Setting to 'Nothing' removes the absolute timeout.+  }+  deriving stock (Eq, Show)++-- | Default timeouts+--+--   - idle = 8 hours+--   - absolute = 30 days+defaultTimeout :: Timeout NominalDiffTime+defaultTimeout =+  Timeout+    { idle = Just $ hours 8+    , absolute = Just $ days 30+    }
+ internal/Session/TransportSecurity.hs view
@@ -0,0 +1,21 @@+module Session.TransportSecurity+  ( TransportSecurity (..)+  , cookieSecure+  ) where++import Internal.Prelude++data TransportSecurity+  = -- | Only allow cookies on HTTPS connections+    --+    -- Set this in production.+    RequireSecureTransport+  | -- | Allow cookies over either HTTP or HTTPS+    --+    -- This is okay for development.+    AllowPlaintextTranport++cookieSecure :: TransportSecurity -> Bool+cookieSecure = \case+  RequireSecureTransport -> True+  AllowPlaintextTranport -> False
+ internal/Time.hs view
@@ -0,0 +1,38 @@+module Time+  ( subtractUTCTime+  , minutes+  , hours+  , days+  , years+  , module X+  ) where++import Internal.Prelude++import Data.Time as X+  ( NominalDiffTime+  , UTCTime (..)+  , addUTCTime+  , diffUTCTime+  , nominalDay+  , nominalDiffTimeToSeconds+  , secondsToDiffTime+  , secondsToNominalDiffTime+  )+import Data.Time.Calendar.OrdinalDate as X (fromOrdinalDate)+import Data.Time.Clock.System as X (systemEpochDay)++subtractUTCTime :: NominalDiffTime -> UTCTime -> UTCTime+subtractUTCTime d t = addUTCTime (negate d) t++minutes :: NominalDiffTime -> NominalDiffTime+minutes = (* 60)++hours :: NominalDiffTime -> NominalDiffTime+hours = (* 60) . minutes++days :: NominalDiffTime -> NominalDiffTime+days = (* 24) . hours++years :: NominalDiffTime -> NominalDiffTime+years = (* 365.2) . days
+ internal/Yesod/Session/Cookie/Logic.hs view
@@ -0,0 +1,51 @@+module Yesod.Session.Cookie.Logic+  ( setCookie+  , CookieContext (..)+  ) where++import Internal.Prelude++import Yesod.Core.Types (Header)+import Yesod.Session.Cookie.SetCookie+import Yesod.Session.Options+import Yesod.Session.SaveResult+import Yesod.Session.SessionType++data CookieContext = CookieContext+  { cookie :: Maybe ByteString+  , load :: Maybe Session+  , save :: SaveResult Session+  }++setCookie :: Options tx m -> CookieContext -> [Header]+setCookie options = \case+  CookieContext {save = Frozen} ->+    -- Never send anything when a freeze was requested.+    []+  CookieContext {save = Deleted} ->+    -- There was a session but it's now gone; send deletion+    -- cookies so the client can forget all about it.+    cookiesForSession Nothing+  CookieContext {save = Saved s} ->+    -- Any time a session was saved, send cookies.+    -- At the very least this will probably be wanted to give+    -- the client a new expiration time.+    cookiesForSession (Just s)+  CookieContext {save = NoChange, load = Just s} ->+    -- There was a session loaded but change saved; send cookies+    -- for the session that was loaded. This is probably superfluous.+    -- It will only be useful if the server's timeout settings+    -- have changed. But it's low cost, so might as well do it.+    cookiesForSession (Just s)+  CookieContext {save = NoChange, load = Nothing, cookie = Nothing} ->+    -- No cookie was sent, no session was loaded, no change was saved.+    -- There is nothing to send.+    []+  CookieContext {save = NoChange, load = Nothing, cookie = Just _} ->+    -- The client sent a cookie but it did not result in a session load,+    -- and there is no new session key to send. Send a deletion to put+    -- this worthless session cookie out of its misery.+    cookiesForSession Nothing+ where+  cookiesForSession :: Maybe Session -> [Header]+  cookiesForSession = makeSetCookieHeaders options . fmap (\s -> (s.key, s.time))
+ internal/Yesod/Session/Cookie/Reading.hs view
@@ -0,0 +1,24 @@+module Yesod.Session.Cookie.Reading+  ( findSessionKey+  )+where++import Internal.Prelude++import Network.HTTP.Types.Header+import Network.Wai+import Web.Cookie++-- | Find a session key in the request+findSessionKey :: ByteString -> Request -> Maybe ByteString+findSessionKey cookieNameBS =+  one+    . concatMap (lookupAll cookieNameBS . parseCookies)+    . lookupAll hCookie+    . requestHeaders++one :: [a] -> Maybe a+one = \case [x] -> Just x; _ -> Nothing++lookupAll :: Eq a => a -> [(a, b)] -> [b]+lookupAll a = fmap snd . filter ((== a) . fst)
+ internal/Yesod/Session/Cookie/SetCookie.hs view
@@ -0,0 +1,60 @@+module Yesod.Session.Cookie.SetCookie+  ( makeSetCookieHeaders+  ) where++import Internal.Prelude++import Data.Text.Encoding (encodeUtf8)+import Session.Key+import Session.Timing.Math+import Session.Timing.Options+import Session.Timing.Time+import Session.Timing.Timeout+import Session.TransportSecurity qualified as TransportSecurity+import Time+import Web.Cookie qualified as C+import Yesod.Core.Types (Header (AddCookie))+import Yesod.Session.Options++makeSetCookieHeaders+  :: Options tx m -> Maybe (SessionKey, Time UTCTime) -> [Header]+makeSetCookieHeaders options =+  (: []) <$> maybe (deleteCookie options) (createCookie options)++cookieNameBS :: Options tx m -> ByteString+cookieNameBS options = encodeUtf8 options.cookieName++-- | Create a cookie for the given session+createCookie :: Options tx m -> (SessionKey, Time UTCTime) -> Header+createCookie options (key, time) =+  AddCookie+    C.def+      { C.setCookieName = cookieNameBS options+      , C.setCookieValue = sessionKeyToCookieValue key+      , C.setCookiePath = Just "/"+      , C.setCookieExpires = Just $ cookieExpires options.timing.timeout time+      , C.setCookieDomain = Nothing+      , C.setCookieHttpOnly = True+      , C.setCookieSecure = TransportSecurity.cookieSecure options.transportSecurity+      }++-- | Remove the session cookie from the client+deleteCookie :: Options tx m -> Header+deleteCookie options =+  AddCookie+    C.def+      { C.setCookieName = cookieNameBS options+      , C.setCookieValue = ""+      , C.setCookiePath = Just "/"+      , C.setCookieExpires = Just $ UTCTime systemEpochDay 1+      , C.setCookieMaxAge = Just 0+      , C.setCookieDomain = Nothing+      , C.setCookieHttpOnly = True+      , C.setCookieSecure = TransportSecurity.cookieSecure options.transportSecurity+      }++-- | Calculate the date that should be used for the cookie's "expires" field+cookieExpires :: Timeout NominalDiffTime -> Time UTCTime -> UTCTime+cookieExpires timeout time =+  fromMaybe (addUTCTime (years 10) time.accessed)+    $ nextExpires timeout time
+ internal/Yesod/Session/Embedding/Map.hs view
@@ -0,0 +1,62 @@+module Yesod.Session.Embedding.Map+  ( SessionMapEmbedding+  , MapOperations (..)+  , bsKeyEmbedding+  , showReadKeyEmbedding+  ) where++import Internal.Prelude++import Control.Monad.State (StateT (..))+import Control.Monad.State qualified as State+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Embedding+import Yesod.Core (HandlerFor, deleteSession, lookupSessionBS, setSessionBS)++-- | Specifies how we represent some value within a 'SessionMap'+--+-- We use this to sort of abuse the session; key rotation and freezing are+-- done by embedding special values among the session data. These special+-- values are extracted from the map before persisting to storage and are+-- never actually saved.+type SessionMapEmbedding a = Embedding (MapOperations Text ByteString) () a++-- | A monadic context with operations over some 'Map'-like state+--+-- This allows us to generalize between pure operations over 'Map' and+-- the more limited session manipulation utilities afforded by Yesod.+-- (See the instance list for this class.)+class (Monad m, Ord k) => MapOperations k v m | m -> k v where+  lookup :: k -> m (Maybe v)+  assign :: k -> Maybe v -> m ()++instance MapOperations Text ByteString (HandlerFor site) where+  lookup k = lookupSessionBS k+  assign k v = maybe (deleteSession k) (setSessionBS k) v++instance (Monad m, Ord k) => MapOperations k v (StateT (Map k v) m) where+  lookup k = State.gets $ Map.lookup k+  assign k v = State.modify' $ Map.alter (const v) k++-- | An embedding which stores a value at some particular key in a map-like structure+bsKeyEmbedding :: k -> Embedding (MapOperations k a) e a+bsKeyEmbedding key =+  Embedding+    { embed = assign key+    , extract = fmap Right $ lookup key <* assign key Nothing+    }++-- | Represents a value in a 'SessionMap' by storing the+--   UTF-8 encoding of its 'show' representation at the given key+showReadKeyEmbedding+  :: (Read a, Show a) => k -> Embedding (MapOperations k ByteString) () a+showReadKeyEmbedding k =+  dimapEmbedding+    ( maybe (throwError ()) pure+        . readMaybe+        <=< (bimap (const ()) T.unpack . decodeUtf8')+    )+    (encodeUtf8 . T.pack . show)+    (bsKeyEmbedding k)
+ internal/Yesod/Session/Embedding/Options.hs view
@@ -0,0 +1,25 @@+module Yesod.Session.Embedding.Options+  ( SessionEmbeddings (..)+  , HasSessionEmbeddings (..)+  ) where++import Internal.Prelude++import Session.Freeze+import Session.KeyRotation+import Yesod.Session.Embedding.Map++data SessionEmbeddings = SessionEmbeddings+  { keyRotation :: SessionMapEmbedding KeyRotation+  -- ^ How to represent a key rotation instruction in the session data;+  --   see 'Yesod.Session.Persist.assignSessionKeyRotation'+  , freeze :: SessionMapEmbedding SessionFreeze+  -- ^ How to represent a freeze instruction in the session data;+  --   see 'Yesod.Session.Persist.assignSessionFreeze'+  }++class HasSessionEmbeddings a where+  getSessionEmbeddings :: a -> SessionEmbeddings++instance HasSessionEmbeddings SessionEmbeddings where+  getSessionEmbeddings = id
+ internal/Yesod/Session/Freeze.hs view
@@ -0,0 +1,30 @@+module Yesod.Session.Freeze+  ( disableSessionManagement+  , assignSessionFreeze+  ) where++import Internal.Prelude++import Embedding+import Session.Freeze+import Yesod.Core (HandlerSite, MonadHandler (liftHandler), getYesod)+import Yesod.Session.Embedding.Options++-- | Indicate whether the session should be frozen for the handling+--   of the current request+--+-- At the end of the request handler, if the value is 'Just', no+-- database actions will be performed and no cookies will be set.+assignSessionFreeze+  :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m))+  => Maybe SessionFreeze+  -- ^ 'Just' to freeze the session, or 'Nothing' to cancel any previous+  --   request for session freezing and restore the default behavior+  -> m ()+assignSessionFreeze f = do+  embedding <- getSessionEmbeddings <$> getYesod+  liftHandler $ embed embedding.freeze f++disableSessionManagement+  :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m)) => m ()+disableSessionManagement = assignSessionFreeze (Just FreezeSessionForCurrentRequest)
+ internal/Yesod/Session/KeyRotation.hs view
@@ -0,0 +1,38 @@+module Yesod.Session.KeyRotation+  ( rotateSessionKey+  , assignSessionKeyRotation+  ) where++import Internal.Prelude++import Embedding+import Session.KeyRotation+import Yesod.Core (HandlerSite, MonadHandler (liftHandler), getYesod)+import Yesod.Session.Embedding.Options++-- | Indicate whether the current session key should be rotated+--+-- The key rotation does not occur immediately;+-- this action only places a value into the session map.+--+-- Later calls to 'assignSessionKeyRotation' on the same handler will+-- override earlier calls.+--+-- At the end of the request handler, if the value is 'Just',+-- the session key will be rotated.+--+-- The session variable set by this function is then discarded+-- and is not persisted across requests.+assignSessionKeyRotation+  :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m))+  => Maybe KeyRotation+  -- ^ 'Just' to rotate, or 'Nothing' to cancel any previous+  --   request for rotation and restore the default behavior+  -> m ()+assignSessionKeyRotation kr = do+  embedding <- getSessionEmbeddings <$> getYesod+  liftHandler $ embed embedding.keyRotation kr++rotateSessionKey+  :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m)) => m ()+rotateSessionKey = assignSessionKeyRotation (Just RotateSessionKey)
+ internal/Yesod/Session/Manager.hs view
@@ -0,0 +1,35 @@+module Yesod.Session.Manager+  ( SessionManager (..)+  , sessionKeyAppearsReasonable+  , checkedSessionKeyFromCookieValue+  , newSessionKey+  ) where++import Internal.Prelude++import Session.Key+import Yesod.Session.Options+import Yesod.Session.Storage.Operation++-- | Server-wide state for the session mechanism+data SessionManager tx m = SessionManager+  { keyManager :: SessionKeyManager tx+  -- ^ A random session key generator+  , storage :: forall a. StorageOperation a -> tx a+  -- ^ The storage backend+  , options :: Options tx m+  , runTransaction :: forall a. tx a -> m a+  }++sessionKeyAppearsReasonable :: SessionManager tx m -> SessionKey -> Bool+sessionKeyAppearsReasonable SessionManager {keyManager = SessionKeyManager {check}} = check++checkedSessionKeyFromCookieValue+  :: SessionManager tx m -> ByteString -> Maybe SessionKey+checkedSessionKeyFromCookieValue x =+  sessionKeyFromCookieValue+    >=> (\v -> guard (sessionKeyAppearsReasonable x v) $> v)++newSessionKey :: SessionManager tx m -> m SessionKey+newSessionKey SessionManager {keyManager, runTransaction} =+  runTransaction keyManager.new
+ internal/Yesod/Session/Manager/Load.hs view
@@ -0,0 +1,57 @@+module Yesod.Session.Manager.Load+  ( loadSessionMaybe+  , loadSession+  , loadNothing+  , Load (..)+  , didSessionLoad+  , loadedData+  ) where++import Internal.Prelude++import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import Data.Map.Strict qualified as Map+import Session.Key+import Session.Timing.Math+import Session.Timing.Options+import Time+import Yesod.Core (SessionMap)+import Yesod.Session.Manager+import Yesod.Session.Options+import Yesod.Session.SessionType+import Yesod.Session.Storage.Operation++data Load a = Load+  { got :: Maybe a+  -- ^ The original session that was loaded from the database, if any+  , time :: UTCTime+  -- ^ The time at which the session was loaded+  }+  deriving stock (Eq, Show)++didSessionLoad :: Load a -> Bool+didSessionLoad = isJust . (.got)++loadedData :: Load Session -> SessionMap+loadedData load =+  maybe Map.empty (.map) load.got++loadSession :: Monad m => SessionManager tx m -> SessionKey -> m (Load Session)+loadSession SessionManager {options, storage, runTransaction} sessionKey = do+  now <- options.clock+  got <-+    runMaybeT $ do+      session <-+        MaybeT $ runTransaction $ storage $ GetSession sessionKey+      MaybeT $ pure $ guard $ not $ isExpired options.timing.timeout now session.time+      pure session+  pure Load {got, time = now}++loadNothing :: Monad m => SessionManager tx m -> m (Load a)+loadNothing SessionManager {options} = do+  now <- options.clock+  pure Load {got = Nothing, time = now}++loadSessionMaybe+  :: Monad m => SessionManager tx m -> Maybe SessionKey -> m (Load Session)+loadSessionMaybe sm = maybe (loadNothing sm) (loadSession sm)
+ internal/Yesod/Session/Manager/Save.hs view
@@ -0,0 +1,62 @@+module Yesod.Session.Manager.Save+  ( saveSession+  ) where++import Internal.Prelude++import Comparison+import Control.Monad.State qualified as State+import Embedding+import Session.Freeze+import Session.KeyRotation+import Yesod.Core (SessionMap)+import Yesod.Session.Embedding.Options+import Yesod.Session.Manager+import Yesod.Session.Manager.Load+import Yesod.Session.Options+import Yesod.Session.SaveResult+import Yesod.Session.SessionType+import Yesod.Session.Storage.Operation+import Yesod.Session.Storage.Save qualified as Storage++-- | Save the session on the storage backend+--+-- A 'SessionLoad' given by 'loadSession' is expected besides+-- the new contents of the session.+--+-- Returns 'Nothing' if the session was empty and didn't need to be saved.+-- Note that this does /not/ necessarily means that nothing was done.+-- If you ask for a session key to be rotated and clear every other sesssion+-- variable, then 'saveSession' will delete the older session but will+-- avoid creating a new, empty one.+saveSession+  :: Monad tx+  => SessionManager tx m+  -> Load Session+  -> SessionMap+  -> m (SaveResult Session)+saveSession SessionManager {options, storage, keyManager, runTransaction} load outputData =+  runTransaction+    $ case freeze of+      Just FreezeSessionForCurrentRequest -> pure Frozen+      Nothing ->+        case (load.got, rotation) of+          (Just s, Just RotateSessionKey) -> do+            storage $ DeleteSession s.key+            maybe Deleted Saved <$> save Nothing+          _ -> maybe NoChange Saved <$> save load.got+ where+  ((requestedRotation, freeze), newInfo) =+    flip State.runState outputData+      $ (,)+      <$> extractIgnoringError options.embedding.keyRotation+      <*> extractIgnoringError options.embedding.freeze++  autoRotation =+    options.keyRotationTrigger+      Comparison {old = loadedData load, new = newInfo}++  rotation = requestedRotation <|> autoRotation++  save oldSessionMaybe =+    Storage.save options storage keyManager load.time newInfo oldSessionMaybe
+ internal/Yesod/Session/Options.hs view
@@ -0,0 +1,79 @@+module Yesod.Session.Options+  ( Options (..)+  , defaultOptions+  , hoistOptions+  ) where++import Internal.Prelude++import Comparison+import Data.Time qualified as Time+import Randomization+import Session.KeyRotation+import Session.Timing.Options+import Session.TransportSecurity+import Time+import Yesod.Core (SessionMap)+import Yesod.Session.Embedding.Map+import Yesod.Session.Embedding.Options++-- | Settings that have defaults+--+-- See 'defaultOptions'.+data Options tx m = Options+  { cookieName :: Text+  -- ^ The name of cookie where the session key will be saved+  , timing :: TimingOptions NominalDiffTime+  -- ^ Various time duration settings+  , transportSecurity :: TransportSecurity+  -- ^ Whether cookies require HTTPS+  , embedding :: SessionEmbeddings+  -- ^ How special session management indicators get smuggled through a 'SessionMap'+  , clock :: m UTCTime+  -- ^ How to determine the current time;+  --   you can change this to a fake for testing+  , randomization :: m (Randomization tx)+  -- ^ Generator of random byte strings, used to contrive session keys+  , keyRotationTrigger :: Comparison SessionMap -> Maybe KeyRotation+  -- ^ At the end of request handling, compare old session data to new+  --   session data to determine whether a key rotation should be performed+  }++-- | Default options+--+--   - cookieName = @"session-key"@+--   - timing = 'defaultTimingOptions'+--   - transportSecurity = 'AllowPlaintextTranport' (change this in production)+--   - embedding.keyRotation = @'showReadKeyEmbedding' "session-key-rotation"@+--   - embedding.freeze = @'showReadKeyEmbedding' "session-freeze"@+--   - clock = 'Time.getCurrentTime'+--   - randomization = 'defaultRandomization'+--   - keyRotationTrigger = 'const' 'Nothing'+defaultOptions :: Options IO IO+defaultOptions =+  Options+    { cookieName = "session-key"+    , timing = defaultTimingOptions+    , transportSecurity = AllowPlaintextTranport+    , clock = Time.getCurrentTime+    , randomization = defaultRandomization+    , embedding =+        SessionEmbeddings+          { keyRotation = showReadKeyEmbedding "session-key-rotation"+          , freeze = showReadKeyEmbedding "session-freeze"+          }+    , keyRotationTrigger = const Nothing+    }++hoistOptions+  :: Functor m2+  => (forall a. tx1 a -> tx2 a)+  -> (forall a. m1 a -> m2 a)+  -> Options tx1 m1+  -> Options tx2 m2+hoistOptions f g Options {..} =+  Options+    { clock = g clock+    , randomization = hoistRandomization f <$> g randomization+    , ..+    }
+ internal/Yesod/Session/Persist/Storage.hs view
@@ -0,0 +1,59 @@+module Yesod.Session.Persist.Storage+  ( persistentStorage+  , SessionPersistence (..)++    -- * Persistent reëxports+  , PersistEntity+  , PersistEntityBackend+  , SafeToInsert+  , ConnectionPool+  ) where++import Internal.Prelude++import Database.Persist (Key, PersistRecordBackend)+import Database.Persist qualified as Persist+import Database.Persist.Class+  ( PersistEntity+  , PersistEntityBackend+  , SafeToInsert+  )+import Database.Persist.Sql (ConnectionPool)+import Session.Key+import Yesod.Session.SessionType+import Yesod.Session.Storage.Exceptions+import Yesod.Session.Storage.Operation++-- | Mapping between 'Yesod.Session.Persist.Session' and+--   a Persistent entity of your choice+data SessionPersistence backend record m = ( PersistRecordBackend record backend+                                           , Persist.PersistStoreWrite backend+                                           , SafeToInsert record+                                           ) =>+  SessionPersistence+  { databaseKey :: SessionKey -> Key record+  , toDatabase :: Session -> record+  , fromDatabase :: record -> Session+  , runTransaction :: forall a. ReaderT backend IO a -> m a+  }++persistentStorage+  :: forall record backend result m+   . (PersistRecordBackend record backend, Persist.PersistStoreWrite backend)+  => SessionPersistence backend record m+  -> StorageOperation result+  -> ReaderT backend IO result+persistentStorage sp@SessionPersistence {} = \case+  GetSession sessionKey ->+    fmap sp.fromDatabase <$> Persist.get (sp.databaseKey sessionKey)+  DeleteSession sessionKey ->+    Persist.delete $ sp.databaseKey sessionKey+  InsertSession session ->+    persistentStorage sp (GetSession session.key) >>= \case+      Nothing -> void $ Persist.insert $ sp.toDatabase session+      Just old -> throwWithCallStack $ SessionAlreadyExists old session+  ReplaceSession session ->+    let key = sp.databaseKey session.key+    in  Persist.get key >>= \case+          Nothing -> throwWithCallStack $ SessionDoesNotExist session+          Just _old -> void $ Persist.replace key $ sp.toDatabase session
+ internal/Yesod/Session/Persist/Yesod.hs view
@@ -0,0 +1,89 @@+module Yesod.Session.Persist.Yesod+  ( -- * Concretely+    makeSessionBackend+  , SessionConfiguration (..)++    -- * More general+  , makeSessionBackend'+  , SessionConfiguration' (..)++    -- * Extra general+  , makeSessionBackend''++    -- * Reëxport+  , SessionBackend+  ) where++import Internal.Prelude++import Data.Text.Encoding (encodeUtf8)+import Session.Key+import Yesod.Core.Types (SessionBackend (..))+import Yesod.Session.Cookie.Logic+import Yesod.Session.Cookie.Reading+import Yesod.Session.Manager+import Yesod.Session.Manager.Load+import Yesod.Session.Manager.Save+import Yesod.Session.Options+import Yesod.Session.Persist.Storage+import Yesod.Session.Storage.Operation++data SessionConfiguration persistentBackend persistentRecord = SessionConfiguration+  { persistence :: SessionPersistence persistentBackend persistentRecord IO+  -- ^ Mapping between 'Yesod.Session.Persist.Session' and your Persistent entity+  , options :: Options (ReaderT persistentBackend IO) IO+  -- ^ Various options that have defaults; see 'defaultOptions'+  }++-- | Use this to implement 'Yesod.Core.makeSessionBackend'.+--+-- The @session@ type parameter represents the Persistent entity+-- you're using to store sessions+-- (see the 'SessionPersistence' field of the configuration).+makeSessionBackend+  :: forall persistentBackend persistentRecord+   . SessionConfiguration persistentBackend persistentRecord+  -> IO SessionBackend+makeSessionBackend configuration =+  let SessionConfiguration {persistence, options} = configuration+  in  case persistence of+        SessionPersistence {runTransaction} ->+          makeSessionBackend'+            SessionConfiguration'+              { storage = persistentStorage persistence+              , options = options+              , runTransaction+              }++data SessionConfiguration' session = forall tx.+  Monad tx =>+  SessionConfiguration'+  { storage :: forall a. StorageOperation a -> tx a+  , options :: Options tx IO+  , runTransaction :: forall a. tx a -> IO a+  }++makeSessionBackend' :: SessionConfiguration' session -> IO SessionBackend+makeSessionBackend' SessionConfiguration' {options = options :: Options tx m, ..} = do+  keyManager :: SessionKeyManager tx <-+    makeSessionKeyManager <$> options.randomization+  let sessionManager = SessionManager {keyManager, storage, options, runTransaction}+  pure $ makeSessionBackend'' sessionManager++makeSessionBackend'' :: Monad tx => SessionManager tx IO -> SessionBackend+makeSessionBackend'' sessionManager@SessionManager {options} =+  SessionBackend+    { sbLoadSession = \req -> do+        let+          cookie = findSessionKey (encodeUtf8 options.cookieName) req+          sessionKeyMaybe = cookie >>= checkedSessionKeyFromCookieValue sessionManager++        load <- loadSessionMaybe sessionManager sessionKeyMaybe++        pure+          ( loadedData load+          , \newData -> do+              save <- saveSession sessionManager load newData+              pure $ setCookie options CookieContext {cookie, load = load.got, save}+          )+    }
+ internal/Yesod/Session/SaveResult.hs view
@@ -0,0 +1,16 @@+module Yesod.Session.SaveResult+  ( SaveResult (..)+  ) where++import Internal.Prelude++data SaveResult a+  = -- | Nothing was done because a session freeze was requested+    Frozen+  | -- | There were no changes worth saving.+    NoChange+  | -- | A session was saved (either a new or existing session key).+    Saved a+  | -- | A session was deleted, and no new session was inserted.+    Deleted+  deriving stock (Eq, Ord, Show)
+ internal/Yesod/Session/SessionType.hs view
@@ -0,0 +1,22 @@+module Yesod.Session.SessionType+  ( Session (..)+  )+where++import Internal.Prelude++import Session.Key+import Session.Timing.Time+import Time+import Yesod.Core (SessionMap)++-- | What a saved session looks like in the database+data Session = Session+  { key :: SessionKey+  -- ^ Session key (primary key)+  , map :: SessionMap+  -- ^ Arbitrary session data+  , time :: Time UTCTime+  -- ^ Creation and access times, used to determine expiration+  }+  deriving stock (Eq, Show)
+ internal/Yesod/Session/Storage/Exceptions.hs view
@@ -0,0 +1,22 @@+module Yesod.Session.Storage.Exceptions+  ( StorageException (..)+  ) where++import Internal.Prelude++import Yesod.Session.SessionType (Session (..))++-- | Common exceptions that may be thrown by any storage.+data StorageException+  = -- | Thrown when attempting to insert a new session and+    --   another session with the same key already exists+    SessionAlreadyExists+      { existingSession :: Session+      , newSession :: Session+      }+  | -- | Thrown when attempting to replace an existing session+    --   but no session with the same key exists+    SessionDoesNotExist+      {newSession :: Session}+  deriving stock (Eq, Show)+  deriving anyclass (Exception)
+ internal/Yesod/Session/Storage/Operation.hs view
@@ -0,0 +1,48 @@+module Yesod.Session.Storage.Operation+  ( StorageOperation (..)+  , StorageOperation' (..)+  ) where++import Internal.Prelude++import Session.Key+import Yesod.Session.SessionType++data StorageOperation'+  = forall result. StorageOperation' (StorageOperation result)++deriving stock instance Show StorageOperation'++{- FOURMOLU_DISABLE -}++instance Eq StorageOperation' where+  (==) = \case+    StorageOperation' a@GetSession{}     -> \case StorageOperation' b@GetSession{}     -> a == b; _ -> False+    StorageOperation' a@DeleteSession{}  -> \case StorageOperation' b@DeleteSession{}  -> a == b; _ -> False+    StorageOperation' a@InsertSession{}  -> \case StorageOperation' b@InsertSession{}  -> a == b; _ -> False+    StorageOperation' a@ReplaceSession{} -> \case StorageOperation' b@ReplaceSession{} -> a == b; _ -> False++{- FOURMOLU_ENABLE -}++data StorageOperation result+  = -- | Get the session for the given session key+    --+    --   Returns 'Nothing' if the session is not found.+    result ~ Maybe Session => GetSession SessionKey+  | -- | Delete the session with given session key+    --+    -- Does not do anything if the session is not found.+    result ~ () => DeleteSession SessionKey+  | -- | Insert a new session+    --+    -- Throws 'SessionAlreadyExists' if there already exists a session with the same key.+    -- We only call this method after generating a fresh session key.+    result ~ () => InsertSession Session+  | -- | Replace the contents of a session+    --+    -- Throws 'SessionDoesNotExist' if there is no session with the given session key.+    -- We only call this method when updating a session that is known to exist.+    result ~ () => ReplaceSession Session++deriving stock instance Eq (StorageOperation result)+deriving stock instance Show (StorageOperation result)
+ internal/Yesod/Session/Storage/Save.hs view
@@ -0,0 +1,82 @@+module Yesod.Session.Storage.Save+  ( save+  ) where++import Internal.Prelude++import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import Data.Map.Strict qualified as Map+import Session.Key+import Session.Timing.Options+import Session.Timing.Time+import Time+import Yesod.Core (SessionMap)+import Yesod.Session.Options+import Yesod.Session.SessionType+import Yesod.Session.Storage.Operation++-- | Save a session to the database+--+-- Return value of 'Nothing' indicates that no changes were made.+-- 'Just' is returned when a session was saved, either by an insert+-- or a replace operation.+save+  :: Monad tx+  => Options tx m+  -> (forall a. StorageOperation a -> tx a)+  -> SessionKeyManager tx+  -> UTCTime+  -- ^ The current time+  -> SessionMap+  -- ^ The new session data to be saved+  -> Maybe Session+  -- ^ What's in the database+  -> tx (Maybe Session)+save options storage sessionKeyManager now newInfo oldSessionMaybe =+  asumM+    [ runMaybeT $ do+        guardMaybeT $ isNothing oldSessionMaybe+        guardMaybeT $ Map.null newInfo+        pure Nothing+    , runMaybeT $ do+        -- If the data is the same and the old access time is within+        -- the timeout resolution, just return the old session without+        -- doing anything else.+        res <- assertJust options.timing.resolution+        old <- assertJust oldSessionMaybe+        guardMaybeT $ old.map == newInfo+        guardMaybeT $ diffUTCTime now old.time.accessed < res+        pure Nothing+    , runMaybeT $ do+        oldSession <- assertJust oldSessionMaybe+        let newSession =+              Session+                { key = oldSession.key+                , map = newInfo+                , time = Time {created = oldSession.time.created, accessed = now}+                }+        lift $ storage $ ReplaceSession newSession+        pure $ Just newSession+    ]+    `orElseM` do+      sessionKey <- sessionKeyManager.new+      let newSession =+            Session+              { key = sessionKey+              , map = newInfo+              , time = Time {created = now, accessed = now}+              }+      storage $ InsertSession newSession+      pure $ Just newSession++orElseM :: Monad m => m (Maybe a) -> m a -> m a+a `orElseM` b = a >>= maybe b pure++asumM :: Monad m => [m (Maybe a)] -> m (Maybe a)+asumM = \case [] -> pure Nothing; x : xs -> x >>= maybe (asumM xs) (pure . Just)++guardMaybeT :: Monad m => Bool -> MaybeT m ()+guardMaybeT = \case True -> pure (); False -> MaybeT (pure Nothing)++assertJust :: Monad m => Maybe a -> MaybeT m a+assertJust = MaybeT . pure
+ library/Yesod/Session/Persist.hs view
@@ -0,0 +1,80 @@+module Yesod.Session.Persist+  ( -- * Setup+    makeSessionBackend+  , SessionConfiguration (..)++    -- * Options+  , Options (..)+  , defaultOptions+  , hoistOptions++    -- * Timing+  , TimingOptions (..)+  , defaultTimingOptions++    -- * Timeout+  , Timeout (..)+  , defaultTimeout++    -- * Transport security+  , TransportSecurity (..)++    -- * Session data model+  , Session (..)+  , SessionKey (..)+  , Time (..)++    -- * Randomization+  , Randomization (..)+  , defaultRandomization+  , deterministicallyRandom+  , DeterministicRandomization (..)++    -- * Storage+  , SessionPersistence (..)+  , StorageException (..)++    -- * Key rotation+  , rotateSessionKey+  , assignSessionKeyRotation+  , KeyRotation (..)++    -- * Freezing+  , disableSessionManagement+  , assignSessionFreeze+  , SessionFreeze (..)++    -- * Session map embedding+  , SessionEmbeddings (..)+  , HasSessionEmbeddings (..)+  , Embedding (..)+  , SessionMapEmbedding+  , MapOperations (..)+  , bsKeyEmbedding+  , dimapEmbedding+  , showReadKeyEmbedding++    -- * Comparison+  , Comparison (..)+  , differsOn+  ) where++import Comparison+import Embedding+import Randomization+import Session.Freeze+import Session.Key+import Session.KeyRotation+import Session.Timing.Options+import Session.Timing.Time+import Session.Timing.Timeout+import Session.TransportSecurity+import Yesod.Session.Embedding.Map+import Yesod.Session.Embedding.Options+import Yesod.Session.Freeze+import Yesod.Session.KeyRotation+import Yesod.Session.Options+import Yesod.Session.Persist.Storage+import Yesod.Session.Persist.Yesod+import Yesod.Session.SessionType+import Yesod.Session.Storage.Exceptions
+ package.yaml view
@@ -0,0 +1,103 @@+name: yesod-session-persist+version: 0.0.0.0+maintainer: Freckle Education+category: Web+github: freckle/yesod-session-persist+synopsis: SQL session backend for Yesod+description: |+  Use Persistent to store Yesod sessions++extra-doc-files:+  - README.md+  - CHANGELOG.md++extra-source-files:+  - package.yaml++language: GHC2021++ghc-options:+  - -Weverything+  - -Wno-all-missed-specialisations+  - -Wno-missed-specialisations+  - -Wno-missing-exported-signatures # re-enables missing-signatures+  - -Wno-missing-import-lists+  - -Wno-missing-kind-signatures+  - -Wno-missing-local-signatures+  - -Wno-missing-safe-haskell-mode+  - -Wno-monomorphism-restriction+  - -Wno-partial-fields+  - -Wno-prepositive-qualified-module+  - -Wno-safe+  - -Wno-unsafe+  - -fwrite-ide-info++dependencies:+  - base < 5++default-extensions:+  - AllowAmbiguousTypes+  - DeriveAnyClass+  - DerivingStrategies+  - DuplicateRecordFields+  - FunctionalDependencies+  - GADTs+  - ImpredicativeTypes+  - LambdaCase+  - NoFieldSelectors+  - NoImplicitPrelude+  - OverloadedRecordDot+  - OverloadedStrings+  - QuantifiedConstraints+  - RecordWildCards+  - TypeFamilies+  - UndecidableInstances++library:+  source-dirs: library+  dependencies:+    - internal++internal-libraries:+  internal:+    source-dirs: internal+    dependencies:+      - annotated-exception+      - base64+      - bytestring+      - containers+      - cookie+      - crypton+      - exceptions+      - http-types+      - mtl+      - persistent+      - text+      - time+      - transformers+      - wai+      - yesod-core++tests:+  spec:+    main: Spec.hs+    source-dirs: tests+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+    dependencies:+      - aeson+      - containers+      - cookie+      - hspec+      - internal+      - mtl+      - QuickCheck+      - random+      - stm+      - text+      - time+      - wai+      - wai-extra+      - yesod+      - yesod-core+      - yesod-session-persist+      - yesod-test
+ tests/Session/KeySpec.hs view
@@ -0,0 +1,83 @@+module Session.KeySpec+  ( spec+  ) where++import Test.Prelude++import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Session.Key+import Yesod.Session.Manager++spec :: Spec+spec = context "SessionKeyManager" $ do+  specify "generates 24-character text"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      Mock {sessionManager} <- newMock id mockInit+      sessionKey <- newSessionKey sessionManager+      pure $ T.length sessionKey.text == 24++  specify "uses only letters, numbers, dash, underscore"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      Mock {sessionManager} <- newMock id mockInit+      sessionKey <- newSessionKey sessionManager+      let charactersPresent = Set.fromList (T.unpack sessionKey.text)+      pure $ charactersPresent `Set.isSubsetOf` charactersWanted++  specify "never generates the same key twice"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      Mock {sessionManager} <- newMock id mockInit+      let n = 1000+      sessionKeys <-+        fmap Set.fromList+          $ replicateM n+          $ newSessionKey sessionManager+      pure $ Set.size sessionKeys == n++  specify "accepts its own keys"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      Mock {sessionManager} <- newMock id mockInit+      sessionKey <- newSessionKey sessionManager+      pure $ sessionKeyAppearsReasonable sessionManager sessionKey++  specify "does not accept invalid keys"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      Mock {sessionManager} <- newMock id mockInit+      pure+        $ all+          (isNothing . checkedSessionKeyFromCookieValue sessionManager)+          someInvalidCookies++charactersWanted :: Set Char+charactersWanted =+  foldMap Set.fromList [['a' .. 'z'], ['A' .. 'Z'], ['0' .. '9'], "-_"]++someInvalidSessionKeyTexts :: [Text]+someInvalidSessionKeyTexts =+  [ ""+  , "123456789-123456789-123"+  , "123456789-123456789-12345"+  , "aaaaaaaaaaaaaaaaaa*aaaaa"+  ]++someInvalidCookies :: [ByteString]+someInvalidCookies =+  (encodeUtf8 <$> someInvalidSessionKeyTexts)+    <> someInvalidUtf8ByteStrings++someInvalidUtf8ByteStrings :: [ByteString]+someInvalidUtf8ByteStrings =+  [ "\xc3\x28"+  , "\xa0\xa1"+  , "\xe2\x28\xa1"+  , "\xe2\x82\x28"+  , "\xf0\x28\x8c\xbc"+  , "\xf0\x90\x28\xbc"+  , "\xf0\x28\x8c\x28"+  ]
+ tests/Spec.hs view
@@ -0,0 +1,3 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-missing-export-lists #-}++module Spec (main) where
+ tests/Test/Gen/General.hs view
@@ -0,0 +1,43 @@+module Test.Gen.General+  ( chooseNominalDiffTime+  , chooseTime+  , chooseFixed+  , genMaybe+  , genVectorOfRange+  ) where++import Internal.Prelude++import Test.QuickCheck (Gen, choose)+import Test.QuickCheck.Gen qualified as Gen+import Time++chooseNominalDiffTime+  :: (NominalDiffTime, NominalDiffTime) -> Gen NominalDiffTime+chooseNominalDiffTime =+  fmap secondsToNominalDiffTime+    . chooseFixed+    . both nominalDiffTimeToSeconds++chooseFixed :: (Fixed a, Fixed a) -> Gen (Fixed a)+chooseFixed = fmap MkFixed . Gen.choose . both (\(MkFixed x) -> x)++both :: (a -> b) -> (a, a) -> (b, b)+both f = bimap f f++chooseTime :: (UTCTime, UTCTime) -> Gen UTCTime+chooseTime (a, b) =+  Gen.frequency+    [ (1,) $ Gen.elements [a, b]+    , (10,) $ do+        d <- chooseNominalDiffTime (0, diffUTCTime b a)+        Gen.elements [addUTCTime d a, addUTCTime (negate d) b]+    ]++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe g = Gen.oneof [pure Nothing, Just <$> g]++genVectorOfRange :: (Int, Int) -> Gen a -> Gen [a]+genVectorOfRange (a, b) g = do+  i <- choose (a, b)+  Gen.vectorOf i g
+ tests/Test/Gen/Mock.hs view
@@ -0,0 +1,87 @@+module Test.Gen.Mock+  ( MockInit (..)+  , genMockInit+  , TimeoutGenOptions+  , requireSomeTimeLimit+  , noTimeoutResolution+  )+where++import Internal.Prelude++import Test.Gen.General+import Test.QuickCheck (Arbitrary (arbitrary), Gen)+import Test.QuickCheck.Gen qualified as Gen+import Time+import Yesod.Session.Persist++data MockInit = MockInit+  { randomSeed :: Int+  , time :: UTCTime+  , timing :: TimingOptions NominalDiffTime+  }+  deriving stock (Eq, Show)++genMockInit :: (TimeoutGenOptions -> TimeoutGenOptions) -> Gen MockInit+genMockInit timeoutOptions = do+  randomSeed <- arbitrary+  time <-+    chooseTime+      (UTCTime (fromOrdinalDate 1950 0) 0, UTCTime (fromOrdinalDate 2050 0) 0)+  timing <- genTimingOptions (timeoutOptions defaultTimeoutGenOptions)+  pure MockInit {..}++data TimeoutGenOptions = TimeoutGenOptions+  { requireSomeLimit :: Bool+  , generateResolution :: Maybe Bool+  }++defaultTimeoutGenOptions :: TimeoutGenOptions+defaultTimeoutGenOptions =+  TimeoutGenOptions+    { requireSomeLimit = False+    , generateResolution = Nothing+    }++-- | Ensure that the generated settings have at least and idle or an absolute timeout+--+-- Use this for tests that require an expired session, since without timeout+-- settings no session can expire.+requireSomeTimeLimit :: TimeoutGenOptions -> TimeoutGenOptions+requireSomeTimeLimit x = x {requireSomeLimit = True}++-- | Ensure that the generate settings do not have a timeout resolution+--+-- This disables the optimization that prevents a session from being saved to the+-- database when the only change is a small increment in the access time.+-- Use this when the optimization would overcomplicate a test's assertion that it+-- performs an update to an existing session.+noTimeoutResolution :: TimeoutGenOptions -> TimeoutGenOptions+noTimeoutResolution x = x {generateResolution = Just False}++genTimingOptions :: TimeoutGenOptions -> Gen (TimingOptions NominalDiffTime)+genTimingOptions x = do+  timeout <- do+    (requireIdle, requireAbsolute) <-+      if x.requireSomeLimit+        then Gen.elements [(False, True), (True, False)]+        else pure (False, False)+    idle <-+      (if requireIdle then fmap Just else genMaybe)+        $ chooseNominalDiffTime (secondsToNominalDiffTime 60, nominalDay)+    absolute <-+      (if requireAbsolute then fmap Just else genMaybe)+        $ maybe id (+) idle -- Absolute timeout should be greater than idle timeout+        <$> chooseNominalDiffTime (secondsToNominalDiffTime 60, nominalDay)+    pure Timeout {idle, absolute}+  let resolutionGenerator = case timeout.idle <|> timeout.absolute of+        Just t ->+          -- Resolution should be a fraction of the smaller of the timeout limits+          chooseNominalDiffTime (t / 10, t / 2)+        Nothing ->+          chooseNominalDiffTime (secondsToNominalDiffTime 2, secondsToNominalDiffTime 60)+  resolution <- case x.generateResolution of+    Nothing -> genMaybe resolutionGenerator+    Just True -> Just <$> resolutionGenerator+    Just False -> pure Nothing+  pure TimingOptions {timeout, resolution}
+ tests/Test/Gen/Session.hs view
@@ -0,0 +1,161 @@+module Test.Gen.Session+  ( SessionInit (..)+  , genSessionInit+  , SessionGenOptions+  , requireLive+  , requireExpired+  ) where++import Internal.Prelude++import Data.Map.Strict qualified as Map+import Test.Gen.General+import Test.Gen.Mock+import Test.QuickCheck (Gen)+import Test.QuickCheck.Gen qualified as Gen+import Time+import Yesod.Core (SessionMap)+import Yesod.Session.Persist+import Prelude (error)++data SessionInit = SessionInit+  { time :: Time UTCTime+  , map :: SessionMap+  }+  deriving stock (Eq, Show)++genSessionInit+  :: (SessionGenOptions -> SessionGenOptions) -> MockInit -> Gen SessionInit+genSessionInit fsgo mockInit = do+  let SessionGenOptions {liveness} = fsgo defaultSessionGenOptions+  map <- genSessionData+  let now = mockInit.time+  let timeout = mockInit.timing.timeout+  time <- case liveness of+    Nothing -> whatever now+    Just Live -> live timeout now+    Just (Expired reasonMaybe) -> do+      reason <- case reasonMaybe of+        Nothing ->+          case (nonEmpty . catMaybes)+            [ timeout.idle $> IdleTimeout+            , timeout.absolute $> AbsoluteTimeout+            ] of+            Just xs -> Gen.elements $ toList xs+            Nothing ->+              error+                "Cannot generate an expired session for a configuration \+                \with no timeout limits"+        Just x -> pure x+      case reason of+        IdleTimeout ->+          fromMaybe+            ( error+                "Cannot generate an expired-by-idle-timeout \+                \session for a configuration with no idle timeout limit"+            )+            $ expiredViaIdleTimeout timeout now+        AbsoluteTimeout ->+          fromMaybe+            ( error+                "Cannot generate an expired-by-absolute-timeout session \+                \for a configuration with no absolute timeout limit"+            )+            $ expiredViaAbsoluteTimeout timeout now++  pure SessionInit {..}++whatever :: UTCTime -> Gen (Time UTCTime)+whatever now = do+  created <- chooseTime (subtractUTCTime nominalDay now, now)+  accessed <- chooseTime (created, now)+  pure Time {accessed, created}++-- | Generates times for a session that is still live+live :: Timeout NominalDiffTime -> UTCTime -> Gen (Time UTCTime)+live timeout now = do+  accessed <-+    chooseTime+      ( subtractUTCTime+          ( case (timeout.idle, timeout.absolute) of+              (Just idleTimeout, _) -> pred idleTimeout+              (_, Just absoluteTimeout) -> pred absoluteTimeout+              _ -> nominalDay+          )+          now+      , now+      )+  created <-+    chooseTime+      ( case timeout.absolute of+          Just absoluteTimeout -> subtractUTCTime (pred absoluteTimeout) now+          Nothing -> subtractUTCTime nominalDay accessed+      , accessed+      )+  pure Time {accessed, created}++-- | Generates times for a session that is expired due to idle timeout+--   (returns 'Nothing' if there is no idle timeout)+expiredViaIdleTimeout+  :: Timeout NominalDiffTime -> UTCTime -> Maybe (Gen (Time UTCTime))+expiredViaIdleTimeout timeout now =+  timeout.idle <&> \idleTimeout -> do+    accessed <-+      chooseTime+        ( case timeout.absolute of+            Just absoluteTimeout -> subtractUTCTime absoluteTimeout now+            Nothing -> subtractUTCTime (idleTimeout + nominalDay) now+        , subtractUTCTime idleTimeout now+        )+    created <-+      chooseTime+        ( case timeout.absolute of+            Just absoluteTimeout -> subtractUTCTime absoluteTimeout now+            Nothing -> subtractUTCTime nominalDay accessed+        , accessed+        )+    pure Time {accessed, created}++-- | Generates times for a session that is expired due to absolute timeout+--   (returns 'Nothing' if there is no absolute timeout)+expiredViaAbsoluteTimeout+  :: Timeout NominalDiffTime -> UTCTime -> Maybe (Gen (Time UTCTime))+expiredViaAbsoluteTimeout timeout now =+  timeout.absolute <&> \absoluteTimeout -> do+    created <-+      let base = subtractUTCTime absoluteTimeout now+       in chooseTime (subtractUTCTime nominalDay base, base)+    accessed <-+      chooseTime+        ( case timeout.idle of+            Just idleTimeout -> subtractUTCTime idleTimeout now+            Nothing -> created+        , now+        )+    pure Time {accessed, created}++newtype SessionGenOptions = SessionGenOptions+  { liveness :: Maybe Liveness+  }++defaultSessionGenOptions :: SessionGenOptions+defaultSessionGenOptions = SessionGenOptions {liveness = Nothing}++requireLive :: SessionGenOptions -> SessionGenOptions+requireLive x = x {liveness = Just Live}++requireExpired :: SessionGenOptions -> SessionGenOptions+requireExpired x = x {liveness = Just (Expired Nothing)}++data Liveness = Live | Expired (Maybe ExpirationReason)++data ExpirationReason = IdleTimeout | AbsoluteTimeout+  deriving stock (Show)++genSessionData :: Gen (Map Text ByteString)+genSessionData = fmap Map.fromList $ do+  k <- Gen.choose (0, 5)+  Gen.vectorOf k+    $ (,)+    <$> Gen.elements ["", "a", "bc", "def", "ghij"]+    <*> Gen.elements ["", "a", "\0", "what"]
+ tests/Test/Mock.hs view
@@ -0,0 +1,78 @@+module Test.Mock+  ( Mock (..)+  , newMock+  , createArbitrarySession+  , advanceTime+  , advanceTimeBriefly+  ) where++import Internal.Prelude++import Control.Concurrent.STM.TVar+  ( TVar+  , modifyTVar'+  , newTVarIO+  , readTVarIO+  )+import Control.Monad.STM (STM, atomically)+import Session.Key+import Test.Gen.Mock+import Test.Gen.Session+import Test.MockStorage+import Test.Randomization+import Time+import Yesod.Session.Manager+import Yesod.Session.Persist+import Yesod.Session.Storage.Operation++data Mock tx m = Mock+  { sessionManager :: SessionManager tx m+  , currentTime :: TVar UTCTime+  , mockStorage :: MockStorage m+  }++newMock :: (Options STM IO -> Options STM IO) -> MockInit -> IO (Mock STM IO)+newMock opt MockInit {randomSeed, time, timing} = do+  let randomization = liftIO $ atomically $ newRandomization randomSeed+  currentTime <- newTVarIO time+  let clock = readTVarIO currentTime+  mockStorage@MockStorage {storage} <-+    hoistMockStorage atomically <$> atomically newMockStorage+  let options = opt defaultOptions {timing, clock, randomization}+  keyManager <- makeSessionKeyManager <$> randomization+  let sessionManager =+        SessionManager {keyManager, storage, options, runTransaction = atomically}+  pure Mock {sessionManager, currentTime, mockStorage}++createArbitrarySession :: Mock STM IO -> SessionInit -> IO SessionKey+createArbitrarySession mock sessionInit =+  let+    Mock {mockStorage, sessionManager} = mock+    SessionManager {storage, runTransaction} = sessionManager+  in+    offTheRecordIO mockStorage+      $ do+        key <- newSessionKey sessionManager+        let session =+              Session+                { key+                , map = sessionInit.map+                , time = sessionInit.time+                }+        runTransaction $ storage $ InsertSession session+        pure session.key++advanceTime :: MonadIO m => NominalDiffTime -> Mock STM IO -> m ()+advanceTime amount mock = do+  liftIO $ atomically $ modifyTVar' mock.currentTime $ addUTCTime amount++advanceTimeBriefly :: MonadIO m => Mock STM IO -> m ()+advanceTimeBriefly mock =+  let+    timeout = mock.sessionManager.options.timing.timeout++    change = case timeout.idle <|> timeout.absolute of+      Nothing -> secondsToNominalDiffTime 1+      Just upperBound -> upperBound / 10+  in+    advanceTime change mock
+ tests/Test/MockStorage.hs view
@@ -0,0 +1,100 @@+module Test.MockStorage+  ( newMockStorage+  , MockStorage (..)+  , hoistMockStorage+  , offTheRecordIO+  , takeTranscript+  ) where++import Internal.Prelude++import Control.Concurrent.STM.TVar+  ( TVar+  , modifyTVar'+  , newTVar+  , readTVar+  , readTVarIO+  , writeTVar+  )+import Control.Monad.STM (STM, atomically)+import Data.Map.Strict qualified as Map+import Data.Sequence ((|>))+import Data.Sequence qualified as Seq+import Session.Key+import Yesod.Session.SessionType+import Yesod.Session.Storage.Exceptions+import Yesod.Session.Storage.Operation++data MockStorage m = MockStorage+  { storage :: forall a. StorageOperation a -> STM a+  , runSTM :: forall a. STM a -> m a+  , transcript :: TVar (Seq StorageOperation')+  , getSessionKeys :: STM (Set SessionKey)+  , recordingVar :: TVar Bool+  }++hoistMockStorage :: (forall a. m a -> m' a) -> MockStorage m -> MockStorage m'+hoistMockStorage f MockStorage {..} =+  MockStorage {runSTM = f . runSTM, ..}++-- | Perform some action without modifying the transcript+offTheRecordIO :: MonadIO m => MockStorage m -> m a -> m a+offTheRecordIO mock action = do+  wasRecording <- liftIO $ readTVarIO mock.recordingVar+  liftIO $ atomically $ writeTVar mock.recordingVar False+  x <- action+  liftIO $ atomically $ writeTVar mock.recordingVar wasRecording+  pure x++takeTranscript :: MockStorage m -> m (Seq StorageOperation')+takeTranscript MockStorage {transcript, runSTM} =+  runSTM $ readTVar transcript <* writeTVar transcript Seq.empty++newMockStorage :: HasCallStack => STM (MockStorage STM)+newMockStorage = do+  transcript <- newTVar Seq.empty+  sessionsVar <- newTVar Map.empty+  recordingVar <- newTVar True++  pure+    MockStorage+      { transcript+      , recordingVar+      , getSessionKeys = Map.keysSet <$> readTVar sessionsVar+      , storage = \(op :: StorageOperation result) ->+          do+            readTVar recordingVar+              >>= (`when` modifyTVar' transcript (|> StorageOperation' op))+            handleOp sessionsVar op+      , runSTM = id+      }++handleOp+  :: HasCallStack+  => TVar (Map SessionKey Session)+  -> StorageOperation result+  -> STM result+handleOp ref = \case+  GetSession sessionKey -> readTVar ref <&> Map.lookup sessionKey+  DeleteSession sessionKey -> modifyTVar' ref $ Map.delete sessionKey+  InsertSession newSession -> do+    modifyTVarSTM ref+      $ Map.alterF+        ( maybe+            (pure $ Just newSession)+            ( \existingSession ->+                throwWithCallStack SessionAlreadyExists {existingSession, newSession}+            )+        )+        newSession.key+  ReplaceSession newSession ->+    modifyTVarSTM ref+      $ Map.alterF+        ( maybe+            (throwWithCallStack SessionDoesNotExist {newSession})+            (const $ pure $ Just newSession)+        )+        newSession.key++modifyTVarSTM :: TVar a -> (a -> STM a) -> STM ()+modifyTVarSTM ref f = readTVar ref >>= f >>= (writeTVar ref $!)
+ tests/Test/Prelude.hs view
@@ -0,0 +1,13 @@+module Test.Prelude+  ( module X+  ) where++import GHC.Generics as X (Generic)+import Internal.Prelude as X+import Test.Gen.General as X+import Test.Gen.Mock as X+import Test.Gen.Session as X+import Test.Hspec as X+import Test.Mock as X+import Test.MockStorage as X+import Test.QuickCheck as X hiding (Fixed)
+ tests/Test/Randomization.hs view
@@ -0,0 +1,29 @@+module Test.Randomization+  ( newRandomization+  ) where++import Internal.Prelude++import Control.Concurrent.STM.TVar (newTVar, readTVar, writeTVar)+import Control.Monad.STM (STM)+import Randomization+import System.Random qualified as Random++newRandomization :: Int -> STM (Randomization STM)+newRandomization seed =+  deterministicallyRandomSTM+    $ let go g =+            DeterministicRandomization $ \n ->+              let (bs, g') = Random.genByteString (fromIntegral n) g+              in  (bs, go g')+      in  go $ Random.mkStdGen seed++deterministicallyRandomSTM+  :: DeterministicRandomization -> STM (Randomization STM)+deterministicallyRandomSTM =+  newTVar >=> pure . \ref ->+    Randomization $ \n -> do+      DeterministicRandomization gen <- readTVar ref+      let (bs, gen') = gen n+      writeTVar ref $! gen'+      pure bs
+ tests/Yesod/Session/Manager/LoadSpec.hs view
@@ -0,0 +1,60 @@+module Yesod.Session.Manager.LoadSpec+  ( spec+  ) where++import Test.Prelude++import Data.Sequence qualified as Seq+import Yesod.Session.Manager+import Yesod.Session.Manager.Load+import Yesod.Session.SessionType++spec :: Spec+spec = context "Session loading" $ do+  specify "may load a session"+    $ forAll (genMockInit id)+    $ \mockInit ->+      forAll (genSessionInit requireLive mockInit) $ \sessionInit ->+        forAll (genVectorOfRange (0, 5) $ genSessionInit id mockInit)+          $ \otherSessionInits ->+            ioProperty $ do+              mock@Mock {sessionManager} <- newMock id mockInit+              traverse_ (createArbitrarySession mock) otherSessionInits+              sessionKey <- createArbitrarySession mock sessionInit+              load <- loadSession sessionManager sessionKey+              pure $ counterexample (show load) $ didSessionLoad load++  context "may load nothing" $ do+    specify "when there is no session key"+      $ forAll (genMockInit id)+      $ \mockInit ->+        forAll (genVectorOfRange (0, 5) $ genSessionInit id mockInit)+          $ \sessionInits -> ioProperty $ do+            mock@Mock {sessionManager} <- newMock id mockInit+            traverse_ (createArbitrarySession mock) sessionInits+            load :: Load Session <- loadNothing sessionManager+            transcript <- takeTranscript mock.mockStorage+            pure+              $ counterexample (show load) (not $ didSessionLoad load)+              .&&. counterexample (show transcript) (transcript == Seq.empty)++    specify "when the key is not in storage"+      $ forAll (genMockInit id)+      $ \mockInit ->+        forAll (genVectorOfRange (0, 5) $ genSessionInit id mockInit)+          $ \sessionInits -> ioProperty $ do+            mock@Mock {sessionManager} <- newMock id mockInit+            traverse_ (createArbitrarySession mock) sessionInits+            sessionKey <- newSessionKey sessionManager+            load <- loadSession sessionManager sessionKey+            pure $ counterexample (show load) (not $ didSessionLoad load)++    specify "when the session is expired"+      $ forAll (genMockInit requireSomeTimeLimit)+      $ \mockInit ->+        forAll (genSessionInit requireExpired mockInit)+          $ \sessionInit -> ioProperty $ do+            mock@Mock {sessionManager} <- newMock id mockInit+            sessionKey <- createArbitrarySession mock sessionInit+            load <- loadSession sessionManager sessionKey+            pure $ counterexample (show load) (not $ didSessionLoad load)
+ tests/Yesod/Session/Manager/SaveSpec.hs view
@@ -0,0 +1,134 @@+module Yesod.Session.Manager.SaveSpec+  ( spec+  ) where++import Test.Prelude++import Control.Concurrent.STM.TVar (readTVarIO)+import Control.Monad.State (execState)+import Data.Map.Strict qualified as Map+import Data.Sequence qualified as Seq+import Embedding+import Session.KeyRotation+import Session.Timing.Time+import Yesod.Core (SessionMap)+import Yesod.Session.Embedding.Options+import Yesod.Session.Manager+import Yesod.Session.Manager.Load+import Yesod.Session.Manager.Save+import Yesod.Session.Options+import Yesod.Session.SaveResult+import Yesod.Session.SessionType+import Yesod.Session.Storage.Operation++spec :: Spec+spec = context "saveSession" $ do+  specify "doesn't unnecessarily create a session"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      mock@Mock {sessionManager} <- newMock id mockInit+      load <- loadNothing sessionManager+      save <- saveSession sessionManager load $ loadedData load+      transcript <- takeTranscript mock.mockStorage+      pure+        $ counterexample (show save) (save === NoChange)+        .&&. counterexample (show transcript) (transcript == Seq.empty)++  specify "may create a session"+    $ forAll (genMockInit id)+    $ \mockInit -> ioProperty $ do+      mock@Mock {sessionManager} <- newMock id mockInit+      now <- readTVarIO mock.currentTime+      load <- loadNothing sessionManager+      let newData = loadedData load & Map.insert "a" "b"+      session <- assertSaved =<< saveSession sessionManager load newData+      transcript <- takeTranscript mock.mockStorage+      pure+        $ counterexample+          (show session)+          ( (session.map == newData)+              .&&. (session.time.created == now)+              .&&. (session.time.accessed == now)+          )+        .&&. counterexample+          (show transcript)+          (transcript == Seq.fromList [StorageOperation' $ InsertSession session])++  specify "may update a loaded session"+    $ forAll (genMockInit noTimeoutResolution)+    $ \mockInit -> ioProperty $ do+      mock@Mock {sessionManager} <- newMock id mockInit+      time1 <- readTVarIO mock.currentTime+      session1 <- do+        load <- loadNothing sessionManager+        let newData = loadedData load & Map.insert "a" "b"+        assertSaved =<< saveSession sessionManager load newData+      advanceTimeBriefly mock+      time2 <- readTVarIO mock.currentTime+      void $ takeTranscript mock.mockStorage+      load <- loadSession sessionManager session1.key+      let newData = loadedData load & Map.insert "c" "d"+      session2 <- assertSaved =<< saveSession sessionManager load newData+      transcript <- takeTranscript mock.mockStorage+      pure+        $ counterexample+          (show session2)+          ( (session2.map == Map.fromList [("a", "b"), ("c", "d")])+              .&&. (session2.time.created == time1)+              .&&. (session2.time.accessed == time2)+          )+        .&&. counterexample+          (show transcript)+          ( transcript+              == Seq.fromList+                [ StorageOperation' $ GetSession session2.key+                , StorageOperation' $ ReplaceSession session2+                ]+          )++  specify "changes the session key when we rotate"+    $ forAll (genMockInit noTimeoutResolution)+    $ \mockInit -> ioProperty $ do+      mock@Mock {sessionManager} <- newMock id mockInit+      let SessionManager {options} = sessionManager+      session1 <- do+        load <- loadNothing sessionManager+        let newData = loadedData load & Map.insert "a" "b"+        assertSaved =<< saveSession sessionManager load newData+      advanceTimeBriefly mock+      (session2, transcript) <- do+        load <- loadSession sessionManager session1.key+        void $ takeTranscript mock.mockStorage+        let newData =+              loadedData load+                & setSessionKeyRotation options (Just RotateSessionKey)+                & Map.insert "c" "d"+        session <- assertSaved =<< saveSession sessionManager load newData+        transcript <- takeTranscript mock.mockStorage+        pure (session, transcript)+      loadForOldSession <- loadSession sessionManager session1.key+      loadForNewSession <- loadSession sessionManager session2.key+      pure+        $ counterexample (show (session1, session2)) (session1.key /= session2.key)+        .&&. counterexample (show loadForOldSession) (not $ didSessionLoad loadForOldSession)+        .&&. counterexample+          (show loadForNewSession)+          (loadedData loadForNewSession == Map.fromList [("a", "b"), ("c", "d")])+        .&&. counterexample+          (show transcript)+          ( transcript+              == Seq.fromList+                [ StorageOperation' $ DeleteSession session1.key+                , StorageOperation' $ InsertSession session2+                ]+          )++setSessionKeyRotation+  :: Options tx m -> Maybe KeyRotation -> SessionMap -> SessionMap+setSessionKeyRotation options =+  execState . embed options.embedding.keyRotation++assertSaved :: Show a => SaveResult a -> IO a+assertSaved = \case+  Saved x -> pure x+  x -> fail $ "Expected Saved, but got: " <> show x
+ tests/Yesod/Session/Persist/YesodApp.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-missing-deriving-strategies #-}+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}++module Yesod.Session.Persist.YesodApp where++import Test.Prelude++import Comparison+import Control.Monad.STM (STM)+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Data.Time qualified as Time+import Session.KeyRotation+import Session.Timing.Options+import Time+import Yesod+  ( FromJSON+  , Html+  , RenderRoute (renderRoute)+  , Yesod (defaultLayout, makeSessionBackend)+  , deleteSession+  , getSession+  , mkYesod+  , parseRoutes+  , requireInsecureJsonBody+  , setSession+  , whamlet+  )+import Yesod.Core (SessionMap)+import Yesod.Session.Manager+import Yesod.Session.Persist+import Yesod.Session.Persist.Yesod++newApp :: TimingOptions NominalDiffTime -> IO App+newApp timing = do+  -- We have limited ability to mock time in a Yesod test, because+  -- the cookie manager will expire cookies based on the real time.+  time <- Time.getCurrentTime++  randomSeed <- generate arbitrary+  let mockInit = MockInit {randomSeed, time, timing}+  mock <- newMock (\x -> x {keyRotationTrigger}) mockInit+  pure App {mock}++keyRotationTrigger :: Comparison SessionMap -> Maybe KeyRotation+keyRotationTrigger x = do+  guard $ differsOn (Map.lookup "user-id") x+  Just RotateSessionKey++newtype App = App+  { mock :: Mock STM IO+  }++-- Derive routes and instances for App.+mkYesod+  "App"+  [parseRoutes|+    / HomeR GET+    /ping PingR GET+    /user UserR GET+    /log-in LogInR POST+    /log-out LogOutR POST+    /rotate RotateR GET+  |]++instance HasSessionEmbeddings App where+  getSessionEmbeddings app =+    let+      App {mock} = app+      Mock {sessionManager} = mock+      SessionManager {options} = sessionManager+      Options {embedding} = options+    in+      embedding++instance Yesod App where+  makeSessionBackend App {mock} = do+    let Mock {sessionManager} = mock+    pure $ Just $ makeSessionBackend'' sessionManager++getHomeR :: Handler Html+getHomeR = defaultLayout [whamlet|Hello World!|]++getPingR :: Handler Text+getPingR = do+  disableSessionManagement+  pure "pong"++getUserR :: Handler Text+getUserR =+  maybe "-" (T.pack . show) . Map.lookup "user-id" <$> getSession++postLogInR :: Handler ()+postLogInR = do+  form :: LoginForm <- requireInsecureJsonBody+  setSession "user-id" form.uid++postLogOutR :: Handler ()+postLogOutR = deleteSession "user-id"++newtype LoginForm = LoginForm+  { uid :: Text+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON)++getRotateR :: Handler ()+getRotateR = rotateSessionKey
+ tests/Yesod/Session/Persist/YesodSpec.hs view
@@ -0,0 +1,209 @@+module Yesod.Session.Persist.YesodSpec+  ( spec+  ) where++import Test.Prelude++import Control.Concurrent.STM.TVar (readTVarIO)+import Data.Aeson (encode, object)+import Data.List qualified as List+import Data.Sequence qualified as Seq+import Data.Text.Encoding (encodeUtf8)+import Network.Wai (Middleware)+import Network.Wai.Test (simpleHeaders)+import Time+import Web.Cookie (SetCookie (..), def, parseSetCookie)+import Yesod.Session.Persist+import Yesod.Session.Persist.YesodApp (App (..), Route (..), newApp)+import Yesod.Session.Storage.Operation+import Yesod.Test+  ( YesodExample+  , bodyEquals+  , getTestYesod+  , request+  , setMethod+  , setRequestBody+  , setUrl+  , withResponse+  )++spec :: Spec+spec =+  withApp defaultTimingOptions $ do+    context "Yesod App" $ do+      specify @(YesodExample App ()) "Sets a session cookie" $ do+        app <- getTestYesod+        now <- liftIO $ readTVarIO app.mock.currentTime++        -- Make a request to a normal route+        request $ do setUrl HomeR; setMethod "GET"++        -- Since there was no session, one should be inserted+        sessionKey :: SessionKey <- do+          transcript <- liftIO $ takeTranscript app.mock.mockStorage+          case toList transcript of+            [StorageOperation' (InsertSession s)] -> pure s.key+            _ -> liftIO $ fail $ show transcript++        -- We should receive a set-cookie header+        assertSetCookie+          $ def+            { setCookieName = "session-key"+            , setCookieValue = encodeUtf8 sessionKey.text+            , setCookiePath = Just "/"+            , setCookieExpires =+                Just+                  $ truncateToSeconds+                  $ addUTCTime (60 * 60 * 8) now+            , setCookieHttpOnly = True+            }++      specify @(YesodExample App ())+        "Doesn't set a session cookie if sessions are disabled"+        $ do+          app <- getTestYesod++          -- Make a request to a route without session management+          request $ do setUrl PingR; setMethod "GET"++          -- No storage operations should have been performed+          transcript <- liftIO $ takeTranscript app.mock.mockStorage+          liftIO $ transcript `shouldBe` Seq.empty++          -- No cookie should be set+          assertNoSetCookie++      specify @(YesodExample App ()) "Saves the session"+        $ do+          app <- getTestYesod++          -- Log in+          request $ do+            setUrl LogInR+            setMethod "POST"+            setRequestBody $ encode $ object [("uid", "xyz")]++          sessionKey :: SessionKey <- do+            transcript <- liftIO $ takeTranscript app.mock.mockStorage+            case toList transcript of+              [StorageOperation' (InsertSession s)] -> pure s.key+              _ -> liftIO $ fail $ show transcript++          replicateM_ 3 $ do+            -- A short pause should not affect anything+            advanceTime 90 app.mock++            -- Verify that we're now logged in+            request $ do setUrl UserR; setMethod "GET"+            bodyEquals (show @ByteString "xyz")++            liftIO $ do+              transcript <- takeTranscript app.mock.mockStorage+              toList transcript+                `shouldBe` [StorageOperation' (GetSession sessionKey)]++      specify @(YesodExample App ()) "Does not load an expired session"+        $ do+          app <- getTestYesod++          request $ do+            setUrl LogInR+            setMethod "POST"+            setRequestBody $ encode $ object [("uid", "xyz")]++          -- A pause longer than the idle timeout should kill the session+          advanceTime (60 * 60 * 10) app.mock++          request $ do setUrl UserR; setMethod "GET"+          bodyEquals "-"++      specify @(YesodExample App ()) "rotates the key when 'rotateSessionKey' is used" $ do+        app <- getTestYesod++        -- Log in+        request $ do+          setUrl LogInR+          setMethod "POST"+          setRequestBody $ encode $ object [("uid", "xyz")]++        -- Get the session+        transcript <- liftIO $ takeTranscript app.mock.mockStorage+        sessionKey :: SessionKey <-+          case toList transcript of+            [StorageOperation' (InsertSession s)] -> pure s.key+            _ -> liftIO $ fail $ show transcript++        -- Make a request to the route that does a key rotation+        request $ do setUrl RotateR; setMethod "GET"++        -- The old session should be deleted+        transcript' <- liftIO $ takeTranscript app.mock.mockStorage+        liftIO+          $ List.take 2 (toList transcript')+          `shouldBe` [ StorageOperation' (GetSession sessionKey)+                     , StorageOperation' (DeleteSession sessionKey)+                     ]++        -- But we're still logged in+        request $ do setUrl UserR; setMethod "GET"+        bodyEquals (show @ByteString "xyz")++      specify @(YesodExample App ()) "rotates the key on auth changes"+        $ do+          app <- getTestYesod++          -- Log in+          request $ do+            setUrl LogInR+            setMethod "POST"+            setRequestBody $ encode $ object [("uid", "xyz")]++          -- Get the session+          transcript <- liftIO $ takeTranscript app.mock.mockStorage+          sessionKey :: SessionKey <-+            case toList transcript of+              [StorageOperation' (InsertSession s)] -> pure s.key+              _ -> liftIO $ fail $ show transcript++          -- Log in differently+          request $ do+            setUrl LogInR+            setMethod "POST"+            setRequestBody $ encode $ object [("uid", "hello")]++          -- The old session should be deleted+          transcript' <- liftIO $ takeTranscript app.mock.mockStorage+          liftIO+            $ List.take 2 (toList transcript')+            `shouldBe` [ StorageOperation' (GetSession sessionKey)+                       , StorageOperation' (DeleteSession sessionKey)+                       ]++          -- But we're still logged in as the new user+          request $ do setUrl UserR; setMethod "GET"+          bodyEquals (show @ByteString "hello")++withApp :: TimingOptions NominalDiffTime -> SpecWith (App, Middleware) -> Spec+withApp timing = around ((=<< newApp timing) . (. (,id :: Middleware)))++-- | Assert that the response contains a set-cookie header that parses to a particular value+assertSetCookie :: SetCookie -> YesodExample site ()+assertSetCookie expected =+  withResponse $ \response ->+    case List.lookup "set-cookie" $ simpleHeaders response of+      Just value -> liftIO $ parseSetCookie value `shouldBe` expected+      Nothing -> liftIO $ expectationFailure "no set-cookie header present"++-- | Fail if set-cookie is present in the response+assertNoSetCookie :: YesodExample site ()+assertNoSetCookie =+  withResponse $ \response ->+    case List.lookup "set-cookie" $ simpleHeaders response of+      Just value ->+        liftIO $ expectationFailure $ "expected no set-cookie, but got " <> show value+      Nothing -> pure ()++-- | Round a time to seconds, because that is the precision in cookie headers+truncateToSeconds :: UTCTime -> UTCTime+truncateToSeconds x =+  x {utctDayTime = secondsToDiffTime (truncate (utctDayTime x))}
+ yesod-session-persist.cabal view
@@ -0,0 +1,175 @@+cabal-version:      2.0+name:               yesod-session-persist+version:            0.0.0.0+license:            MIT+license-file:       LICENSE+maintainer:         Freckle Education+homepage:           https://github.com/freckle/yesod-session-persist#readme+bug-reports:        https://github.com/freckle/yesod-session-persist/issues+synopsis:           SQL session backend for Yesod+description:        Use Persistent to store Yesod sessions+category:           Web+build-type:         Simple+extra-source-files: package.yaml+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/yesod-session-persist++library+    exposed-modules:    Yesod.Session.Persist+    hs-source-dirs:     library+    other-modules:      Paths_yesod_session_persist+    autogen-modules:    Paths_yesod_session_persist+    default-language:   GHC2021+    default-extensions:+        AllowAmbiguousTypes DeriveAnyClass DerivingStrategies+        DuplicateRecordFields FunctionalDependencies GADTs+        ImpredicativeTypes LambdaCase NoFieldSelectors NoImplicitPrelude+        OverloadedRecordDot OverloadedStrings QuantifiedConstraints+        RecordWildCards TypeFamilies UndecidableInstances++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-partial-fields+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe+        -fwrite-ide-info++    build-depends:+        base >=4.16.4.0 && <5,+        internal++library internal+    exposed-modules:+        Comparison+        Embedding+        Internal.Prelude+        Randomization+        Session.Freeze+        Session.Key+        Session.KeyRotation+        Session.Timing.Math+        Session.Timing.Options+        Session.Timing.Time+        Session.Timing.Timeout+        Session.TransportSecurity+        Time+        Yesod.Session.Cookie.Logic+        Yesod.Session.Cookie.Reading+        Yesod.Session.Cookie.SetCookie+        Yesod.Session.Embedding.Map+        Yesod.Session.Embedding.Options+        Yesod.Session.Freeze+        Yesod.Session.KeyRotation+        Yesod.Session.Manager+        Yesod.Session.Manager.Load+        Yesod.Session.Manager.Save+        Yesod.Session.Options+        Yesod.Session.Persist.Storage+        Yesod.Session.Persist.Yesod+        Yesod.Session.SaveResult+        Yesod.Session.SessionType+        Yesod.Session.Storage.Exceptions+        Yesod.Session.Storage.Operation+        Yesod.Session.Storage.Save++    hs-source-dirs:     internal+    other-modules:      Paths_yesod_session_persist+    autogen-modules:    Paths_yesod_session_persist+    default-language:   GHC2021+    default-extensions:+        AllowAmbiguousTypes DeriveAnyClass DerivingStrategies+        DuplicateRecordFields FunctionalDependencies GADTs+        ImpredicativeTypes LambdaCase NoFieldSelectors NoImplicitPrelude+        OverloadedRecordDot OverloadedStrings QuantifiedConstraints+        RecordWildCards TypeFamilies UndecidableInstances++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-partial-fields+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe+        -fwrite-ide-info++    build-depends:+        annotated-exception >=0.2.0.0,+        base >=4.16.4.0 && <5,+        base64 >=0.4.2.4,+        bytestring >=0.11.4.0,+        containers >=0.6.5.1,+        cookie >=0.4.6,+        crypton >=0.33,+        exceptions >=0.10.4,+        http-types >=0.12.3,+        mtl >=2.2.2,+        persistent >=2.14.1.0,+        text >=1.2.5.0,+        time >=1.11.1.1,+        transformers >=0.5.6.2,+        wai >=3.2.3,+        yesod-core >=1.6.24.2++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    hs-source-dirs:     tests+    other-modules:+        Session.KeySpec+        Test.Gen.General+        Test.Gen.Mock+        Test.Gen.Session+        Test.Mock+        Test.MockStorage+        Test.Prelude+        Test.Randomization+        Yesod.Session.Manager.LoadSpec+        Yesod.Session.Manager.SaveSpec+        Yesod.Session.Persist.YesodApp+        Yesod.Session.Persist.YesodSpec+        Paths_yesod_session_persist++    autogen-modules:    Paths_yesod_session_persist+    default-language:   GHC2021+    default-extensions:+        AllowAmbiguousTypes DeriveAnyClass DerivingStrategies+        DuplicateRecordFields FunctionalDependencies GADTs+        ImpredicativeTypes LambdaCase NoFieldSelectors NoImplicitPrelude+        OverloadedRecordDot OverloadedStrings QuantifiedConstraints+        RecordWildCards TypeFamilies UndecidableInstances++    ghc-options:+        -Weverything -Wno-all-missed-specialisations+        -Wno-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-partial-fields+        -Wno-prepositive-qualified-module -Wno-safe -Wno-unsafe+        -fwrite-ide-info -threaded -rtsopts -with-rtsopts=-N++    build-depends:+        QuickCheck >=2.14.3,+        aeson >=2.0.3.0,+        base >=4.16.4.0 && <5,+        containers >=0.6.5.1,+        cookie >=0.4.6,+        hspec >=2.9.7,+        internal,+        mtl >=2.2.2,+        random >=1.2.1.1,+        stm >=2.5.0.2,+        text >=1.2.5.0,+        time >=1.11.1.1,+        wai >=3.2.3,+        wai-extra >=3.1.13.0,+        yesod >=1.6.2.1,+        yesod-core >=1.6.24.2,+        yesod-session-persist,+        yesod-test >=1.6.15