{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Web.Spock.Internal.SessionManager
    ( createSessionManager, withSessionManager
    , SessionId, Session(..), SessionManager(..)
    , SessionIf(..)
    )
where

import Web.Spock.Core
import Web.Spock.Internal.Types
import Web.Spock.Internal.Util
import Web.Spock.Internal.Cookies

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Data.Time
import qualified Crypto.Random as CR
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.HashMap.Strict as HM
import qualified Data.Traversable as T
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vault.Lazy as V
import qualified Network.Wai as Wai

data SessionIf m
    = SessionIf
    { SessionIf m -> forall a. Key a -> m (Maybe a)
si_queryVault :: forall a. V.Key a -> m (Maybe a)
    , SessionIf m -> (Vault -> Vault) -> m ()
si_modifyVault :: (V.Vault -> V.Vault) -> m ()
    , SessionIf m -> MultiHeader -> ByteString -> m ()
si_setRawMultiHeader :: MultiHeader -> BS.ByteString -> m ()
    , SessionIf m -> IO (Key SessionId)
si_vaultKey :: IO (V.Key SessionId)
    }

withSessionManager ::
    MonadIO m => SessionCfg conn sess st -> SessionIf m -> (SessionManager m conn sess st -> IO a) -> IO a
withSessionManager :: SessionCfg conn sess st
-> SessionIf m -> (SessionManager m conn sess st -> IO a) -> IO a
withSessionManager sessCfg :: SessionCfg conn sess st
sessCfg sif :: SessionIf m
sif =
    IO (SessionManager m conn sess st)
-> (SessionManager m conn sess st -> IO ())
-> (SessionManager m conn sess st -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (SessionCfg conn sess st
-> SessionIf m -> IO (SessionManager m conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> SessionIf m -> IO (SessionManager m conn sess st)
createSessionManager SessionCfg conn sess st
sessCfg SessionIf m
sif) SessionManager m conn sess st -> IO ()
forall (m :: * -> *) conn sess st.
SessionManager m conn sess st -> IO ()
sm_closeSessionManager

createSessionManager ::
    MonadIO m => SessionCfg conn sess st -> SessionIf m -> IO (SessionManager m conn sess st)
createSessionManager :: SessionCfg conn sess st
-> SessionIf m -> IO (SessionManager m conn sess st)
createSessionManager cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Key SessionId
vaultKey <- SessionIf m -> IO (Key SessionId)
forall (m :: * -> *). SessionIf m -> IO (Key SessionId)
si_vaultKey SessionIf m
sif
       ThreadId
housekeepThread <- IO () -> IO ThreadId
forkIO (IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (SessionCfg conn sess st -> IO ()
forall conn sess st. SessionCfg conn sess st -> IO ()
housekeepSessions SessionCfg conn sess st
cfg))
       SessionManager m conn sess st -> IO (SessionManager m conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return
          SessionManager :: forall (m :: * -> *) conn sess st.
m SessionId
-> m SessionId
-> m ()
-> m sess
-> (sess -> m ())
-> (forall a. (sess -> (sess, a)) -> m a)
-> ((forall (n :: * -> *). Monad n => sess -> n sess) -> m ())
-> (MonadIO m => m ())
-> Middleware
-> IO ()
-> SessionManager m conn sess st
SessionManager
          { sm_getSessionId :: m SessionId
sm_getSessionId = Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
getSessionIdImpl Key SessionId
vaultKey SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_getCsrfToken :: m SessionId
sm_getCsrfToken = Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
getCsrfTokenImpl Key SessionId
vaultKey SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_regenerateSessionId :: m ()
sm_regenerateSessionId = Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> m ()
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> m ()
regenerateSessionIdImpl Key SessionId
vaultKey SessionStoreInstance (Session conn sess st)
store SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_readSession :: m sess
sm_readSession = Key SessionId -> SessionCfg conn sess st -> SessionIf m -> m sess
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId -> SessionCfg conn sess st -> SessionIf m -> m sess
readSessionImpl Key SessionId
vaultKey SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_writeSession :: sess -> m ()
sm_writeSession = Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> sess
-> m ()
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> sess
-> m ()
writeSessionImpl Key SessionId
vaultKey SessionStoreInstance (Session conn sess st)
store SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_modifySession :: forall a. (sess -> (sess, a)) -> m a
sm_modifySession = Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (sess -> (sess, a))
-> m a
forall (m :: * -> *) conn sess st a.
MonadIO m =>
Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (sess -> (sess, a))
-> m a
modifySessionImpl Key SessionId
vaultKey SessionStoreInstance (Session conn sess st)
store SessionCfg conn sess st
cfg SessionIf m
sif
          , sm_clearAllSessions :: MonadIO m => m ()
sm_clearAllSessions = SessionStoreInstance (Session conn sess st) -> m ()
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionStoreInstance (Session conn sess st) -> m ()
clearAllSessionsImpl SessionStoreInstance (Session conn sess st)
store
          , sm_mapSessions :: (forall (n :: * -> *). Monad n => sess -> n sess) -> m ()
sm_mapSessions = SessionStoreInstance (Session conn sess st)
-> (forall (n :: * -> *). Monad n => sess -> n sess) -> m ()
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionStoreInstance (Session conn sess st)
-> (forall (n :: * -> *). Monad n => sess -> n sess) -> m ()
mapAllSessionsImpl SessionStoreInstance (Session conn sess st)
store
          , sm_middleware :: Middleware
sm_middleware = SessionCfg conn sess st -> Key SessionId -> Middleware
forall conn sess st.
SessionCfg conn sess st -> Key SessionId -> Middleware
sessionMiddleware SessionCfg conn sess st
cfg Key SessionId
vaultKey
          , sm_closeSessionManager :: IO ()
sm_closeSessionManager = ThreadId -> IO ()
killThread ThreadId
housekeepThread
          }
    where
      store :: SessionStoreInstance (Session conn sess st)
store = SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
forall conn a st.
SessionCfg conn a st -> SessionStoreInstance (Session conn a st)
sc_store SessionCfg conn sess st
cfg

regenerateSessionIdImpl ::
    MonadIO m
    => V.Key SessionId
    -> SessionStoreInstance (Session conn sess st)
    -> SessionCfg conn sess st
    -> SessionIf m
    -> m ()
regenerateSessionIdImpl :: Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> m ()
regenerateSessionIdImpl vK :: Key SessionId
vK sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Session conn sess st
sess <- Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
readSessionBase Key SessionId
vK SessionCfg conn sess st
cfg SessionIf m
sif
       IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SessionStoreInstance (Session conn sess st) -> SessionId -> IO ()
forall conn sess st.
SessionStoreInstance (Session conn sess st) -> SessionId -> IO ()
deleteSessionImpl SessionStoreInstance (Session conn sess st)
sessionRef (Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
sess)
       Session conn sess st
newSession <- IO (Session conn sess st) -> m (Session conn sess st)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Session conn sess st) -> m (Session conn sess st))
-> IO (Session conn sess st) -> m (Session conn sess st)
forall a b. (a -> b) -> a -> b
$ SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> sess
-> IO (Session conn sess st)
forall conn sess st.
SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> sess
-> IO (Session conn sess st)
newSessionImpl SessionCfg conn sess st
cfg SessionStoreInstance (Session conn sess st)
sessionRef (Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
sess)
       UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
       SessionIf m -> MultiHeader -> ByteString -> m ()
forall (m :: * -> *).
SessionIf m -> MultiHeader -> ByteString -> m ()
si_setRawMultiHeader SessionIf m
sif MultiHeader
MultiHeaderSetCookie (SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
forall conn sess st.
SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
makeSessionIdCookie SessionCfg conn sess st
cfg Session conn sess st
newSession UTCTime
now)
       SessionIf m -> (Vault -> Vault) -> m ()
forall (m :: * -> *). SessionIf m -> (Vault -> Vault) -> m ()
si_modifyVault SessionIf m
sif ((Vault -> Vault) -> m ()) -> (Vault -> Vault) -> m ()
forall a b. (a -> b) -> a -> b
$ Key SessionId -> SessionId -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
V.insert Key SessionId
vK (Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
newSession)

getSessionIdImpl ::
    MonadIO m
    => V.Key SessionId
    -> SessionCfg conn sess st
    -> SessionIf m
    -> m SessionId
getSessionIdImpl :: Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
getSessionIdImpl vK :: Key SessionId
vK cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Session conn sess st
sess <- Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
readSessionBase Key SessionId
vK SessionCfg conn sess st
cfg SessionIf m
sif
       SessionId -> m SessionId
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId -> m SessionId) -> SessionId -> m SessionId
forall a b. (a -> b) -> a -> b
$ Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
sess

getCsrfTokenImpl ::
    ( MonadIO m )
    => V.Key SessionId
    -> SessionCfg conn sess st
    -> SessionIf m
    -> m T.Text
getCsrfTokenImpl :: Key SessionId
-> SessionCfg conn sess st -> SessionIf m -> m SessionId
getCsrfTokenImpl vK :: Key SessionId
vK cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Session conn sess st
sess <- Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
readSessionBase Key SessionId
vK SessionCfg conn sess st
cfg SessionIf m
sif
       SessionId -> m SessionId
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId -> m SessionId) -> SessionId -> m SessionId
forall a b. (a -> b) -> a -> b
$ Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_csrfToken Session conn sess st
sess

modifySessionBase ::
    MonadIO m
    => V.Key SessionId
    -> SessionStoreInstance (Session conn sess st)
    -> SessionCfg conn sess st
    -> SessionIf m
    -> (Session conn sess st -> (Session conn sess st, a))
    -> m a
modifySessionBase :: Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (Session conn sess st -> (Session conn sess st, a))
-> m a
modifySessionBase vK :: Key SessionId
vK (SessionStoreInstance sessionRef :: SessionStore (Session conn sess st) tx
sessionRef) cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif modFun :: Session conn sess st -> (Session conn sess st, a)
modFun =
    do Maybe SessionId
mValue <- SessionIf m -> Key SessionId -> m (Maybe SessionId)
forall (m :: * -> *). SessionIf m -> forall a. Key a -> m (Maybe a)
si_queryVault SessionIf m
sif Key SessionId
vK
       case Maybe SessionId
mValue of
         Nothing ->
             [Char] -> m a
forall a. HasCallStack => [Char] -> a
error "(3) Internal Spock Session Error. Please report this bug!"
         Just sid :: SessionId
sid ->
             do Session conn sess st
session <- SessionCfg conn sess st
-> Key SessionId
-> SessionIf m
-> Maybe SessionId
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> Key SessionId
-> SessionIf m
-> Maybe SessionId
-> m (Session conn sess st)
readOrNewSession SessionCfg conn sess st
cfg Key SessionId
vK SessionIf m
sif (SessionId -> Maybe SessionId
forall a. a -> Maybe a
Just SessionId
sid)
                let (sessionNew :: Session conn sess st
sessionNew, result :: a
result) = Session conn sess st -> (Session conn sess st, a)
modFun Session conn sess st
session
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
sessionRef (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> Session conn sess st -> tx ()
forall sess (tx :: * -> *). SessionStore sess tx -> sess -> tx ()
ss_storeSession SessionStore (Session conn sess st) tx
sessionRef Session conn sess st
sessionNew
                a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

readSessionBase ::
    MonadIO m
    => V.Key SessionId
    -> SessionCfg conn sess st
    -> SessionIf m
    -> m (Session conn sess st)
readSessionBase :: Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
readSessionBase vK :: Key SessionId
vK cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Maybe SessionId
mValue <- SessionIf m -> Key SessionId -> m (Maybe SessionId)
forall (m :: * -> *). SessionIf m -> forall a. Key a -> m (Maybe a)
si_queryVault SessionIf m
sif Key SessionId
vK
       case Maybe SessionId
mValue of
         Nothing ->
             [Char] -> m (Session conn sess st)
forall a. HasCallStack => [Char] -> a
error "(1) Internal Spock Session Error. Please report this bug!"
         Just sid :: SessionId
sid ->
             SessionCfg conn sess st
-> Key SessionId
-> SessionIf m
-> Maybe SessionId
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> Key SessionId
-> SessionIf m
-> Maybe SessionId
-> m (Session conn sess st)
readOrNewSession SessionCfg conn sess st
cfg Key SessionId
vK SessionIf m
sif (SessionId -> Maybe SessionId
forall a. a -> Maybe a
Just SessionId
sid)

readSessionImpl ::
    MonadIO m
    => V.Key SessionId
    -> SessionCfg conn sess st
    -> SessionIf m
    -> m sess
readSessionImpl :: Key SessionId -> SessionCfg conn sess st -> SessionIf m -> m sess
readSessionImpl vK :: Key SessionId
vK cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif =
    do Session conn sess st
base <- Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
forall (m :: * -> *) conn sess st.
MonadIO m =>
Key SessionId
-> SessionCfg conn sess st
-> SessionIf m
-> m (Session conn sess st)
readSessionBase Key SessionId
vK SessionCfg conn sess st
cfg SessionIf m
sif
       sess -> m sess
forall (m :: * -> *) a. Monad m => a -> m a
return (Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
base)

writeSessionImpl ::
    MonadIO m
    => V.Key SessionId
    -> SessionStoreInstance (Session conn sess st)
    -> SessionCfg conn sess st
    -> SessionIf m
    -> sess
    -> m ()
writeSessionImpl :: Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> sess
-> m ()
writeSessionImpl vK :: Key SessionId
vK sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif value :: sess
value =
    Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (sess -> (sess, ()))
-> m ()
forall (m :: * -> *) conn sess st a.
MonadIO m =>
Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (sess -> (sess, a))
-> m a
modifySessionImpl Key SessionId
vK SessionStoreInstance (Session conn sess st)
sessionRef SessionCfg conn sess st
cfg SessionIf m
sif ((sess, ()) -> sess -> (sess, ())
forall a b. a -> b -> a
const (sess
value, ()))

modifySessionImpl ::
    MonadIO m
    => V.Key SessionId
    -> SessionStoreInstance (Session conn sess st)
    -> SessionCfg conn sess st
    -> SessionIf m
    -> (sess -> (sess, a))
    -> m a
modifySessionImpl :: Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (sess -> (sess, a))
-> m a
modifySessionImpl vK :: Key SessionId
vK sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef cfg :: SessionCfg conn sess st
cfg sif :: SessionIf m
sif f :: sess -> (sess, a)
f =
    do let modFun :: Session conn sess st -> (Session conn sess st, a)
modFun session :: Session conn sess st
session =
               let (sessData' :: sess
sessData', out :: a
out) = sess -> (sess, a)
f (Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
session)
               in (Session conn sess st
session { sess_data :: sess
sess_data = sess
sessData' }, a
out)
       Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (Session conn sess st -> (Session conn sess st, a))
-> m a
forall (m :: * -> *) conn sess st a.
MonadIO m =>
Key SessionId
-> SessionStoreInstance (Session conn sess st)
-> SessionCfg conn sess st
-> SessionIf m
-> (Session conn sess st -> (Session conn sess st, a))
-> m a
modifySessionBase Key SessionId
vK SessionStoreInstance (Session conn sess st)
sessionRef SessionCfg conn sess st
cfg SessionIf m
sif Session conn sess st -> (Session conn sess st, a)
modFun

makeSessionIdCookie :: SessionCfg conn sess st -> Session conn sess st -> UTCTime -> BS.ByteString
makeSessionIdCookie :: SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
makeSessionIdCookie cfg :: SessionCfg conn sess st
cfg sess :: Session conn sess st
sess now :: UTCTime
now =
    SessionId -> SessionId -> CookieSettings -> UTCTime -> ByteString
generateCookieHeaderString SessionId
name SessionId
value CookieSettings
settings UTCTime
now
    where
      name :: SessionId
name = SessionCfg conn sess st -> SessionId
forall conn a st. SessionCfg conn a st -> SessionId
sc_cookieName SessionCfg conn sess st
cfg
      value :: SessionId
value = Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
sess
      settings :: CookieSettings
settings =
          CookieSettings
defaultCookieSettings
          { cs_EOL :: CookieEOL
cs_EOL = SessionCfg conn sess st -> CookieEOL
forall conn a st. SessionCfg conn a st -> CookieEOL
sc_cookieEOL SessionCfg conn sess st
cfg
          , cs_HTTPOnly :: Bool
cs_HTTPOnly = Bool
True
          }

readOrNewSession ::
    MonadIO m
    => SessionCfg conn sess st
    -> V.Key SessionId
    -> SessionIf m
    -> Maybe SessionId
    -> m (Session conn sess st)
readOrNewSession :: SessionCfg conn sess st
-> Key SessionId
-> SessionIf m
-> Maybe SessionId
-> m (Session conn sess st)
readOrNewSession cfg :: SessionCfg conn sess st
cfg vK :: Key SessionId
vK sif :: SessionIf m
sif mSid :: Maybe SessionId
mSid =
    do (sess :: Session conn sess st
sess, write :: Bool
write) <- SessionCfg conn sess st
-> Maybe SessionId -> m (Session conn sess st, Bool)
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> Maybe SessionId -> m (Session conn sess st, Bool)
loadOrSpanSession SessionCfg conn sess st
cfg Maybe SessionId
mSid
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
write (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
           do UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              SessionIf m -> MultiHeader -> ByteString -> m ()
forall (m :: * -> *).
SessionIf m -> MultiHeader -> ByteString -> m ()
si_setRawMultiHeader SessionIf m
sif MultiHeader
MultiHeaderSetCookie (SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
forall conn sess st.
SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
makeSessionIdCookie SessionCfg conn sess st
cfg Session conn sess st
sess UTCTime
now)
              SessionIf m -> (Vault -> Vault) -> m ()
forall (m :: * -> *). SessionIf m -> (Vault -> Vault) -> m ()
si_modifyVault SessionIf m
sif ((Vault -> Vault) -> m ()) -> (Vault -> Vault) -> m ()
forall a b. (a -> b) -> a -> b
$ Key SessionId -> SessionId -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
V.insert Key SessionId
vK (Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
sess)
       Session conn sess st -> m (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return Session conn sess st
sess

loadOrSpanSession ::
    MonadIO m
    => SessionCfg conn sess st
    -> Maybe SessionId
    -> m (Session conn sess st, Bool)
loadOrSpanSession :: SessionCfg conn sess st
-> Maybe SessionId -> m (Session conn sess st, Bool)
loadOrSpanSession cfg :: SessionCfg conn sess st
cfg mSid :: Maybe SessionId
mSid =
    do Maybe (Session conn sess st)
mSess <-
           IO (Maybe (Session conn sess st))
-> m (Maybe (Session conn sess st))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Session conn sess st))
 -> m (Maybe (Session conn sess st)))
-> IO (Maybe (Session conn sess st))
-> m (Maybe (Session conn sess st))
forall a b. (a -> b) -> a -> b
$
           Maybe (Maybe (Session conn sess st))
-> Maybe (Session conn sess st)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Session conn sess st))
 -> Maybe (Session conn sess st))
-> IO (Maybe (Maybe (Session conn sess st)))
-> IO (Maybe (Session conn sess st))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SessionId -> IO (Maybe (Session conn sess st)))
-> Maybe SessionId -> IO (Maybe (Maybe (Session conn sess st)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> SessionId
-> IO (Maybe (Session conn sess st))
forall conn sess st.
SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> SessionId
-> IO (Maybe (Session conn sess st))
loadSessionImpl SessionCfg conn sess st
cfg SessionStoreInstance (Session conn sess st)
sessionRef) Maybe SessionId
mSid
       case Maybe (Session conn sess st)
mSess of
         Nothing ->
             do Session conn sess st
newSess <-
                    IO (Session conn sess st) -> m (Session conn sess st)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Session conn sess st) -> m (Session conn sess st))
-> IO (Session conn sess st) -> m (Session conn sess st)
forall a b. (a -> b) -> a -> b
$
                    SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> sess
-> IO (Session conn sess st)
forall conn sess st.
SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> sess
-> IO (Session conn sess st)
newSessionImpl SessionCfg conn sess st
cfg SessionStoreInstance (Session conn sess st)
sessionRef (SessionCfg conn sess st -> sess
forall conn a st. SessionCfg conn a st -> a
sc_emptySession SessionCfg conn sess st
cfg)
                (Session conn sess st, Bool) -> m (Session conn sess st, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session conn sess st
newSess, Bool
True)
         Just s :: Session conn sess st
s -> (Session conn sess st, Bool) -> m (Session conn sess st, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session conn sess st
s, Bool
False)
    where
        sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef = SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
forall conn a st.
SessionCfg conn a st -> SessionStoreInstance (Session conn a st)
sc_store SessionCfg conn sess st
cfg

sessionMiddleware ::
    SessionCfg conn sess st
    -> V.Key SessionId
    -> Wai.Middleware
sessionMiddleware :: SessionCfg conn sess st -> Key SessionId -> Middleware
sessionMiddleware cfg :: SessionCfg conn sess st
cfg vK :: Key SessionId
vK app :: Application
app req :: Request
req respond :: Response -> IO ResponseReceived
respond =
    Maybe SessionId -> IO ResponseReceived
go (Maybe SessionId -> IO ResponseReceived)
-> Maybe SessionId -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ SessionId -> Maybe SessionId
getCookieFromReq (SessionCfg conn sess st -> SessionId
forall conn a st. SessionCfg conn a st -> SessionId
sc_cookieName SessionCfg conn sess st
cfg)
    where
      go :: Maybe SessionId -> IO ResponseReceived
go mSid :: Maybe SessionId
mSid =
          do (sess :: Session conn sess st
sess, shouldWriteCookie :: Bool
shouldWriteCookie) <- SessionCfg conn sess st
-> Maybe SessionId -> IO (Session conn sess st, Bool)
forall (m :: * -> *) conn sess st.
MonadIO m =>
SessionCfg conn sess st
-> Maybe SessionId -> m (Session conn sess st, Bool)
loadOrSpanSession SessionCfg conn sess st
cfg Maybe SessionId
mSid
             Bool -> Session conn sess st -> IO ResponseReceived
withSess Bool
shouldWriteCookie Session conn sess st
sess
      getCookieFromReq :: SessionId -> Maybe SessionId
getCookieFromReq name :: SessionId
name =
          HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "cookie" (Request -> [(HeaderName, ByteString)]
Wai.requestHeaders Request
req) Maybe ByteString
-> (ByteString -> Maybe SessionId) -> Maybe SessionId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SessionId -> [(SessionId, SessionId)] -> Maybe SessionId
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SessionId
name ([(SessionId, SessionId)] -> Maybe SessionId)
-> (ByteString -> [(SessionId, SessionId)])
-> ByteString
-> Maybe SessionId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(SessionId, SessionId)]
parseCookies
      v :: Vault
v = Request -> Vault
Wai.vault Request
req
      addCookie :: Session conn sess st
-> UTCTime
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
addCookie sess :: Session conn sess st
sess now :: UTCTime
now responseHeaders :: [(HeaderName, ByteString)]
responseHeaders =
          let cookieContent :: ByteString
cookieContent = SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
forall conn sess st.
SessionCfg conn sess st
-> Session conn sess st -> UTCTime -> ByteString
makeSessionIdCookie SessionCfg conn sess st
cfg Session conn sess st
sess UTCTime
now
              cookieC :: (HeaderName, ByteString)
cookieC = ("Set-Cookie", ByteString
cookieContent)
          in ((HeaderName, ByteString)
cookieC (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
responseHeaders)
      withSess :: Bool -> Session conn sess st -> IO ResponseReceived
withSess shouldSetCookie :: Bool
shouldSetCookie sess :: Session conn sess st
sess =
          Application
app (Request
req { vault :: Vault
Wai.vault = Key SessionId -> SessionId -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
V.insert Key SessionId
vK (Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
sess) Vault
v }) ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \unwrappedResp :: Response
unwrappedResp ->
              do UTCTime
now <- IO UTCTime
getCurrentTime
                 Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
                   if Bool
shouldSetCookie
                   then ([(HeaderName, ByteString)] -> [(HeaderName, ByteString)])
-> Response -> Response
mapReqHeaders (Session conn sess st
-> UTCTime
-> [(HeaderName, ByteString)]
-> [(HeaderName, ByteString)]
addCookie Session conn sess st
sess UTCTime
now) Response
unwrappedResp
                   else Response
unwrappedResp

newSessionImpl ::
    SessionCfg conn sess st
    -> SessionStoreInstance (Session conn sess st)
    -> sess
    -> IO (Session conn sess st)
newSessionImpl :: SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> sess
-> IO (Session conn sess st)
newSessionImpl sessCfg :: SessionCfg conn sess st
sessCfg (SessionStoreInstance sessionRef :: SessionStore (Session conn sess st) tx
sessionRef) content :: sess
content =
    do Session conn sess st
sess <- SessionCfg conn sess st -> sess -> IO (Session conn sess st)
forall conn sess st.
SessionCfg conn sess st -> sess -> IO (Session conn sess st)
createSession SessionCfg conn sess st
sessCfg sess
content
       SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
sessionRef (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> Session conn sess st -> tx ()
forall sess (tx :: * -> *). SessionStore sess tx -> sess -> tx ()
ss_storeSession SessionStore (Session conn sess st) tx
sessionRef Session conn sess st
sess
       Session conn sess st -> IO (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session conn sess st -> IO (Session conn sess st))
-> Session conn sess st -> IO (Session conn sess st)
forall a b. (a -> b) -> a -> b
$! Session conn sess st
sess

loadSessionImpl ::
    SessionCfg conn sess st
    -> SessionStoreInstance (Session conn sess st)
    -> SessionId
    -> IO (Maybe (Session conn sess st))
loadSessionImpl :: SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
-> SessionId
-> IO (Maybe (Session conn sess st))
loadSessionImpl sessCfg :: SessionCfg conn sess st
sessCfg sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef@(SessionStoreInstance store :: SessionStore (Session conn sess st) tx
store) sid :: SessionId
sid =
    do Maybe (Session conn sess st)
mSess <- SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
store (tx (Maybe (Session conn sess st))
 -> IO (Maybe (Session conn sess st)))
-> tx (Maybe (Session conn sess st))
-> IO (Maybe (Session conn sess st))
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> SessionId -> tx (Maybe (Session conn sess st))
forall sess (tx :: * -> *).
SessionStore sess tx -> SessionId -> tx (Maybe sess)
ss_loadSession SessionStore (Session conn sess st) tx
store SessionId
sid
       UTCTime
now <- IO UTCTime
getCurrentTime
       case Maybe (Session conn sess st)
mSess of
         Just sess :: Session conn sess st
sess ->
             do Session conn sess st
sessWithPossibleExpansion <-
                    if SessionCfg conn sess st -> Bool
forall conn a st. SessionCfg conn a st -> Bool
sc_sessionExpandTTL SessionCfg conn sess st
sessCfg
                    then do let expandedSession :: Session conn sess st
expandedSession =
                                    Session conn sess st
sess
                                    { sess_validUntil :: UTCTime
sess_validUntil =
                                          NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (SessionCfg conn sess st -> NominalDiffTime
forall conn a st. SessionCfg conn a st -> NominalDiffTime
sc_sessionTTL SessionCfg conn sess st
sessCfg) UTCTime
now
                                    }
                            SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
store (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> Session conn sess st -> tx ()
forall sess (tx :: * -> *). SessionStore sess tx -> sess -> tx ()
ss_storeSession SessionStore (Session conn sess st) tx
store Session conn sess st
expandedSession
                            Session conn sess st -> IO (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return Session conn sess st
expandedSession
                    else Session conn sess st -> IO (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return Session conn sess st
sess
                if Session conn sess st -> UTCTime
forall conn sess st. Session conn sess st -> UTCTime
sess_validUntil Session conn sess st
sessWithPossibleExpansion UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now
                then Maybe (Session conn sess st) -> IO (Maybe (Session conn sess st))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Session conn sess st) -> IO (Maybe (Session conn sess st)))
-> Maybe (Session conn sess st)
-> IO (Maybe (Session conn sess st))
forall a b. (a -> b) -> a -> b
$ Session conn sess st -> Maybe (Session conn sess st)
forall a. a -> Maybe a
Just Session conn sess st
sessWithPossibleExpansion
                else do SessionStoreInstance (Session conn sess st) -> SessionId -> IO ()
forall conn sess st.
SessionStoreInstance (Session conn sess st) -> SessionId -> IO ()
deleteSessionImpl SessionStoreInstance (Session conn sess st)
sessionRef SessionId
sid
                        Maybe (Session conn sess st) -> IO (Maybe (Session conn sess st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session conn sess st)
forall a. Maybe a
Nothing
         Nothing ->
             Maybe (Session conn sess st) -> IO (Maybe (Session conn sess st))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session conn sess st)
forall a. Maybe a
Nothing

deleteSessionImpl ::
    SessionStoreInstance (Session conn sess st)
    -> SessionId
    -> IO ()
deleteSessionImpl :: SessionStoreInstance (Session conn sess st) -> SessionId -> IO ()
deleteSessionImpl (SessionStoreInstance sessionRef :: SessionStore (Session conn sess st) tx
sessionRef) sid :: SessionId
sid =
    SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
sessionRef (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx -> SessionId -> tx ()
forall sess (tx :: * -> *).
SessionStore sess tx -> SessionId -> tx ()
ss_deleteSession SessionStore (Session conn sess st) tx
sessionRef SessionId
sid

clearAllSessionsImpl ::
    MonadIO m
    => SessionStoreInstance (Session conn sess st)
    -> m ()
clearAllSessionsImpl :: SessionStoreInstance (Session conn sess st) -> m ()
clearAllSessionsImpl (SessionStoreInstance sessionRef :: SessionStore (Session conn sess st) tx
sessionRef) =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
sessionRef (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> (Session conn sess st -> Bool) -> tx ()
forall sess (tx :: * -> *).
SessionStore sess tx -> (sess -> Bool) -> tx ()
ss_filterSessions SessionStore (Session conn sess st) tx
sessionRef (Bool -> Session conn sess st -> Bool
forall a b. a -> b -> a
const Bool
False)

mapAllSessionsImpl ::
    MonadIO m
    => SessionStoreInstance (Session conn sess st)
    -> (forall n. Monad n => sess -> n sess)
    -> m ()
mapAllSessionsImpl :: SessionStoreInstance (Session conn sess st)
-> (forall (n :: * -> *). Monad n => sess -> n sess) -> m ()
mapAllSessionsImpl (SessionStoreInstance sessionRef :: SessionStore (Session conn sess st) tx
sessionRef) f :: forall (n :: * -> *). Monad n => sess -> n sess
f =
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
sessionRef (tx () -> IO ()) -> tx () -> IO ()
forall a b. (a -> b) -> a -> b
$ SessionStore (Session conn sess st) tx
-> (Session conn sess st -> tx (Session conn sess st)) -> tx ()
forall sess (tx :: * -> *).
SessionStore sess tx -> (sess -> tx sess) -> tx ()
ss_mapSessions SessionStore (Session conn sess st) tx
sessionRef ((Session conn sess st -> tx (Session conn sess st)) -> tx ())
-> (Session conn sess st -> tx (Session conn sess st)) -> tx ()
forall a b. (a -> b) -> a -> b
$ \sess :: Session conn sess st
sess ->
        do sess
newData <- sess -> tx sess
forall (n :: * -> *). Monad n => sess -> n sess
f (Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data Session conn sess st
sess)
           Session conn sess st -> tx (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session conn sess st -> tx (Session conn sess st))
-> Session conn sess st -> tx (Session conn sess st)
forall a b. (a -> b) -> a -> b
$ Session conn sess st
sess { sess_data :: sess
sess_data = sess
newData }

housekeepSessions :: SessionCfg conn sess st -> IO ()
housekeepSessions :: SessionCfg conn sess st -> IO ()
housekeepSessions cfg :: SessionCfg conn sess st
cfg =
    case SessionCfg conn sess st
-> SessionStoreInstance (Session conn sess st)
forall conn a st.
SessionCfg conn a st -> SessionStoreInstance (Session conn a st)
sc_store SessionCfg conn sess st
cfg of
      SessionStoreInstance store :: SessionStore (Session conn sess st) tx
store ->
       do UTCTime
now <- IO UTCTime
getCurrentTime
          (newStatus :: [Session conn sess st]
newStatus, oldStatus :: [Session conn sess st]
oldStatus) <-
            SessionStore (Session conn sess st) tx -> forall a. tx a -> IO a
forall sess (tx :: * -> *).
SessionStore sess tx -> forall a. tx a -> IO a
ss_runTx SessionStore (Session conn sess st) tx
store (tx ([Session conn sess st], [Session conn sess st])
 -> IO ([Session conn sess st], [Session conn sess st]))
-> tx ([Session conn sess st], [Session conn sess st])
-> IO ([Session conn sess st], [Session conn sess st])
forall a b. (a -> b) -> a -> b
$
            do [Session conn sess st]
oldSt <- SessionStore (Session conn sess st) tx -> tx [Session conn sess st]
forall sess (tx :: * -> *). SessionStore sess tx -> tx [sess]
ss_toList SessionStore (Session conn sess st) tx
store
               SessionStore (Session conn sess st) tx
-> (Session conn sess st -> Bool) -> tx ()
forall sess (tx :: * -> *).
SessionStore sess tx -> (sess -> Bool) -> tx ()
ss_filterSessions SessionStore (Session conn sess st) tx
store (\sess :: Session conn sess st
sess -> Session conn sess st -> UTCTime
forall conn sess st. Session conn sess st -> UTCTime
sess_validUntil Session conn sess st
sess UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
now)
               (,) ([Session conn sess st]
 -> [Session conn sess st]
 -> ([Session conn sess st], [Session conn sess st]))
-> tx [Session conn sess st]
-> tx
     ([Session conn sess st]
      -> ([Session conn sess st], [Session conn sess st]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SessionStore (Session conn sess st) tx -> tx [Session conn sess st]
forall sess (tx :: * -> *). SessionStore sess tx -> tx [sess]
ss_toList SessionStore (Session conn sess st) tx
store tx
  ([Session conn sess st]
   -> ([Session conn sess st], [Session conn sess st]))
-> tx [Session conn sess st]
-> tx ([Session conn sess st], [Session conn sess st])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Session conn sess st] -> tx [Session conn sess st]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Session conn sess st]
oldSt
          let packSessionHm :: [Session conn sess st] -> HashMap SessionId (Session conn sess st)
packSessionHm = [(SessionId, Session conn sess st)]
-> HashMap SessionId (Session conn sess st)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(SessionId, Session conn sess st)]
 -> HashMap SessionId (Session conn sess st))
-> ([Session conn sess st] -> [(SessionId, Session conn sess st)])
-> [Session conn sess st]
-> HashMap SessionId (Session conn sess st)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Session conn sess st -> (SessionId, Session conn sess st))
-> [Session conn sess st] -> [(SessionId, Session conn sess st)]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: Session conn sess st
v -> (Session conn sess st -> SessionId
forall conn sess st. Session conn sess st -> SessionId
sess_id Session conn sess st
v, Session conn sess st
v))
              oldHm :: HashMap SessionId (Session conn sess st)
oldHm = [Session conn sess st] -> HashMap SessionId (Session conn sess st)
forall conn sess st.
[Session conn sess st] -> HashMap SessionId (Session conn sess st)
packSessionHm [Session conn sess st]
oldStatus
              newHm :: HashMap SessionId (Session conn sess st)
newHm = [Session conn sess st] -> HashMap SessionId (Session conn sess st)
forall conn sess st.
[Session conn sess st] -> HashMap SessionId (Session conn sess st)
packSessionHm [Session conn sess st]
newStatus
          SessionHooks sess -> HashMap SessionId sess -> IO ()
forall a. SessionHooks a -> HashMap SessionId a -> IO ()
sh_removed (SessionCfg conn sess st -> SessionHooks sess
forall conn a st. SessionCfg conn a st -> SessionHooks a
sc_hooks SessionCfg conn sess st
cfg) ((Session conn sess st -> sess)
-> HashMap SessionId (Session conn sess st)
-> HashMap SessionId sess
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.map Session conn sess st -> sess
forall conn sess st. Session conn sess st -> sess
sess_data (HashMap SessionId (Session conn sess st)
 -> HashMap SessionId sess)
-> HashMap SessionId (Session conn sess st)
-> HashMap SessionId sess
forall a b. (a -> b) -> a -> b
$ HashMap SessionId (Session conn sess st)
oldHm HashMap SessionId (Session conn sess st)
-> HashMap SessionId (Session conn sess st)
-> HashMap SessionId (Session conn sess st)
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HM.difference` HashMap SessionId (Session conn sess st)
newHm)
          Int -> IO ()
threadDelay (1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ SessionCfg conn sess st -> NominalDiffTime
forall conn a st. SessionCfg conn a st -> NominalDiffTime
sc_housekeepingInterval SessionCfg conn sess st
cfg))

createSession :: SessionCfg conn sess st -> sess -> IO (Session conn sess st)
createSession :: SessionCfg conn sess st -> sess -> IO (Session conn sess st)
createSession sessCfg :: SessionCfg conn sess st
sessCfg content :: sess
content =
    do SessionId
sid <- Int -> IO SessionId
randomHash (SessionCfg conn sess st -> Int
forall conn a st. SessionCfg conn a st -> Int
sc_sessionIdEntropy SessionCfg conn sess st
sessCfg)
       SessionId
csrfToken <- Int -> IO SessionId
randomHash 12
       UTCTime
now <- IO UTCTime
getCurrentTime
       let validUntil :: UTCTime
validUntil = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (SessionCfg conn sess st -> NominalDiffTime
forall conn a st. SessionCfg conn a st -> NominalDiffTime
sc_sessionTTL SessionCfg conn sess st
sessCfg) UTCTime
now
       Session conn sess st -> IO (Session conn sess st)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId -> SessionId -> UTCTime -> sess -> Session conn sess st
forall conn sess st.
SessionId -> SessionId -> UTCTime -> sess -> Session conn sess st
Session SessionId
sid SessionId
csrfToken UTCTime
validUntil sess
content)

randomHash :: Int -> IO T.Text
randomHash :: Int -> IO SessionId
randomHash len :: Int
len =
    do ByteString
by <- Int -> IO ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
CR.getRandomBytes Int
len
       SessionId -> IO SessionId
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId -> IO SessionId) -> SessionId -> IO SessionId
forall a b. (a -> b) -> a -> b
$ SessionId -> SessionId -> SessionId -> SessionId
T.replace "=" "" (SessionId -> SessionId) -> SessionId -> SessionId
forall a b. (a -> b) -> a -> b
$ SessionId -> SessionId -> SessionId -> SessionId
T.replace "/" "_" (SessionId -> SessionId) -> SessionId -> SessionId
forall a b. (a -> b) -> a -> b
$ SessionId -> SessionId -> SessionId -> SessionId
T.replace "+" "-" (SessionId -> SessionId) -> SessionId -> SessionId
forall a b. (a -> b) -> a -> b
$
              ByteString -> SessionId
T.decodeUtf8 (ByteString -> SessionId) -> ByteString -> SessionId
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode ByteString
by