{-# 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 SessionCfg conn sess st
sessCfg 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 SessionCfg conn sess st
cfg 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 Key SessionId
vK SessionStoreInstance (Session conn sess st)
sessionRef SessionCfg conn sess st
cfg 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 Key SessionId
vK SessionCfg conn sess st
cfg 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 Key SessionId
vK SessionCfg conn sess st
cfg 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 Key SessionId
vK (SessionStoreInstance SessionStore (Session conn sess st) tx
sessionRef) SessionCfg conn sess st
cfg SessionIf m
sif 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
         Maybe SessionId
Nothing ->
             [Char] -> m a
forall a. HasCallStack => [Char] -> a
error [Char]
"(3) Internal Spock Session Error. Please report this bug!"
         Just 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 (Session conn sess st
sessionNew, 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 Key SessionId
vK SessionCfg conn sess st
cfg 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
         Maybe SessionId
Nothing ->
             [Char] -> m (Session conn sess st)
forall a. HasCallStack => [Char] -> a
error [Char]
"(1) Internal Spock Session Error. Please report this bug!"
         Just 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 Key SessionId
vK SessionCfg conn sess st
cfg 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 Key SessionId
vK SessionStoreInstance (Session conn sess st)
sessionRef SessionCfg conn sess st
cfg SessionIf m
sif 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 Key SessionId
vK SessionStoreInstance (Session conn sess st)
sessionRef SessionCfg conn sess st
cfg SessionIf m
sif sess -> (sess, a)
f =
    do let modFun :: Session conn sess st -> (Session conn sess st, a)
modFun Session conn sess st
session =
               let (sess
sessData', 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 SessionCfg conn sess st
cfg Session conn sess st
sess 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 SessionCfg conn sess st
cfg Key SessionId
vK SessionIf m
sif Maybe SessionId
mSid =
    do (Session conn sess st
sess, 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 SessionCfg conn sess st
cfg 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
         Maybe (Session conn sess st)
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 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 SessionCfg conn sess st
cfg Key SessionId
vK Application
app Request
req 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 Maybe SessionId
mSid =
          do (Session conn sess st
sess, 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 SessionId
name =
          HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"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 Session conn sess st
sess UTCTime
now [(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 = (HeaderName
"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 Bool
shouldSetCookie 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
$ \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 SessionCfg conn sess st
sessCfg (SessionStoreInstance SessionStore (Session conn sess st) tx
sessionRef) 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 SessionCfg conn sess st
sessCfg sessionRef :: SessionStoreInstance (Session conn sess st)
sessionRef@(SessionStoreInstance SessionStore (Session conn sess st) tx
store) 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 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
         Maybe (Session conn sess st)
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 SessionStore (Session conn sess st) tx
sessionRef) 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 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 SessionStore (Session conn sess st) tx
sessionRef) 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
$ \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 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 SessionStore (Session conn sess st) tx
store ->
       do UTCTime
now <- IO UTCTime
getCurrentTime
          ([Session conn sess st]
newStatus, [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 (\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 (\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 (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 SessionCfg conn sess st
sessCfg 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 Int
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 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) -> SessionId -> SessionId
forall a b. (a -> b) -> a -> b
$ SessionId -> SessionId -> SessionId -> SessionId
T.replace SessionId
"/" SessionId
"_" (SessionId -> SessionId) -> SessionId -> SessionId
forall a b. (a -> b) -> a -> b
$ SessionId -> SessionId -> SessionId -> SessionId
T.replace SessionId
"+" SessionId
"-" (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