71 lines
2.4 KiB
Haskell
71 lines
2.4 KiB
Haskell
module Yesod.Internal.Session
|
|
( encodeClientSession
|
|
, decodeClientSession
|
|
, clientSessionDateCacher
|
|
, ClientSessionDateCache(..)
|
|
, BackendSession
|
|
, SaveSession
|
|
, SessionBackend(..)
|
|
) where
|
|
|
|
import qualified Web.ClientSession as CS
|
|
import Data.Serialize
|
|
import Data.Time
|
|
import Data.ByteString (ByteString)
|
|
import Control.Concurrent (forkIO, killThread, threadDelay)
|
|
import Control.Monad (forever, guard)
|
|
import Data.Text (Text)
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Time
|
|
import qualified Data.IORef as I
|
|
|
|
encodeClientSession :: CS.Key
|
|
-> CS.IV
|
|
-> ClientSessionDateCache -- ^ expire time
|
|
-> ByteString -- ^ remote host
|
|
-> [(Text, ByteString)] -- ^ session
|
|
-> ByteString -- ^ cookie value
|
|
encodeClientSession key iv date rhost session' =
|
|
CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
|
|
where expires = Right (csdcExpiresSerialized date)
|
|
|
|
decodeClientSession :: CS.Key
|
|
-> ClientSessionDateCache -- ^ current time
|
|
-> ByteString -- ^ remote host field
|
|
-> ByteString -- ^ cookie value
|
|
-> Maybe [(Text, ByteString)]
|
|
decodeClientSession key date rhost encrypted = do
|
|
decrypted <- CS.decrypt key encrypted
|
|
SessionCookie (Left expire) rhost' session' <-
|
|
either (const Nothing) Just $ decode decrypted
|
|
guard $ expire > csdcNow date
|
|
guard $ rhost' == rhost
|
|
return session'
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
-- Mostly copied from Kazu's date-cache, but with modifications
|
|
-- that better suit our needs.
|
|
--
|
|
-- The cached date is updated every 10s, we don't need second
|
|
-- resolution for session expiration times.
|
|
|
|
clientSessionDateCacher ::
|
|
NominalDiffTime -- ^ Inactive session valitity.
|
|
-> IO (IO ClientSessionDateCache, IO ())
|
|
clientSessionDateCacher validity = do
|
|
ref <- getUpdated >>= I.newIORef
|
|
tid <- forkIO $ forever (doUpdate ref)
|
|
return $! (I.readIORef ref, killThread tid)
|
|
where
|
|
getUpdated = do
|
|
now <- getCurrentTime
|
|
let expires = validity `addUTCTime` now
|
|
expiresS = runPut (putTime expires)
|
|
return $! ClientSessionDateCache now expires expiresS
|
|
doUpdate ref = do
|
|
threadDelay 10000000 -- 10s
|
|
I.writeIORef ref =<< getUpdated
|