57 lines
1.7 KiB
Haskell
57 lines
1.7 KiB
Haskell
module Yesod.Internal.Session
|
|
( encodeSession
|
|
, decodeSession
|
|
) where
|
|
|
|
import qualified Web.ClientSession as CS
|
|
import Data.Serialize
|
|
import Data.Time
|
|
import Data.ByteString (ByteString)
|
|
import Control.Monad (guard)
|
|
import Data.Text (Text, pack, unpack)
|
|
import Control.Arrow ((***))
|
|
|
|
encodeSession :: CS.Key
|
|
-> CS.IV
|
|
-> UTCTime -- ^ expire time
|
|
-> ByteString -- ^ remote host
|
|
-> [(Text, Text)] -- ^ session
|
|
-> ByteString -- ^ cookie value
|
|
encodeSession key iv expire rhost session' =
|
|
CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
|
|
|
|
decodeSession :: CS.Key
|
|
-> UTCTime -- ^ current time
|
|
-> ByteString -- ^ remote host field
|
|
-> ByteString -- ^ cookie value
|
|
-> Maybe [(Text, Text)]
|
|
decodeSession key now rhost encrypted = do
|
|
decrypted <- CS.decrypt key encrypted
|
|
SessionCookie expire rhost' session' <-
|
|
either (const Nothing) Just $ decode decrypted
|
|
guard $ expire > now
|
|
guard $ rhost' == rhost
|
|
return session'
|
|
|
|
data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]
|
|
deriving (Show, Read)
|
|
instance Serialize SessionCookie where
|
|
put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)
|
|
get = do
|
|
a <- getTime
|
|
b <- get
|
|
c <- map (pack *** pack) `fmap` get
|
|
return $ SessionCookie a b c
|
|
|
|
putTime :: Putter UTCTime
|
|
putTime t@(UTCTime d _) = do
|
|
put $ toModifiedJulianDay d
|
|
let ndt = diffUTCTime t $ UTCTime d 0
|
|
put $ toRational ndt
|
|
|
|
getTime :: Get UTCTime
|
|
getTime = do
|
|
d <- get
|
|
ndt <- get
|
|
return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
|