module Yesod.Core.Internal.Session
( encodeClientSession
, decodeClientSession
, clientSessionDateCacher
, ClientSessionDateCache(..)
, SaveSession
, SessionBackend(..)
) where
import qualified Web.ClientSession as CS
import Data.Serialize
import Data.Time
import Data.ByteString (ByteString)
import Control.Monad (guard)
import Yesod.Core.Types
import Yesod.Core.Internal.Util
import Control.AutoUpdate
encodeClientSession :: CS.Key
-> CS.IV
-> ClientSessionDateCache
-> ByteString
-> SessionMap
-> ByteString
encodeClientSession :: Key
-> IV
-> ClientSessionDateCache
-> ByteString
-> SessionMap
-> ByteString
encodeClientSession Key
key IV
iv ClientSessionDateCache
date ByteString
rhost SessionMap
session' =
Key -> IV -> ByteString -> ByteString
CS.encrypt Key
key IV
iv (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SessionCookie -> ByteString
forall a. Serialize a => a -> ByteString
encode (SessionCookie -> ByteString) -> SessionCookie -> ByteString
forall a b. (a -> b) -> a -> b
$ Either UTCTime ByteString
-> ByteString -> SessionMap -> SessionCookie
SessionCookie Either UTCTime ByteString
forall {a}. Either a ByteString
expires ByteString
rhost SessionMap
session'
where expires :: Either a ByteString
expires = ByteString -> Either a ByteString
forall a b. b -> Either a b
Right (ClientSessionDateCache -> ByteString
csdcExpiresSerialized ClientSessionDateCache
date)
decodeClientSession :: CS.Key
-> ClientSessionDateCache
-> ByteString
-> ByteString
-> Maybe SessionMap
decodeClientSession :: Key
-> ClientSessionDateCache
-> ByteString
-> ByteString
-> Maybe SessionMap
decodeClientSession Key
key ClientSessionDateCache
date ByteString
rhost ByteString
encrypted = do
decrypted <- Key -> ByteString -> Maybe ByteString
CS.decrypt Key
key ByteString
encrypted
SessionCookie (Left expire) rhost' session' <-
either (const Nothing) Just $ decode decrypted
guard $ expire > csdcNow date
guard $ rhost' == rhost
return session'
clientSessionDateCacher ::
NominalDiffTime
-> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher :: NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher NominalDiffTime
validity = do
getClientSessionDateCache <- UpdateSettings ClientSessionDateCache
-> IO (IO ClientSessionDateCache)
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings
{ updateAction = getUpdated
, updateFreq = 10000000
}
return (getClientSessionDateCache, return ())
where
getUpdated :: IO ClientSessionDateCache
getUpdated = do
now <- IO UTCTime
getCurrentTime
let expires = NominalDiffTime
validity NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now
expiresS = Put -> ByteString
runPut (UTCTime -> Put
putTime UTCTime
expires)
return $! ClientSessionDateCache now expires expiresS