module Web.ServerSession.Core.Internal
( SessionId(..)
, checkSessionId
, generateSessionId
, AuthId
, Session(..)
, SessionMap(..)
, IsSessionData(..)
, DecomposedSession(..)
, Storage(..)
, StorageException(..)
, State(..)
, createState
, setCookieName
, setAuthKey
, setIdleTimeout
, setAbsoluteTimeout
, setTimeoutResolution
, setPersistentCookies
, setHttpOnlyCookies
, setSecureCookies
, getCookieName
, getHttpOnlyCookies
, getSecureCookies
, loadSession
, checkExpired
, nextExpires
, cookieExpires
, saveSession
, SaveSessionToken(..)
, invalidateIfNeeded
, saveSessionOnDb
, forceInvalidateKey
, ForceInvalidate(..)
) where
import Control.Applicative as A
import Control.Monad (guard, when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Hashable (Hashable(..))
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Data.Time.Clock (NominalDiffTime, addUTCTime, diffUTCTime)
import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..))
import qualified Control.Exception as E
import qualified Crypto.Nonce as N
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
newtype SessionId sess = S { SessionId sess -> Text
unS :: Text }
deriving (SessionId sess -> SessionId sess -> Bool
(SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> Eq (SessionId sess)
forall sess. SessionId sess -> SessionId sess -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionId sess -> SessionId sess -> Bool
$c/= :: forall sess. SessionId sess -> SessionId sess -> Bool
== :: SessionId sess -> SessionId sess -> Bool
$c== :: forall sess. SessionId sess -> SessionId sess -> Bool
Eq, Eq (SessionId sess)
Eq (SessionId sess)
-> (SessionId sess -> SessionId sess -> Ordering)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> Bool)
-> (SessionId sess -> SessionId sess -> SessionId sess)
-> (SessionId sess -> SessionId sess -> SessionId sess)
-> Ord (SessionId sess)
SessionId sess -> SessionId sess -> Bool
SessionId sess -> SessionId sess -> Ordering
SessionId sess -> SessionId sess -> SessionId sess
forall sess. Eq (SessionId sess)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall sess. SessionId sess -> SessionId sess -> Bool
forall sess. SessionId sess -> SessionId sess -> Ordering
forall sess. SessionId sess -> SessionId sess -> SessionId sess
min :: SessionId sess -> SessionId sess -> SessionId sess
$cmin :: forall sess. SessionId sess -> SessionId sess -> SessionId sess
max :: SessionId sess -> SessionId sess -> SessionId sess
$cmax :: forall sess. SessionId sess -> SessionId sess -> SessionId sess
>= :: SessionId sess -> SessionId sess -> Bool
$c>= :: forall sess. SessionId sess -> SessionId sess -> Bool
> :: SessionId sess -> SessionId sess -> Bool
$c> :: forall sess. SessionId sess -> SessionId sess -> Bool
<= :: SessionId sess -> SessionId sess -> Bool
$c<= :: forall sess. SessionId sess -> SessionId sess -> Bool
< :: SessionId sess -> SessionId sess -> Bool
$c< :: forall sess. SessionId sess -> SessionId sess -> Bool
compare :: SessionId sess -> SessionId sess -> Ordering
$ccompare :: forall sess. SessionId sess -> SessionId sess -> Ordering
$cp1Ord :: forall sess. Eq (SessionId sess)
Ord, Int -> SessionId sess -> ShowS
[SessionId sess] -> ShowS
SessionId sess -> String
(Int -> SessionId sess -> ShowS)
-> (SessionId sess -> String)
-> ([SessionId sess] -> ShowS)
-> Show (SessionId sess)
forall sess. Int -> SessionId sess -> ShowS
forall sess. [SessionId sess] -> ShowS
forall sess. SessionId sess -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionId sess] -> ShowS
$cshowList :: forall sess. [SessionId sess] -> ShowS
show :: SessionId sess -> String
$cshow :: forall sess. SessionId sess -> String
showsPrec :: Int -> SessionId sess -> ShowS
$cshowsPrec :: forall sess. Int -> SessionId sess -> ShowS
Show, ReadPrec [SessionId sess]
ReadPrec (SessionId sess)
Int -> ReadS (SessionId sess)
ReadS [SessionId sess]
(Int -> ReadS (SessionId sess))
-> ReadS [SessionId sess]
-> ReadPrec (SessionId sess)
-> ReadPrec [SessionId sess]
-> Read (SessionId sess)
forall sess. ReadPrec [SessionId sess]
forall sess. ReadPrec (SessionId sess)
forall sess. Int -> ReadS (SessionId sess)
forall sess. ReadS [SessionId sess]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SessionId sess]
$creadListPrec :: forall sess. ReadPrec [SessionId sess]
readPrec :: ReadPrec (SessionId sess)
$creadPrec :: forall sess. ReadPrec (SessionId sess)
readList :: ReadS [SessionId sess]
$creadList :: forall sess. ReadS [SessionId sess]
readsPrec :: Int -> ReadS (SessionId sess)
$creadsPrec :: forall sess. Int -> ReadS (SessionId sess)
Read, Typeable)
instance PathPiece (SessionId sess) where
toPathPiece :: SessionId sess -> Text
toPathPiece = SessionId sess -> Text
forall sess. SessionId sess -> Text
unS
fromPathPiece :: Text -> Maybe (SessionId sess)
fromPathPiece = Text -> Maybe (SessionId sess)
forall sess. Text -> Maybe (SessionId sess)
checkSessionId
instance A.FromJSON (SessionId sess) where
parseJSON :: Value -> Parser (SessionId sess)
parseJSON = (Text -> SessionId sess) -> Parser Text -> Parser (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SessionId sess
forall sess. Text -> SessionId sess
S (Parser Text -> Parser (SessionId sess))
-> (Value -> Parser Text) -> Value -> Parser (SessionId sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
A.parseJSON
instance A.ToJSON (SessionId sess) where
toJSON :: SessionId sess -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Text -> Value)
-> (SessionId sess -> Text) -> SessionId sess -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
unS
instance Hashable (SessionId sess) where
hashWithSalt :: Int -> SessionId sess -> Int
hashWithSalt Int
s = Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Text -> Int) -> (SessionId sess -> Text) -> SessionId sess -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId sess -> Text
forall sess. SessionId sess -> Text
unS
checkSessionId :: Text -> Maybe (SessionId sess)
checkSessionId :: Text -> Maybe (SessionId sess)
checkSessionId Text
text = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Int
T.length Text
text Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
24)
let bs :: ByteString
bs = Text -> ByteString
TE.encodeUtf8 Text
text
ByteString
decoded <- (String -> Maybe ByteString)
-> (ByteString -> Maybe ByteString)
-> Either String ByteString
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> String -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Either String ByteString -> Maybe ByteString)
-> Either String ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
B64URL.decode ByteString
bs
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B8.length ByteString
decoded Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
18)
SessionId sess -> Maybe (SessionId sess)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionId sess -> Maybe (SessionId sess))
-> SessionId sess -> Maybe (SessionId sess)
forall a b. (a -> b) -> a -> b
$ Text -> SessionId sess
forall sess. Text -> SessionId sess
S Text
text
generateSessionId :: N.Generator -> IO (SessionId sess)
generateSessionId :: Generator -> IO (SessionId sess)
generateSessionId = (Text -> SessionId sess) -> IO Text -> IO (SessionId sess)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> SessionId sess
forall sess. Text -> SessionId sess
S (IO Text -> IO (SessionId sess))
-> (Generator -> IO Text) -> Generator -> IO (SessionId sess)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Generator -> IO Text
forall (m :: * -> *). MonadIO m => Generator -> m Text
N.nonce128urlT
type AuthId = ByteString
data Session sess =
Session
{ Session sess -> SessionId sess
sessionKey :: SessionId sess
, Session sess -> Maybe ByteString
sessionAuthId :: Maybe AuthId
, Session sess -> Decomposed sess
sessionData :: Decomposed sess
, Session sess -> UTCTime
sessionCreatedAt :: UTCTime
, Session sess -> UTCTime
sessionAccessedAt :: UTCTime
} deriving (Typeable)
deriving instance Eq (Decomposed sess) => Eq (Session sess)
deriving instance Ord (Decomposed sess) => Ord (Session sess)
deriving instance Show (Decomposed sess) => Show (Session sess)
newtype SessionMap =
SessionMap { SessionMap -> HashMap Text ByteString
unSessionMap :: HM.HashMap Text ByteString }
deriving (SessionMap -> SessionMap -> Bool
(SessionMap -> SessionMap -> Bool)
-> (SessionMap -> SessionMap -> Bool) -> Eq SessionMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SessionMap -> SessionMap -> Bool
$c/= :: SessionMap -> SessionMap -> Bool
== :: SessionMap -> SessionMap -> Bool
$c== :: SessionMap -> SessionMap -> Bool
Eq, Int -> SessionMap -> ShowS
[SessionMap] -> ShowS
SessionMap -> String
(Int -> SessionMap -> ShowS)
-> (SessionMap -> String)
-> ([SessionMap] -> ShowS)
-> Show SessionMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionMap] -> ShowS
$cshowList :: [SessionMap] -> ShowS
show :: SessionMap -> String
$cshow :: SessionMap -> String
showsPrec :: Int -> SessionMap -> ShowS
$cshowsPrec :: Int -> SessionMap -> ShowS
Show, ReadPrec [SessionMap]
ReadPrec SessionMap
Int -> ReadS SessionMap
ReadS [SessionMap]
(Int -> ReadS SessionMap)
-> ReadS [SessionMap]
-> ReadPrec SessionMap
-> ReadPrec [SessionMap]
-> Read SessionMap
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SessionMap]
$creadListPrec :: ReadPrec [SessionMap]
readPrec :: ReadPrec SessionMap
$creadPrec :: ReadPrec SessionMap
readList :: ReadS [SessionMap]
$creadList :: ReadS [SessionMap]
readsPrec :: Int -> ReadS SessionMap
$creadsPrec :: Int -> ReadS SessionMap
Read, Typeable)
class ( Show (Decomposed sess)
, Typeable (Decomposed sess)
, Typeable sess
) => IsSessionData sess where
type Decomposed sess :: *
emptySession :: sess
decomposeSession
:: Text
-> sess
-> DecomposedSession sess
recomposeSession
:: Text
-> Maybe AuthId
-> Decomposed sess
-> sess
isSameDecomposed :: proxy sess -> Decomposed sess -> Decomposed sess -> Bool
isDecomposedEmpty :: proxy sess -> Decomposed sess -> Bool
instance IsSessionData SessionMap where
type Decomposed SessionMap = SessionMap
emptySession :: SessionMap
emptySession = HashMap Text ByteString -> SessionMap
SessionMap HashMap Text ByteString
forall k v. HashMap k v
HM.empty
isSameDecomposed :: proxy SessionMap
-> Decomposed SessionMap -> Decomposed SessionMap -> Bool
isSameDecomposed proxy SessionMap
_ = Decomposed SessionMap -> Decomposed SessionMap -> Bool
forall a. Eq a => a -> a -> Bool
(==)
decomposeSession :: Text -> SessionMap -> DecomposedSession SessionMap
decomposeSession Text
authKey_ (SessionMap HashMap Text ByteString
sm1) =
let authId :: Maybe ByteString
authId = Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
authKey_ HashMap Text ByteString
sm1
force :: ForceInvalidate
force = ForceInvalidate
-> (ByteString -> ForceInvalidate)
-> Maybe ByteString
-> ForceInvalidate
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ForceInvalidate
DoNotForceInvalidate (String -> ForceInvalidate
forall a. Read a => String -> a
read (String -> ForceInvalidate)
-> (ByteString -> String) -> ByteString -> ForceInvalidate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B8.unpack) (Maybe ByteString -> ForceInvalidate)
-> Maybe ByteString -> ForceInvalidate
forall a b. (a -> b) -> a -> b
$
Text -> HashMap Text ByteString -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
forceInvalidateKey HashMap Text ByteString
sm1
sm2 :: HashMap Text ByteString
sm2 = Text -> HashMap Text ByteString -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
authKey_ (HashMap Text ByteString -> HashMap Text ByteString)
-> HashMap Text ByteString -> HashMap Text ByteString
forall a b. (a -> b) -> a -> b
$
Text -> HashMap Text ByteString -> HashMap Text ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete Text
forceInvalidateKey HashMap Text ByteString
sm1
in DecomposedSession :: forall sess.
Maybe ByteString
-> ForceInvalidate -> Decomposed sess -> DecomposedSession sess
DecomposedSession
{ dsAuthId :: Maybe ByteString
dsAuthId = Maybe ByteString
authId
, dsForceInvalidate :: ForceInvalidate
dsForceInvalidate = ForceInvalidate
force
, dsDecomposed :: Decomposed SessionMap
dsDecomposed = HashMap Text ByteString -> SessionMap
SessionMap HashMap Text ByteString
sm2 }
recomposeSession :: Text -> Maybe ByteString -> Decomposed SessionMap -> SessionMap
recomposeSession Text
authKey_ Maybe ByteString
mauthId (SessionMap sm) =
HashMap Text ByteString -> SessionMap
SessionMap (HashMap Text ByteString -> SessionMap)
-> HashMap Text ByteString -> SessionMap
forall a b. (a -> b) -> a -> b
$ (HashMap Text ByteString -> HashMap Text ByteString)
-> (ByteString
-> HashMap Text ByteString -> HashMap Text ByteString)
-> Maybe ByteString
-> HashMap Text ByteString
-> HashMap Text ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashMap Text ByteString -> HashMap Text ByteString
forall a. a -> a
id (Text
-> ByteString -> HashMap Text ByteString -> HashMap Text ByteString
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
authKey_) Maybe ByteString
mauthId HashMap Text ByteString
sm
isDecomposedEmpty :: proxy SessionMap -> Decomposed SessionMap -> Bool
isDecomposedEmpty proxy SessionMap
_ = HashMap Text ByteString -> Bool
forall k v. HashMap k v -> Bool
HM.null (HashMap Text ByteString -> Bool)
-> (SessionMap -> HashMap Text ByteString) -> SessionMap -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionMap -> HashMap Text ByteString
unSessionMap
data DecomposedSession sess =
DecomposedSession
{ DecomposedSession sess -> Maybe ByteString
dsAuthId :: !(Maybe ByteString)
, DecomposedSession sess -> ForceInvalidate
dsForceInvalidate :: !ForceInvalidate
, DecomposedSession sess -> Decomposed sess
dsDecomposed :: !(Decomposed sess)
} deriving (Typeable)
deriving instance Eq (Decomposed sess) => Eq (DecomposedSession sess)
deriving instance Ord (Decomposed sess) => Ord (DecomposedSession sess)
deriving instance Show (Decomposed sess) => Show (DecomposedSession sess)
class ( Typeable sto
, MonadIO (TransactionM sto)
, IsSessionData (SessionData sto)
) => Storage sto where
type SessionData sto :: *
type TransactionM sto :: * -> *
runTransactionM :: sto -> TransactionM sto a -> IO a
getSession
:: sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
deleteSession :: sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteAllSessionsOfAuthId :: sto -> AuthId -> TransactionM sto ()
insertSession :: sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession :: sto -> Session (SessionData sto) -> TransactionM sto ()
data StorageException sto =
SessionAlreadyExists
{ StorageException sto -> Session (SessionData sto)
seExistingSession :: Session (SessionData sto)
, StorageException sto -> Session (SessionData sto)
seNewSession :: Session (SessionData sto) }
| SessionDoesNotExist
{ seNewSession :: Session (SessionData sto) }
deriving (Typeable)
deriving instance Eq (Decomposed (SessionData sto)) => Eq (StorageException sto)
deriving instance Ord (Decomposed (SessionData sto)) => Ord (StorageException sto)
deriving instance Show (Decomposed (SessionData sto)) => Show (StorageException sto)
instance Storage sto => E.Exception (StorageException sto) where
data State sto =
State
{ State sto -> Generator
generator :: !N.Generator
, State sto -> sto
storage :: !sto
, State sto -> Text
cookieName :: !Text
, State sto -> Text
authKey :: !Text
, State sto -> Maybe NominalDiffTime
idleTimeout :: !(Maybe NominalDiffTime)
, State sto -> Maybe NominalDiffTime
absoluteTimeout :: !(Maybe NominalDiffTime)
, State sto -> Maybe NominalDiffTime
timeoutResolution :: !(Maybe NominalDiffTime)
, State sto -> Bool
persistentCookies :: !Bool
, State sto -> Bool
httpOnlyCookies :: !Bool
, State sto -> Bool
secureCookies :: !Bool
} deriving (Typeable)
createState :: MonadIO m => sto -> m (State sto)
createState :: sto -> m (State sto)
createState sto
sto = do
Generator
gen <- m Generator
forall (m :: * -> *). MonadIO m => m Generator
N.new
State sto -> m (State sto)
forall (m :: * -> *) a. Monad m => a -> m a
return State :: forall sto.
Generator
-> sto
-> Text
-> Text
-> Maybe NominalDiffTime
-> Maybe NominalDiffTime
-> Maybe NominalDiffTime
-> Bool
-> Bool
-> Bool
-> State sto
State
{ generator :: Generator
generator = Generator
gen
, storage :: sto
storage = sto
sto
, cookieName :: Text
cookieName = Text
"JSESSIONID"
, authKey :: Text
authKey = Text
"_ID"
, idleTimeout :: Maybe NominalDiffTime
idleTimeout = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
7
, absoluteTimeout :: Maybe NominalDiffTime
absoluteTimeout = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60
, timeoutResolution :: Maybe NominalDiffTime
timeoutResolution = NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime -> Maybe NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
10
, persistentCookies :: Bool
persistentCookies = Bool
True
, httpOnlyCookies :: Bool
httpOnlyCookies = Bool
True
, secureCookies :: Bool
secureCookies = Bool
False
}
setCookieName :: Text -> State sto -> State sto
setCookieName :: Text -> State sto -> State sto
setCookieName Text
val State sto
state = State sto
state { cookieName :: Text
cookieName = Text
val }
setAuthKey :: Text -> State sto -> State sto
setAuthKey :: Text -> State sto -> State sto
setAuthKey Text
val State sto
state = State sto
state { authKey :: Text
authKey = Text
val }
setIdleTimeout :: Maybe NominalDiffTime -> State sto -> State sto
setIdleTimeout :: Maybe NominalDiffTime -> State sto -> State sto
setIdleTimeout (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setIdleTimeout: Timeout should be positive."
setIdleTimeout Maybe NominalDiffTime
val State sto
state = State sto
state { idleTimeout :: Maybe NominalDiffTime
idleTimeout = Maybe NominalDiffTime
val }
setAbsoluteTimeout :: Maybe NominalDiffTime -> State sto -> State sto
setAbsoluteTimeout :: Maybe NominalDiffTime -> State sto -> State sto
setAbsoluteTimeout (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setAbsoluteTimeout: Timeout should be positive."
setAbsoluteTimeout Maybe NominalDiffTime
val State sto
state = State sto
state { absoluteTimeout :: Maybe NominalDiffTime
absoluteTimeout = Maybe NominalDiffTime
val }
setTimeoutResolution :: Maybe NominalDiffTime -> State sto -> State sto
setTimeoutResolution :: Maybe NominalDiffTime -> State sto -> State sto
setTimeoutResolution (Just NominalDiffTime
d) State sto
_ | NominalDiffTime
d NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0 = String -> State sto
forall a. HasCallStack => String -> a
error String
"serversession/setTimeoutResolution: Resolution should be positive."
setTimeoutResolution Maybe NominalDiffTime
val State sto
state = State sto
state { timeoutResolution :: Maybe NominalDiffTime
timeoutResolution = Maybe NominalDiffTime
val }
setPersistentCookies :: Bool -> State sto -> State sto
setPersistentCookies :: Bool -> State sto -> State sto
setPersistentCookies Bool
val State sto
state = State sto
state { persistentCookies :: Bool
persistentCookies = Bool
val }
setHttpOnlyCookies :: Bool -> State sto -> State sto
setHttpOnlyCookies :: Bool -> State sto -> State sto
setHttpOnlyCookies Bool
val State sto
state = State sto
state { httpOnlyCookies :: Bool
httpOnlyCookies = Bool
val }
setSecureCookies :: Bool -> State sto -> State sto
setSecureCookies :: Bool -> State sto -> State sto
setSecureCookies Bool
val State sto
state = State sto
state { secureCookies :: Bool
secureCookies = Bool
val }
getCookieName :: State sto -> Text
getCookieName :: State sto -> Text
getCookieName = State sto -> Text
forall sto. State sto -> Text
cookieName
getHttpOnlyCookies :: State sto -> Bool
getHttpOnlyCookies :: State sto -> Bool
getHttpOnlyCookies = State sto -> Bool
forall sto. State sto -> Bool
httpOnlyCookies
getSecureCookies :: State sto -> Bool
getSecureCookies :: State sto -> Bool
getSecureCookies = State sto -> Bool
forall sto. State sto -> Bool
secureCookies
loadSession
:: Storage sto
=> State sto
-> Maybe ByteString
-> IO (SessionData sto, SaveSessionToken sto)
loadSession :: State sto
-> Maybe ByteString -> IO (SessionData sto, SaveSessionToken sto)
loadSession State sto
state Maybe ByteString
mcookieVal = do
UTCTime
now <- IO UTCTime
getCurrentTime
let maybeInputId :: Maybe (SessionId (SessionData sto))
maybeInputId = Maybe ByteString
mcookieVal Maybe ByteString
-> (ByteString -> Maybe (SessionId (SessionData sto)))
-> Maybe (SessionId (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (SessionId (SessionData sto))
forall s. PathPiece s => Text -> Maybe s
fromPathPiece (Text -> Maybe (SessionId (SessionData sto)))
-> (ByteString -> Text)
-> ByteString
-> Maybe (SessionId (SessionData sto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8
get :: SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
get = sto
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall sto a. Storage sto => sto -> TransactionM sto a -> IO a
runTransactionM (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto))))
-> (SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto))))
-> SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
sto
-> SessionId (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
getSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
checkedGet :: SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
checkedGet = (Maybe (Session (SessionData sto))
-> Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Session (SessionData sto))
-> (Session (SessionData sto) -> Maybe (Session (SessionData sto)))
-> Maybe (Session (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UTCTime
-> State sto
-> Session (SessionData sto)
-> Maybe (Session (SessionData sto))
forall sto sess.
UTCTime -> State sto -> Session sess -> Maybe (Session sess)
checkExpired UTCTime
now State sto
state) (IO (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto))))
-> (SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto))))
-> SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
get
Maybe (Session (SessionData sto))
maybeInput <- IO (Maybe (Session (SessionData sto)))
-> (SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto))))
-> Maybe (SessionId (SessionData sto))
-> IO (Maybe (Session (SessionData sto)))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Session (SessionData sto))
-> IO (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session (SessionData sto))
forall a. Maybe a
Nothing) SessionId (SessionData sto)
-> IO (Maybe (Session (SessionData sto)))
checkedGet Maybe (SessionId (SessionData sto))
maybeInputId
let inputData :: SessionData sto
inputData =
SessionData sto
-> (Session (SessionData sto) -> SessionData sto)
-> Maybe (Session (SessionData sto))
-> SessionData sto
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
SessionData sto
forall sess. IsSessionData sess => sess
emptySession
(\Session (SessionData sto)
s -> Text
-> Maybe ByteString
-> Decomposed (SessionData sto)
-> SessionData sto
forall sess.
IsSessionData sess =>
Text -> Maybe ByteString -> Decomposed sess -> sess
recomposeSession (State sto -> Text
forall sto. State sto -> Text
authKey State sto
state) (Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId Session (SessionData sto)
s) (Session (SessionData sto) -> Decomposed (SessionData sto)
forall sess. Session sess -> Decomposed sess
sessionData Session (SessionData sto)
s))
Maybe (Session (SessionData sto))
maybeInput
(SessionData sto, SaveSessionToken sto)
-> IO (SessionData sto, SaveSessionToken sto)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionData sto
inputData, Maybe (Session (SessionData sto))
-> UTCTime -> SaveSessionToken sto
forall sto.
Maybe (Session (SessionData sto))
-> UTCTime -> SaveSessionToken sto
SaveSessionToken Maybe (Session (SessionData sto))
maybeInput UTCTime
now)
checkExpired :: UTCTime -> State sto -> Session sess -> Maybe (Session sess)
checkExpired :: UTCTime -> State sto -> Session sess -> Maybe (Session sess)
checkExpired UTCTime
now State sto
state Session sess
session =
let expired :: Bool
expired = Bool -> (UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
now) (State sto -> Session sess -> Maybe UTCTime
forall sto sess. State sto -> Session sess -> Maybe UTCTime
nextExpires State sto
state Session sess
session)
in Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
expired) Maybe () -> Maybe (Session sess) -> Maybe (Session sess)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session sess -> Maybe (Session sess)
forall (m :: * -> *) a. Monad m => a -> m a
return Session sess
session
nextExpires :: State sto -> Session sess -> Maybe UTCTime
nextExpires :: State sto -> Session sess -> Maybe UTCTime
nextExpires State {sto
Bool
Maybe NominalDiffTime
Text
Generator
secureCookies :: Bool
httpOnlyCookies :: Bool
persistentCookies :: Bool
timeoutResolution :: Maybe NominalDiffTime
absoluteTimeout :: Maybe NominalDiffTime
idleTimeout :: Maybe NominalDiffTime
authKey :: Text
cookieName :: Text
storage :: sto
generator :: Generator
secureCookies :: forall sto. State sto -> Bool
httpOnlyCookies :: forall sto. State sto -> Bool
persistentCookies :: forall sto. State sto -> Bool
timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
absoluteTimeout :: forall sto. State sto -> Maybe NominalDiffTime
idleTimeout :: forall sto. State sto -> Maybe NominalDiffTime
authKey :: forall sto. State sto -> Text
cookieName :: forall sto. State sto -> Text
storage :: forall sto. State sto -> sto
generator :: forall sto. State sto -> Generator
..} Session {Maybe ByteString
UTCTime
Decomposed sess
SessionId sess
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed sess
sessionAuthId :: Maybe ByteString
sessionKey :: SessionId sess
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe ByteString
sessionKey :: forall sess. Session sess -> SessionId sess
..} =
let viaIdle :: Maybe UTCTime
viaIdle = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
sessionAccessedAt (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
idleTimeout
viaAbsolute :: Maybe UTCTime
viaAbsolute = (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
sessionCreatedAt (NominalDiffTime -> UTCTime)
-> Maybe NominalDiffTime -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NominalDiffTime
absoluteTimeout
minimum' :: [a] -> Maybe a
minimum' [] = Maybe a
forall a. Maybe a
Nothing
minimum' [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [a]
xs
in [UTCTime] -> Maybe UTCTime
forall a. Ord a => [a] -> Maybe a
minimum' ([UTCTime] -> Maybe UTCTime) -> [UTCTime] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes [Maybe UTCTime
viaIdle, Maybe UTCTime
viaAbsolute]
cookieExpires :: State sto -> Session sess -> Maybe UTCTime
cookieExpires :: State sto -> Session sess -> Maybe UTCTime
cookieExpires State {sto
Bool
Maybe NominalDiffTime
Text
Generator
secureCookies :: Bool
httpOnlyCookies :: Bool
persistentCookies :: Bool
timeoutResolution :: Maybe NominalDiffTime
absoluteTimeout :: Maybe NominalDiffTime
idleTimeout :: Maybe NominalDiffTime
authKey :: Text
cookieName :: Text
storage :: sto
generator :: Generator
secureCookies :: forall sto. State sto -> Bool
httpOnlyCookies :: forall sto. State sto -> Bool
persistentCookies :: forall sto. State sto -> Bool
timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
absoluteTimeout :: forall sto. State sto -> Maybe NominalDiffTime
idleTimeout :: forall sto. State sto -> Maybe NominalDiffTime
authKey :: forall sto. State sto -> Text
cookieName :: forall sto. State sto -> Text
storage :: forall sto. State sto -> sto
generator :: forall sto. State sto -> Generator
..} Session sess
_ | Bool -> Bool
not Bool
persistentCookies = Maybe UTCTime
forall a. Maybe a
Nothing
cookieExpires State sto
state Session sess
session =
UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> UTCTime
forall a. a -> Maybe a -> a
fromMaybe UTCTime
tenYearsFromNow (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ State sto -> Session sess -> Maybe UTCTime
forall sto sess. State sto -> Session sess -> Maybe UTCTime
nextExpires State sto
state Session sess
session
where tenYearsFromNow :: UTCTime
tenYearsFromNow = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
3652) UTCTime
now
now :: UTCTime
now = Session sess -> UTCTime
forall sess. Session sess -> UTCTime
sessionAccessedAt Session sess
session
data SaveSessionToken sto =
SaveSessionToken (Maybe (Session (SessionData sto))) UTCTime
deriving (Typeable)
deriving instance Eq (Decomposed (SessionData sto)) => Eq (SaveSessionToken sto)
deriving instance Ord (Decomposed (SessionData sto)) => Ord (SaveSessionToken sto)
deriving instance Show (Decomposed (SessionData sto)) => Show (SaveSessionToken sto)
saveSession
:: Storage sto
=> State sto
-> SaveSessionToken sto
-> SessionData sto
-> IO (Maybe (Session (SessionData sto)))
saveSession :: State sto
-> SaveSessionToken sto
-> SessionData sto
-> IO (Maybe (Session (SessionData sto)))
saveSession State sto
state (SaveSessionToken Maybe (Session (SessionData sto))
maybeInput UTCTime
now) SessionData sto
outputData =
sto
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall sto a. Storage sto => sto -> TransactionM sto a -> IO a
runTransactionM (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto))))
-> TransactionM sto (Maybe (Session (SessionData sto)))
-> IO (Maybe (Session (SessionData sto)))
forall a b. (a -> b) -> a -> b
$ do
let outputDecomp :: DecomposedSession (SessionData sto)
outputDecomp = Text -> SessionData sto -> DecomposedSession (SessionData sto)
forall sess.
IsSessionData sess =>
Text -> sess -> DecomposedSession sess
decomposeSession (State sto -> Text
forall sto. State sto -> Text
authKey State sto
state) SessionData sto
outputData
Maybe (Session (SessionData sto))
newMaybeInput <- State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
invalidateIfNeeded State sto
state Maybe (Session (SessionData sto))
maybeInput DecomposedSession (SessionData sto)
outputDecomp
State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall sto.
Storage sto =>
State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
saveSessionOnDb State sto
state UTCTime
now Maybe (Session (SessionData sto))
newMaybeInput DecomposedSession (SessionData sto)
outputDecomp
invalidateIfNeeded
:: Storage sto
=> State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
invalidateIfNeeded :: State sto
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
invalidateIfNeeded State sto
state Maybe (Session (SessionData sto))
maybeInput DecomposedSession {Maybe ByteString
ForceInvalidate
Decomposed (SessionData sto)
dsDecomposed :: Decomposed (SessionData sto)
dsForceInvalidate :: ForceInvalidate
dsAuthId :: Maybe ByteString
dsDecomposed :: forall sess. DecomposedSession sess -> Decomposed sess
dsForceInvalidate :: forall sess. DecomposedSession sess -> ForceInvalidate
dsAuthId :: forall sess. DecomposedSession sess -> Maybe ByteString
..} = do
let inputAuthId :: Maybe ByteString
inputAuthId = Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId (Session (SessionData sto) -> Maybe ByteString)
-> Maybe (Session (SessionData sto)) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Session (SessionData sto))
maybeInput
invalidateCurrent :: Bool
invalidateCurrent = ForceInvalidate
dsForceInvalidate ForceInvalidate -> ForceInvalidate -> Bool
forall a. Eq a => a -> a -> Bool
/= ForceInvalidate
DoNotForceInvalidate Bool -> Bool -> Bool
|| Maybe ByteString
inputAuthId Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ByteString
dsAuthId
invalidateOthers :: Bool
invalidateOthers = ForceInvalidate
dsForceInvalidate ForceInvalidate -> ForceInvalidate -> Bool
forall a. Eq a => a -> a -> Bool
== ForceInvalidate
AllSessionIdsOfLoggedUser Bool -> Bool -> Bool
&& Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
dsAuthId
whenMaybe :: Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
b Maybe a
m a -> f ()
f = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> f ()
f Maybe a
m
Bool
-> Maybe (Session (SessionData sto))
-> (Session (SessionData sto) -> TransactionM sto ())
-> TransactionM sto ()
forall (f :: * -> *) a.
Monad f =>
Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
invalidateCurrent Maybe (Session (SessionData sto))
maybeInput ((Session (SessionData sto) -> TransactionM sto ())
-> TransactionM sto ())
-> (Session (SessionData sto) -> TransactionM sto ())
-> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ sto -> SessionId (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> SessionId (SessionData sto) -> TransactionM sto ()
deleteSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state) (SessionId (SessionData sto) -> TransactionM sto ())
-> (Session (SessionData sto) -> SessionId (SessionData sto))
-> Session (SessionData sto)
-> TransactionM sto ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Session (SessionData sto) -> SessionId (SessionData sto)
forall sess. Session sess -> SessionId sess
sessionKey
Bool
-> Maybe ByteString
-> (ByteString -> TransactionM sto ())
-> TransactionM sto ()
forall (f :: * -> *) a.
Monad f =>
Bool -> Maybe a -> (a -> f ()) -> f ()
whenMaybe Bool
invalidateOthers Maybe ByteString
dsAuthId ((ByteString -> TransactionM sto ()) -> TransactionM sto ())
-> (ByteString -> TransactionM sto ()) -> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ sto -> ByteString -> TransactionM sto ()
forall sto. Storage sto => sto -> ByteString -> TransactionM sto ()
deleteAllSessionsOfAuthId (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto))))
-> Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not Bool
invalidateCurrent) Maybe ()
-> Maybe (Session (SessionData sto))
-> Maybe (Session (SessionData sto))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Session (SessionData sto))
maybeInput
saveSessionOnDb
:: forall sto. Storage sto
=> State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
saveSessionOnDb :: State sto
-> UTCTime
-> Maybe (Session (SessionData sto))
-> DecomposedSession (SessionData sto)
-> TransactionM sto (Maybe (Session (SessionData sto)))
saveSessionOnDb State sto
_ UTCTime
_ Maybe (Session (SessionData sto))
Nothing (DecomposedSession Maybe ByteString
Nothing ForceInvalidate
_ Decomposed (SessionData sto)
m)
| Maybe (SessionData sto) -> Decomposed (SessionData sto) -> Bool
forall sess (proxy :: * -> *).
IsSessionData sess =>
proxy sess -> Decomposed sess -> Bool
isDecomposedEmpty Maybe (SessionData sto)
proxy Decomposed (SessionData sto)
m = Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Session (SessionData sto))
forall a. Maybe a
Nothing
where
proxy :: Maybe (SessionData sto)
proxy :: Maybe (SessionData sto)
proxy = Maybe (SessionData sto)
forall a. Maybe a
Nothing
saveSessionOnDb State { timeoutResolution :: forall sto. State sto -> Maybe NominalDiffTime
timeoutResolution = Just NominalDiffTime
res } UTCTime
now (Just Session (SessionData sto)
old) (DecomposedSession Maybe ByteString
authId ForceInvalidate
_ Decomposed (SessionData sto)
newSession)
| Session (SessionData sto) -> Maybe ByteString
forall sess. Session sess -> Maybe ByteString
sessionAuthId Session (SessionData sto)
old Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
authId Bool -> Bool -> Bool
&&
Maybe (SessionData sto)
-> Decomposed (SessionData sto)
-> Decomposed (SessionData sto)
-> Bool
forall sess (proxy :: * -> *).
IsSessionData sess =>
proxy sess -> Decomposed sess -> Decomposed sess -> Bool
isSameDecomposed Maybe (SessionData sto)
proxy (Session (SessionData sto) -> Decomposed (SessionData sto)
forall sess. Session sess -> Decomposed sess
sessionData Session (SessionData sto)
old) Decomposed (SessionData sto)
newSession Bool -> Bool -> Bool
&&
NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now (Session (SessionData sto) -> UTCTime
forall sess. Session sess -> UTCTime
sessionAccessedAt Session (SessionData sto)
old)) NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
res =
Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Session (SessionData sto) -> Maybe (Session (SessionData sto))
forall a. a -> Maybe a
Just Session (SessionData sto)
old)
where
proxy :: Maybe (SessionData sto)
proxy :: Maybe (SessionData sto)
proxy = Maybe (SessionData sto)
forall a. Maybe a
Nothing
saveSessionOnDb State sto
state UTCTime
now Maybe (Session (SessionData sto))
maybeInput DecomposedSession {Maybe ByteString
ForceInvalidate
Decomposed (SessionData sto)
dsDecomposed :: Decomposed (SessionData sto)
dsForceInvalidate :: ForceInvalidate
dsAuthId :: Maybe ByteString
dsDecomposed :: forall sess. DecomposedSession sess -> Decomposed sess
dsForceInvalidate :: forall sess. DecomposedSession sess -> ForceInvalidate
dsAuthId :: forall sess. DecomposedSession sess -> Maybe ByteString
..} = do
(Session (SessionData sto) -> TransactionM sto ()
saveToDb, SessionId (SessionData sto)
key, UTCTime
createdAt) <-
case Maybe (Session (SessionData sto))
maybeInput of
Maybe (Session (SessionData sto))
Nothing -> IO
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
-> TransactionM
sto
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
-> TransactionM
sto
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
-> IO
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
-> TransactionM
sto
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
forall a b. (a -> b) -> a -> b
$
(,,) ((Session (SessionData sto) -> TransactionM sto ())
-> SessionId (SessionData sto)
-> UTCTime
-> (Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
-> IO (Session (SessionData sto) -> TransactionM sto ())
-> IO
(SessionId (SessionData sto)
-> UTCTime
-> (Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> (Session (SessionData sto) -> TransactionM sto ())
-> IO (Session (SessionData sto) -> TransactionM sto ())
forall (m :: * -> *) a. Monad m => a -> m a
return (sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
insertSession (sto -> Session (SessionData sto) -> TransactionM sto ())
-> sto -> Session (SessionData sto) -> TransactionM sto ()
forall a b. (a -> b) -> a -> b
$ State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
IO
(SessionId (SessionData sto)
-> UTCTime
-> (Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
-> IO (SessionId (SessionData sto))
-> IO
(UTCTime
-> (Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Generator -> IO (SessionId (SessionData sto))
forall sess. Generator -> IO (SessionId sess)
generateSessionId (State sto -> Generator
forall sto. State sto -> Generator
generator State sto
state)
IO
(UTCTime
-> (Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime))
-> IO UTCTime
-> IO
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
now
Just Session {Maybe ByteString
UTCTime
Decomposed (SessionData sto)
SessionId (SessionData sto)
sessionAccessedAt :: UTCTime
sessionCreatedAt :: UTCTime
sessionData :: Decomposed (SessionData sto)
sessionAuthId :: Maybe ByteString
sessionKey :: SessionId (SessionData sto)
sessionAccessedAt :: forall sess. Session sess -> UTCTime
sessionCreatedAt :: forall sess. Session sess -> UTCTime
sessionData :: forall sess. Session sess -> Decomposed sess
sessionAuthId :: forall sess. Session sess -> Maybe ByteString
sessionKey :: forall sess. Session sess -> SessionId sess
..} ->
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
-> TransactionM
sto
(Session (SessionData sto) -> TransactionM sto (),
SessionId (SessionData sto), UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return ( sto -> Session (SessionData sto) -> TransactionM sto ()
forall sto.
Storage sto =>
sto -> Session (SessionData sto) -> TransactionM sto ()
replaceSession (State sto -> sto
forall sto. State sto -> sto
storage State sto
state)
, SessionId (SessionData sto)
sessionKey
, UTCTime
sessionCreatedAt)
let session :: Session (SessionData sto)
session = Session :: forall sess.
SessionId sess
-> Maybe ByteString
-> Decomposed sess
-> UTCTime
-> UTCTime
-> Session sess
Session
{ sessionKey :: SessionId (SessionData sto)
sessionKey = SessionId (SessionData sto)
key
, sessionAuthId :: Maybe ByteString
sessionAuthId = Maybe ByteString
dsAuthId
, sessionData :: Decomposed (SessionData sto)
sessionData = Decomposed (SessionData sto)
dsDecomposed
, sessionCreatedAt :: UTCTime
sessionCreatedAt = UTCTime
createdAt
, sessionAccessedAt :: UTCTime
sessionAccessedAt = UTCTime
now
}
Session (SessionData sto) -> TransactionM sto ()
saveToDb Session (SessionData sto)
session
Maybe (Session (SessionData sto))
-> TransactionM sto (Maybe (Session (SessionData sto)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Session (SessionData sto) -> Maybe (Session (SessionData sto))
forall a. a -> Maybe a
Just Session (SessionData sto)
session)
forceInvalidateKey :: Text
forceInvalidateKey :: Text
forceInvalidateKey = Text
"serversession-force-invalidate"
data ForceInvalidate =
CurrentSessionId
| AllSessionIdsOfLoggedUser
| DoNotForceInvalidate
deriving (ForceInvalidate -> ForceInvalidate -> Bool
(ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> Eq ForceInvalidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForceInvalidate -> ForceInvalidate -> Bool
$c/= :: ForceInvalidate -> ForceInvalidate -> Bool
== :: ForceInvalidate -> ForceInvalidate -> Bool
$c== :: ForceInvalidate -> ForceInvalidate -> Bool
Eq, Eq ForceInvalidate
Eq ForceInvalidate
-> (ForceInvalidate -> ForceInvalidate -> Ordering)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> Bool)
-> (ForceInvalidate -> ForceInvalidate -> ForceInvalidate)
-> (ForceInvalidate -> ForceInvalidate -> ForceInvalidate)
-> Ord ForceInvalidate
ForceInvalidate -> ForceInvalidate -> Bool
ForceInvalidate -> ForceInvalidate -> Ordering
ForceInvalidate -> ForceInvalidate -> ForceInvalidate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
$cmin :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
max :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
$cmax :: ForceInvalidate -> ForceInvalidate -> ForceInvalidate
>= :: ForceInvalidate -> ForceInvalidate -> Bool
$c>= :: ForceInvalidate -> ForceInvalidate -> Bool
> :: ForceInvalidate -> ForceInvalidate -> Bool
$c> :: ForceInvalidate -> ForceInvalidate -> Bool
<= :: ForceInvalidate -> ForceInvalidate -> Bool
$c<= :: ForceInvalidate -> ForceInvalidate -> Bool
< :: ForceInvalidate -> ForceInvalidate -> Bool
$c< :: ForceInvalidate -> ForceInvalidate -> Bool
compare :: ForceInvalidate -> ForceInvalidate -> Ordering
$ccompare :: ForceInvalidate -> ForceInvalidate -> Ordering
$cp1Ord :: Eq ForceInvalidate
Ord, Int -> ForceInvalidate -> ShowS
[ForceInvalidate] -> ShowS
ForceInvalidate -> String
(Int -> ForceInvalidate -> ShowS)
-> (ForceInvalidate -> String)
-> ([ForceInvalidate] -> ShowS)
-> Show ForceInvalidate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ForceInvalidate] -> ShowS
$cshowList :: [ForceInvalidate] -> ShowS
show :: ForceInvalidate -> String
$cshow :: ForceInvalidate -> String
showsPrec :: Int -> ForceInvalidate -> ShowS
$cshowsPrec :: Int -> ForceInvalidate -> ShowS
Show, ReadPrec [ForceInvalidate]
ReadPrec ForceInvalidate
Int -> ReadS ForceInvalidate
ReadS [ForceInvalidate]
(Int -> ReadS ForceInvalidate)
-> ReadS [ForceInvalidate]
-> ReadPrec ForceInvalidate
-> ReadPrec [ForceInvalidate]
-> Read ForceInvalidate
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ForceInvalidate]
$creadListPrec :: ReadPrec [ForceInvalidate]
readPrec :: ReadPrec ForceInvalidate
$creadPrec :: ReadPrec ForceInvalidate
readList :: ReadS [ForceInvalidate]
$creadList :: ReadS [ForceInvalidate]
readsPrec :: Int -> ReadS ForceInvalidate
$creadsPrec :: Int -> ReadS ForceInvalidate
Read, ForceInvalidate
ForceInvalidate -> ForceInvalidate -> Bounded ForceInvalidate
forall a. a -> a -> Bounded a
maxBound :: ForceInvalidate
$cmaxBound :: ForceInvalidate
minBound :: ForceInvalidate
$cminBound :: ForceInvalidate
Bounded, Int -> ForceInvalidate
ForceInvalidate -> Int
ForceInvalidate -> [ForceInvalidate]
ForceInvalidate -> ForceInvalidate
ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
(ForceInvalidate -> ForceInvalidate)
-> (ForceInvalidate -> ForceInvalidate)
-> (Int -> ForceInvalidate)
-> (ForceInvalidate -> Int)
-> (ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> (ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate])
-> Enum ForceInvalidate
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromThenTo :: ForceInvalidate
-> ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFromTo :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromTo :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFromThen :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
$cenumFromThen :: ForceInvalidate -> ForceInvalidate -> [ForceInvalidate]
enumFrom :: ForceInvalidate -> [ForceInvalidate]
$cenumFrom :: ForceInvalidate -> [ForceInvalidate]
fromEnum :: ForceInvalidate -> Int
$cfromEnum :: ForceInvalidate -> Int
toEnum :: Int -> ForceInvalidate
$ctoEnum :: Int -> ForceInvalidate
pred :: ForceInvalidate -> ForceInvalidate
$cpred :: ForceInvalidate -> ForceInvalidate
succ :: ForceInvalidate -> ForceInvalidate
$csucc :: ForceInvalidate -> ForceInvalidate
Enum, Typeable)