yesod-session-persist 0.0.0.1 → 0.0.0.2

raw patch · 31 files changed

+580/−118 lines, 31 filesdep +generic-arbitrarydep +memcachePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: generic-arbitrary, memcache

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• README.md +4/−3
• internal/Internal/Prelude.hs +17/−2
• internal/Session/Timing/Math.hs +2/−1
• internal/Session/Timing/Timeout.hs +5/−1
• internal/Time.hs +6/−0
• internal/Yesod/Session/Embedding/Options.hs +2/−2
• internal/Yesod/Session/Freeze.hs +4/−2
• internal/Yesod/Session/KeyRotation.hs +4/−2
• internal/Yesod/Session/Manager.hs +3/−3
• internal/Yesod/Session/Manager/Load.hs +2/−2
• internal/Yesod/Session/Manager/Save.hs +2/−2
• internal/Yesod/Session/Memcache/Expiration.hs +62/−0
• internal/Yesod/Session/Memcache/Storage.hs +112/−0
• internal/Yesod/Session/Memcache/Yesod.hs +39/−0
• internal/Yesod/Session/Options.hs +1/−1
• internal/Yesod/Session/Persist/Storage.hs +3/−3
• internal/Yesod/Session/Persist/Yesod.hs +6/−53
• internal/Yesod/Session/Storage/Exceptions.hs +0/−6
• internal/Yesod/Session/Storage/Yesod.hs +57/−0
• library/Yesod/Session/Memcache.hs +69/−0
• library/Yesod/Session/Persist.hs +1/−17
• library/Yesod/Session/Storage.hs +74/−0
• package.yaml +4/−2
• tests/Test/Gen/Mock.hs +1/−1
• tests/Test/Mock.hs +3/−3
• tests/Test/MockStorage.hs +2/−4
• tests/Test/Prelude.hs +0/−1
• tests/Yesod/Session/Memcache/StorageSpec.hs +72/−0
• tests/Yesod/Session/Persist/YesodApp.hs +2/−3
• yesod-session-persist.cabal +14/−3

@@ -1,4 +1,10 @@-## [_Unreleased_](https://github.com/freckle/yesod-session-persist/compare/v0.0.0.1...main)+## [_Unreleased_](https://github.com/freckle/yesod-session-persist/compare/v0.0.0.2...main)++## [v0.0.0.2](https://github.com/freckle/yesod-session-persist/compare/v0.0.0.1...v0.0.0.2)++Add support for `memcache` as a data store.++Change return type of `getSessionEmbeddings` to 'Maybe SessionEmbeddings' (Breaking Change)  ## [v0.0.0.1](https://github.com/freckle/yesod-session-persist/compare/v0.0.0.0...v0.0.0.1) 

@@ -4,7 +4,7 @@ [![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.+stored in a backend data store.  ## Features @@ -54,8 +54,9 @@  ### 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.+Garbage collection is supported when using `memcache` as the data store. Please see 'Yesod.Session.Memcache.Storage.SessionPersistence'.++The `Yesod.Session.Persist` module _does not_ does not proactively seek out expired sessions for deletion. Thus, in the absence of some other intervention, your session table will grow without bound.  ## Prior art 

@@ -16,6 +16,7 @@   , join   , replicateM   , replicateM_+  , unless   , when   , (<=<)   , (=<<)@@ -51,7 +52,7 @@   , maybe   ) import Data.Ord as X (Ord (..))-import Data.Semigroup as X ((<>))+import Data.Semigroup as X (Min (..), (<>)) import Data.Sequence as X (Seq) import Data.Set as X (Set) import Data.String as X (String)@@ -59,22 +60,36 @@ import Data.Traversable as X (for) import Data.Tuple as X (fst, snd, swap) import Data.Type.Equality as X+import Data.Word as X (Word32)+import GHC.Generics as X (Generic) import GHC.Stack as X (HasCallStack) import Numeric.Natural as X (Natural) import System.IO as X (IO)+import Test.QuickCheck as X (Arbitrary (arbitrary, shrink))+import Test.QuickCheck.Arbitrary.Generic as X+  ( GenericArbitrary+  , genericArbitrary+  , genericShrink+  ) import Text.Read as X (Read, readMaybe) import Text.Show as X (Show, show) import Prelude as X-  ( Bounded+  ( Bounded (..)   , Enum   , Int+  , Integer   , Integral+  , Num+  , RealFrac (ceiling, floor)+  , fromInteger   , fromIntegral   , minimum   , negate   , pred   , succ+  , toInteger   , truncate+  , uncurry   , ($!)   , (*)   , (+)

@@ -12,7 +12,8 @@ -- | 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.+--  Returns 'Nothing' if and only if the settings do not specify any timeout+--  limits. nextExpires   :: Timeout NominalDiffTime   -> Time UTCTime

@@ -27,7 +27,11 @@   --   -- Setting to 'Nothing' removes the absolute timeout.   }-  deriving stock (Eq, Show)+  deriving stock (Eq, Show, Generic, Functor)++instance Arbitrary a => Arbitrary (Timeout a) where+  arbitrary = genericArbitrary+  shrink = genericShrink  -- | Default timeouts --

@@ -14,12 +14,18 @@   , UTCTime (..)   , addUTCTime   , diffUTCTime+  , getCurrentTime   , nominalDay   , nominalDiffTimeToSeconds   , secondsToDiffTime   , secondsToNominalDiffTime   ) import Data.Time.Calendar.OrdinalDate as X (fromOrdinalDate)+import Data.Time.Clock.POSIX as X+  ( POSIXTime+  , posixSecondsToUTCTime+  , utcTimeToPOSIXSeconds+  ) import Data.Time.Clock.System as X (systemEpochDay)  subtractUTCTime :: NominalDiffTime -> UTCTime -> UTCTime

@@ -19,7 +19,7 @@   }  class HasSessionEmbeddings a where-  getSessionEmbeddings :: a -> SessionEmbeddings+  getSessionEmbeddings :: a -> Maybe SessionEmbeddings  instance HasSessionEmbeddings SessionEmbeddings where-  getSessionEmbeddings = id+  getSessionEmbeddings x = pure x

@@ -22,8 +22,10 @@   --   request for session freezing and restore the default behavior   -> m () assignSessionFreeze f = do-  embedding <- getSessionEmbeddings <$> getYesod-  liftHandler $ embed embedding.freeze f+  mEmbedding <- getSessionEmbeddings <$> getYesod+  case mEmbedding of+    Nothing -> pure ()+    Just embedding -> liftHandler $ embed embedding.freeze f  disableSessionManagement   :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m)) => m ()

@@ -30,8 +30,10 @@   --   request for rotation and restore the default behavior   -> m () assignSessionKeyRotation kr = do-  embedding <- getSessionEmbeddings <$> getYesod-  liftHandler $ embed embedding.keyRotation kr+  mEmbedding <- getSessionEmbeddings <$> getYesod+  case mEmbedding of+    Nothing -> pure ()+    Just embedding -> liftHandler $ embed embedding.keyRotation kr  rotateSessionKey   :: (MonadHandler m, HasSessionEmbeddings (HandlerSite m)) => m ()

@@ -18,7 +18,7 @@   , storage :: forall a. StorageOperation a -> tx a   -- ^ The storage backend   , options :: Options tx m-  , runTransaction :: forall a. tx a -> m a+  , runDB :: forall a. tx a -> m a   }  sessionKeyAppearsReasonable :: SessionManager tx m -> SessionKey -> Bool@@ -31,5 +31,5 @@     >=> (\v -> guard (sessionKeyAppearsReasonable x v) $> v)  newSessionKey :: SessionManager tx m -> m SessionKey-newSessionKey SessionManager {keyManager, runTransaction} =-  runTransaction keyManager.new+newSessionKey SessionManager {keyManager, runDB} =+  runDB keyManager.new

@@ -37,12 +37,12 @@   maybe Map.empty (.map) load.got  loadSession :: Monad m => SessionManager tx m -> SessionKey -> m (Load Session)-loadSession SessionManager {options, storage, runTransaction} sessionKey = do+loadSession SessionManager {options, storage, runDB} sessionKey = do   now <- options.clock   got <-     runMaybeT $ do       session <--        MaybeT $ runTransaction $ storage $ GetSession sessionKey+        MaybeT $ runDB $ storage $ GetSession sessionKey       MaybeT $ pure $ guard $ not $ isExpired options.timing.timeout now session.time       pure session   pure Load {got, time = now}

@@ -35,8 +35,8 @@   -> Load Session   -> SessionMap   -> m (SaveResult Session)-saveSession SessionManager {options, storage, keyManager, runTransaction} load outputData =-  runTransaction+saveSession SessionManager {options, storage, keyManager, runDB} load outputData =+  runDB     $ case freeze of       Just FreezeSessionForCurrentRequest -> pure Frozen       Nothing ->

@@ -0,0 +1,62 @@+module Yesod.Session.Memcache.Expiration+  ( MemcacheExpiration (..)+  , noExpiration+  , fromUTC+  , maxTimestamp+  , minTimestamp+  ) where++import Internal.Prelude++import Data.Fixed (Pico)+import Database.Memcache.Types qualified as Memcache+import Time (UTCTime, nominalDiffTimeToSeconds, utcTimeToPOSIXSeconds)++newtype Exceptions = InvalidExpiration Pico+  deriving stock (Eq, Show)+  deriving anyclass (Exception)++data MemcacheExpiration+  = -- | Do not set expiration times; memache will only evict when the cache is full+    NoMemcacheExpiration+  | -- | Sessions will be stored in memcache with the same expiration time that we+    -- send to the HTTP client, the lesser of the idle and absolute timeouts.+    UseMemcacheExpiration++-- | Do not expire the session via Memcache's expiration mechanism.+--+--  Memcache will evict the session when the cache is full.+noExpiration :: Memcache.Expiration+noExpiration = 0++-- | Convert 'UTCTime' to 'Word32', with possibility of failure.+--+-- This function guards against UTCTime values that, converted to a timestamp,+-- would be too big or too small.+--+-- See 'maxTimestamp' and 'minTimestamp' for definitions of too 'big / small'.+fromUTC :: MonadThrow m => UTCTime -> m Word32+fromUTC utcTime = do+  when (tooLarge || tooSmall) $ throwWithCallStack $ InvalidExpiration seconds+  pure $ ceiling seconds+ where+  seconds = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds utcTime+  tooLarge = seconds > maxTimestamp+  tooSmall = seconds < minTimestamp++-- | Minimum value that will be interpreted as a timestamp by Memcache+--+-- Values lower than this are considered to be "number of seconds" in the future+-- to expire a key / value pair. This is /not/ the interpretation we want.+--+-- See: https://github.com/dterei/memcache-hs/blob/83957ee9c4983f87447b0e7476a9a9155474dc80/Database/Memcache/Client.hs#L49-L59+--+-- This value is ~1960.+minTimestamp :: Num a => a+minTimestamp = 2592000 + 1 -- Values lower than this++-- | Check to make sure we don't overflow.+--+-- 4_294_967_295 is ~2096+maxTimestamp :: Num a => a+maxTimestamp = fromIntegral $ maxBound @Word32

@@ -0,0 +1,112 @@+module Yesod.Session.Memcache.Storage+  ( memcacheStorage+  , SessionPersistence (..)+  , getMemcacheExpiration+  ) where++import Internal.Prelude++import Database.Memcache.Client qualified as Memcache+import Database.Memcache.Types qualified as Memcache+import Session.Key+import Session.Timing.Math (nextExpires)+import Session.Timing.Options (TimingOptions (timeout))+import Session.Timing.Time (Time (..))+import Session.Timing.Timeout (Timeout (..))+import Time (NominalDiffTime, UTCTime)+import Yesod.Core (SessionMap)+import Yesod.Session.Memcache.Expiration+  ( MemcacheExpiration (NoMemcacheExpiration, UseMemcacheExpiration)+  , fromUTC+  , noExpiration+  )+import Yesod.Session.Options (Options (timing))+import Yesod.Session.SessionType+import Yesod.Session.Storage.Exceptions+import Yesod.Session.Storage.Operation++-- | Mapping between 'Session' and Memcache representation.+data SessionPersistence = SessionPersistence+  { databaseKey :: SessionKey -> Memcache.Key+  , toDatabase :: (SessionMap, Time UTCTime) -> Memcache.Value+  , fromDatabase+      :: Memcache.Value+      -> Either SomeException (SessionMap, Time UTCTime)+  , client :: Memcache.Client+  , expiration :: MemcacheExpiration+  }++memcacheStorage+  :: forall m result+   . (MonadThrow m, MonadIO m)+  => SessionPersistence+  -> Options IO IO+  -> StorageOperation result+  -> m result+memcacheStorage sp opt = \case+  GetSession sessionKey -> do+    mValue <-+      liftIO $ fmap fstOf3 <$> Memcache.get sp.client (sp.databaseKey sessionKey)++    case mValue of+      Nothing -> pure Nothing+      Just value -> do+        (map, time) <- either throwM pure $ sp.fromDatabase value+        pure $ Just Session {key = sessionKey, map, time}+  DeleteSession sessionKey -> do+    void $ liftIO $ Memcache.delete sp.client (sp.databaseKey sessionKey) bypassCAS+  InsertSession session -> do+    let+      key = sp.databaseKey session.key+      value = sp.toDatabase (session.map, session.time)++    expiration <-+      getMemcacheExpiration sp.expiration opt.timing.timeout session.time++    mVersion <- liftIO $ Memcache.add sp.client key value defaultFlags expiration+    throwOnNothing SessionAlreadyExists mVersion+  ReplaceSession session -> do+    let key = sp.databaseKey session.key++    expiration <-+      getMemcacheExpiration sp.expiration opt.timing.timeout session.time++    mVersion <-+      liftIO+        $ Memcache.replace+          sp.client+          key+          (sp.toDatabase (session.map, session.time))+          defaultFlags+          expiration+          bypassCAS+    throwOnNothing SessionDoesNotExist mVersion+ where+  throwOnNothing exception maybeValue = maybe (throwWithCallStack exception) (const $ pure ()) maybeValue+  fstOf3 (a, _, _) = a++-- | Determine what 'Memcache.Expiration' value to use.+getMemcacheExpiration+  :: MonadThrow m+  => MemcacheExpiration+  -> Timeout NominalDiffTime+  -> Time UTCTime+  -> m Memcache.Expiration+getMemcacheExpiration UseMemcacheExpiration timeout time = maybe (pure noExpiration) fromUTC $ nextExpires timeout time+getMemcacheExpiration NoMemcacheExpiration _timeout _time = pure noExpiration++defaultFlags :: Memcache.Flags+defaultFlags = 0++-- | Do not do any CAS checking.+--+-- Logically, a 'Version' (a.k.a CAS) value is optional. However, this optionality is represented+-- by a 'Version' of /0/. This is documented in the Memcache docs for the /set/, /add/,+-- and /replace/ commands:+--+-- https://github.com/memcached/memcached/wiki/BinaryProtocolRevamped#set-add-replace+--+-- But it applies at the level of the binary protocol itself. The /0/ 'Version'+-- sentinel value means "do not do any CAS checking".+bypassCAS :: Memcache.Version+bypassCAS = 0

@@ -0,0 +1,39 @@+module Yesod.Session.Memcache.Yesod+  ( makeSessionBackend+  , SessionConfiguration (..)+  ) where++import Internal.Prelude++import Database.Memcache.Client qualified as Memcache+import Yesod.Core.Types (SessionBackend (..))+import Yesod.Session.Memcache.Storage+import Yesod.Session.Options+import Yesod.Session.Storage.Yesod+  ( SessionConfiguration' (..)+  , makeSessionBackend'+  )++data SessionConfiguration env = SessionConfiguration+  { persistence :: SessionPersistence+  -- ^ Mapping between 'Yesod.Session.Persist.Session' and Memcache+  --   representation+  , options :: Options IO IO+  -- ^ Various options that have defaults; see 'defaultOptions'+  }++-- | Use this to implement 'Yesod.Core.makeSessionBackend'.+makeSessionBackend+  :: SessionConfiguration Memcache.Client+  -> IO SessionBackend+makeSessionBackend configuration =+  case persistence of+    SessionPersistence {} ->+      makeSessionBackend'+        SessionConfiguration'+          { storage = memcacheStorage persistence options+          , options = options+          , runDB = id+          }+ where+  SessionConfiguration {persistence, options} = configuration

@@ -12,7 +12,7 @@ import Session.KeyRotation import Session.Timing.Options import Session.TransportSecurity-import Time+import Time (NominalDiffTime, UTCTime) import Yesod.Core (SessionMap) import Yesod.Session.Embedding.Map import Yesod.Session.Embedding.Options

@@ -34,7 +34,7 @@   { databaseKey :: SessionKey -> Key record   , toDatabase :: Session -> record   , fromDatabase :: record -> Session-  , runTransaction :: forall a. ReaderT backend IO a -> m a+  , runDB :: forall a. ReaderT backend IO a -> m a   }  persistentStorage@@ -51,9 +51,9 @@   InsertSession session ->     persistentStorage sp (GetSession session.key) >>= \case       Nothing -> void $ Persist.insert $ sp.toDatabase session-      Just old -> throwWithCallStack $ SessionAlreadyExists old session+      Just _ -> throwWithCallStack SessionAlreadyExists   ReplaceSession session ->     let key = sp.databaseKey session.key     in  Persist.get key >>= \case-          Nothing -> throwWithCallStack $ SessionDoesNotExist session+          Nothing -> throwWithCallStack SessionDoesNotExist           Just _old -> void $ Persist.replace key $ sp.toDatabase session

@@ -2,31 +2,17 @@   ( -- * 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+import Yesod.Session.Storage.Yesod+  ( SessionConfiguration' (..)+  , makeSessionBackend'+  )  data SessionConfiguration persistentBackend persistentRecord = SessionConfiguration   { persistence :: SessionPersistence persistentBackend persistentRecord IO@@ -47,43 +33,10 @@ makeSessionBackend configuration =   let SessionConfiguration {persistence, options} = configuration   in  case persistence of-        SessionPersistence {runTransaction} ->+        SessionPersistence {runDB} ->           makeSessionBackend'             SessionConfiguration'               { storage = persistentStorage persistence               , options = options-              , runTransaction+              , runDB               }--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}-          )-    }

@@ -4,19 +4,13 @@  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)

@@ -0,0 +1,57 @@+module Yesod.Session.Storage.Yesod+  ( -- * 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.Storage.Operation++data SessionConfiguration' session = forall tx.+  Monad tx =>+  SessionConfiguration'+  { storage :: forall a. StorageOperation a -> tx a+  , options :: Options tx IO+  , runDB :: 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, runDB}+  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}+          )+    }

@@ -0,0 +1,69 @@+module Yesod.Session.Memcache+  ( -- * Setup+    makeSessionBackend+  , SessionConfiguration (..)++    -- * Options+  , Options (..)+  , defaultOptions+  , hoistOptions++    -- * Timing+  , TimingOptions (..)+  , defaultTimingOptions+  , minutes++    -- * Timeout+  , Timeout (..)+  , defaultTimeout++    -- * Transport security+  , TransportSecurity (..)++    -- * Session data model+  , Session (..)+  , SessionKey (..)+  , Time (..)+  , sessionKeyToCookieValue++    -- * Randomization+  , Randomization (..)+  , defaultRandomization+  , deterministicallyRandom+  , DeterministicRandomization (..)++    -- * Storage+  , SessionPersistence (..)+  , StorageException (..)+  , MemcacheExpiration (..)++    -- * 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 Time+import Yesod.Session.Memcache.Expiration+import Yesod.Session.Memcache.Storage+import Yesod.Session.Memcache.Yesod+import Yesod.Session.Storage

@@ -59,22 +59,6 @@   , 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+import Yesod.Session.Storage

@@ -0,0 +1,74 @@+module Yesod.Session.Storage+  ( -- * Options+    Options (..)+  , defaultOptions+  , hoistOptions++    -- * Timing+  , TimingOptions (..)+  , defaultTimingOptions++    -- * Timeout+  , Timeout (..)+  , defaultTimeout++    -- * Transport security+  , TransportSecurity (..)++    -- * Session data model+  , Session (..)+  , SessionKey (..)+  , Time (..)+  , sessionKeyToCookieValue++    -- * Randomization+  , Randomization (..)+  , defaultRandomization+  , deterministicallyRandom+  , DeterministicRandomization (..)++    -- * Storage+  , 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.SessionType+import Yesod.Session.Storage.Exceptions

@@ -1,5 +1,5 @@ name: yesod-session-persist-version: 0.0.0.1+version: 0.0.0.2 maintainer: Freckle Education category: Web github: freckle/yesod-session-persist@@ -70,6 +70,7 @@       - crypton       - exceptions       - http-types+      - memcache       - mtl       - persistent       - text@@ -77,6 +78,8 @@       - transformers       - wai       - yesod-core+      - QuickCheck+      - generic-arbitrary  tests:   spec:@@ -94,7 +97,6 @@       - random       - stm       - text-      - time       - wai       - wai-extra       - yesod

@@ -10,7 +10,7 @@ import Internal.Prelude  import Test.Gen.General-import Test.QuickCheck (Arbitrary (arbitrary), Gen)+import Test.QuickCheck (Gen) import Test.QuickCheck.Gen qualified as Gen import Time import Yesod.Session.Persist

@@ -41,14 +41,14 @@   let options = opt defaultOptions {timing, clock, randomization}   keyManager <- makeSessionKeyManager <$> randomization   let sessionManager =-        SessionManager {keyManager, storage, options, runTransaction = atomically}+        SessionManager {keyManager, storage, options, runDB = 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+    SessionManager {storage, runDB} = sessionManager   in     offTheRecordIO mockStorage       $ do@@ -59,7 +59,7 @@                 , map = sessionInit.map                 , time = sessionInit.time                 }-        runTransaction $ storage $ InsertSession session+        runDB $ storage $ InsertSession session         pure session.key  advanceTime :: MonadIO m => NominalDiffTime -> Mock STM IO -> m ()

@@ -82,16 +82,14 @@       $ Map.alterF         ( maybe             (pure $ Just newSession)-            ( \existingSession ->-                throwWithCallStack SessionAlreadyExists {existingSession, newSession}-            )+            (const $ throwWithCallStack SessionAlreadyExists)         )         newSession.key   ReplaceSession newSession ->     modifyTVarSTM ref       $ Map.alterF         ( maybe-            (throwWithCallStack SessionDoesNotExist {newSession})+            (throwWithCallStack SessionDoesNotExist)             (const $ pure $ Just newSession)         )         newSession.key

@@ -2,7 +2,6 @@   ( 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

@@ -0,0 +1,72 @@+module Yesod.Session.Memcache.StorageSpec+  ( spec+  ) where++import Test.Prelude++import Session.Timing.Time (Time (..))+import Session.Timing.Timeout (Timeout (Timeout, absolute, idle), defaultTimeout)+import Time (UTCTime, posixSecondsToUTCTime)+import Yesod.Session.Memcache.Expiration (MemcacheExpiration (NoMemcacheExpiration, UseMemcacheExpiration), maxTimestamp, minTimestamp, noExpiration)+import Yesod.Session.Memcache.Storage (getMemcacheExpiration)++spec :: Spec+spec =+  describe "getMemcacheExpiration" $ do+    context "NoMemcacheExpiration" $ do+      it "is 'noExpiration'" $ do+        let time = Time unixEpoch unixEpoch+        getMemcacheExpiration NoMemcacheExpiration defaultTimeout time+          `shouldBe` Just noExpiration++    context "UseMemcacheExpiration" $ do+      let useMemcacheOption = UseMemcacheExpiration++      it "is 'noExpiration' when timeouts are not provided" $ do+        let+          time = Time unixEpoch unixEpoch+          timeout = Timeout {idle = Nothing, absolute = Nothing}+        getMemcacheExpiration useMemcacheOption timeout time+          `shouldBe` Just noExpiration++      describe "it does NOT catch failures from 'fromUTC'" $ do+        it "fails when 'fromUTC' fails on 'tooLarge'" $ do+          let+            time = Time unixEpoch unixEpoch+            tooBig = maxTimestamp + 1+            timeout = Timeout {idle = Nothing, absolute = (Just tooBig)}+          getMemcacheExpiration useMemcacheOption timeout time `shouldBe` Nothing++        it "fails when 'fromUTC' fails on 'tooSmall'" $ do+          let+            time = Time unixEpoch unixEpoch+            tooSmall = minTimestamp - 1+            timeout = Timeout {idle = Nothing, absolute = (Just tooSmall)}+          getMemcacheExpiration useMemcacheOption timeout time `shouldBe` Nothing++        it "accepts 'minTimestamp'" $ do+          let+            time = Time unixEpoch unixEpoch+            timeout = Timeout {idle = Nothing, absolute = (Just minTimestamp)}+          getMemcacheExpiration useMemcacheOption timeout time+            `shouldBe` Just minTimestamp++        it "accepts 'maxTimestamp'" $ do+          let+            time = Time unixEpoch unixEpoch+            timeout = Timeout {idle = Nothing, absolute = (Just maxTimestamp)}+          getMemcacheExpiration useMemcacheOption timeout time+            `shouldBe` Just maxTimestamp++        it "accepts something between 'minTimestamp' and 'maxTimestamp'" $ do+          let+            time = Time unixEpoch unixEpoch+            timeout = Timeout {idle = Nothing, absolute = (Just (maxTimestamp - 1))}+          getMemcacheExpiration useMemcacheOption timeout time+            `shouldBe` Just (maxTimestamp - 1)++-- The Unix Epoc: 1970-01-01 00:00:00 UTC+--+-- Makes time math easier to reason about.+unixEpoch :: UTCTime+unixEpoch = posixSecondsToUTCTime 0

@@ -11,7 +11,6 @@ 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@@ -31,7 +30,7 @@ import Yesod.Core (SessionMap) import Yesod.Session.Manager import Yesod.Session.Persist-import Yesod.Session.Persist.Yesod+import Yesod.Session.Storage.Yesod (makeSessionBackend'')  newApp :: TimingOptions NominalDiffTime -> IO App newApp timing = do@@ -73,7 +72,7 @@       SessionManager {options} = sessionManager       Options {embedding} = options     in-      embedding+      pure embedding  instance Yesod App where   makeSessionBackend App {mock} = do

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               yesod-session-persist-version:            0.0.0.1+version:            0.0.0.2 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -20,7 +20,11 @@     location: https://github.com/freckle/yesod-session-persist  library-    exposed-modules:    Yesod.Session.Persist+    exposed-modules:+        Yesod.Session.Memcache+        Yesod.Session.Persist+        Yesod.Session.Storage+     hs-source-dirs:     library     other-modules:      Paths_yesod_session_persist     autogen-modules:    Paths_yesod_session_persist@@ -71,6 +75,9 @@         Yesod.Session.Manager         Yesod.Session.Manager.Load         Yesod.Session.Manager.Save+        Yesod.Session.Memcache.Expiration+        Yesod.Session.Memcache.Storage+        Yesod.Session.Memcache.Yesod         Yesod.Session.Options         Yesod.Session.Persist.Storage         Yesod.Session.Persist.Yesod@@ -79,6 +86,7 @@         Yesod.Session.Storage.Exceptions         Yesod.Session.Storage.Operation         Yesod.Session.Storage.Save+        Yesod.Session.Storage.Yesod      hs-source-dirs:     internal     other-modules:      Paths_yesod_session_persist@@ -101,6 +109,7 @@         -fwrite-ide-info      build-depends:+        QuickCheck >=2.14.3,         annotated-exception >=0.2.0.0,         base >=4.16.4.0 && <5,         base64 >=0.4.2.4,@@ -109,7 +118,9 @@         cookie >=0.4.6,         crypton >=0.33,         exceptions >=0.10.4,+        generic-arbitrary >=1.0.1,         http-types >=0.12.3,+        memcache >=0.3.0.1,         mtl >=2.2.2,         persistent >=2.14.1.0,         text >=1.2.5.0,@@ -133,6 +144,7 @@         Test.Randomization         Yesod.Session.Manager.LoadSpec         Yesod.Session.Manager.SaveSpec+        Yesod.Session.Memcache.StorageSpec         Yesod.Session.Persist.YesodApp         Yesod.Session.Persist.YesodSpec         Paths_yesod_session_persist@@ -167,7 +179,6 @@         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,