module Yesod.Internal.Session
( encodeClientSession
, encodeClientSessionOld
, decodeClientSession
, decodeClientSessionOld
, clientSessionDateCacher
, ClientSessionDateCache(..)
, BackendSession
, SaveSession
, SaveSessionOld
, SessionBackend(..)
) where
import Yesod.Internal (Header(..))
import qualified Web.ClientSession as CS
import Data.Int (Int64)
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, pack, unpack)
import Control.Arrow (first)
import Control.Applicative ((<$>))
import qualified Data.ByteString.Char8 as S8
import qualified Data.IORef as I
import qualified Network.Wai as W
type BackendSession = [(Text, S8.ByteString)]
type SaveSession = BackendSession
-> UTCTime
-> IO [Header]
type SaveSessionOld = BackendSession
-> UTCTime
-> IO [Header]
newtype SessionBackend master = SessionBackend
{ sbLoadSession :: master
-> W.Request
-> UTCTime
-> IO (BackendSession, SaveSession)
}
encodeClientSession :: CS.Key
-> CS.IV
-> ClientSessionDateCache
-> ByteString
-> [(Text, ByteString)]
-> ByteString
encodeClientSession key iv date rhost session' =
CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
where expires = Right (csdcExpiresSerialized date)
decodeClientSession :: CS.Key
-> ClientSessionDateCache
-> ByteString
-> ByteString
-> 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'
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
deriving (Show, Read)
instance Serialize SessionCookie where
put (SessionCookie a b c) = do
either putTime putByteString a
put b
put (map (first unpack) c)
get = do
a <- getTime
b <- get
c <- map (first pack) <$> get
return $ SessionCookie (Left a) b c
data ClientSessionDateCache =
ClientSessionDateCache {
csdcNow :: !UTCTime
, csdcExpires :: !UTCTime
, csdcExpiresSerialized :: !ByteString
} deriving (Eq, Show)
clientSessionDateCacher ::
NominalDiffTime
-> 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
I.writeIORef ref =<< getUpdated
putTime :: Putter UTCTime
putTime (UTCTime d t) =
let d' = fromInteger $ toModifiedJulianDay d
t' = fromIntegral $ fromEnum (t / diffTimeScale)
in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
getTime :: Get UTCTime
getTime = do
val <- get
let (d, t) = val `divMod` posixDayLength_int64
d' = ModifiedJulianDay $! fromIntegral d
t' = fromIntegral t
d' `seq` t' `seq` return (UTCTime d' t')
posixDayLength_int64 :: Int64
posixDayLength_int64 = 86400
diffTimeScale :: DiffTime
diffTimeScale = 1e12
encodeClientSessionOld :: CS.Key
-> CS.IV
-> UTCTime
-> ByteString
-> [(Text, ByteString)]
-> ByteString
encodeClientSessionOld key iv expire rhost session' =
CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session'
decodeClientSessionOld :: CS.Key
-> UTCTime
-> ByteString
-> ByteString
-> Maybe [(Text, ByteString)]
decodeClientSessionOld key now rhost encrypted = do
decrypted <- CS.decrypt key encrypted
SessionCookie (Left expire) rhost' session' <-
either (const Nothing) Just $ decode decrypted
guard $ expire > now
guard $ rhost' == rhost
return session'