065e33a3d1
Benchmark on my computer (per call, includes runPut/runGet):
old putTime: 5658 ns +/- 224ns
new putTime: 821 ns +/- 24ns (7x faster)
old getTime: 7228 ns +/- 126ns
new getTime: 99 ns +/- 4ns (73x faster!!)
Besides, the old format used 25 raw bytes (33.3 bytes on the
base64 output), while the new one uses 8 bytes (10.6 bytes on the
base64 output).
91 lines
2.8 KiB
Haskell
91 lines
2.8 KiB
Haskell
module Yesod.Internal.Session
|
|
( encodeClientSession
|
|
, decodeClientSession
|
|
, BackendSession
|
|
, SaveSession
|
|
, 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.Monad (guard)
|
|
import Data.Text (Text, pack, unpack)
|
|
import Control.Arrow (first)
|
|
import Control.Applicative ((<$>))
|
|
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import qualified Network.Wai as W
|
|
|
|
type BackendSession = [(Text, S8.ByteString)]
|
|
|
|
type SaveSession = BackendSession -- ^ The session contents after running the handler
|
|
-> UTCTime -- ^ current time
|
|
-> IO [Header]
|
|
|
|
newtype SessionBackend master = SessionBackend
|
|
{ sbLoadSession :: master
|
|
-> W.Request
|
|
-> UTCTime
|
|
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
|
|
}
|
|
|
|
encodeClientSession :: CS.Key
|
|
-> CS.IV
|
|
-> UTCTime -- ^ expire time
|
|
-> ByteString -- ^ remote host
|
|
-> [(Text, ByteString)] -- ^ session
|
|
-> ByteString -- ^ cookie value
|
|
encodeClientSession key iv expire rhost session' =
|
|
CS.encrypt key iv $ encode $ SessionCookie expire rhost session'
|
|
|
|
decodeClientSession :: CS.Key
|
|
-> UTCTime -- ^ current time
|
|
-> ByteString -- ^ remote host field
|
|
-> ByteString -- ^ cookie value
|
|
-> Maybe [(Text, ByteString)]
|
|
decodeClientSession 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, ByteString)]
|
|
deriving (Show, Read)
|
|
instance Serialize SessionCookie where
|
|
put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c)
|
|
get = do
|
|
a <- getTime
|
|
b <- get
|
|
c <- map (first pack) <$> get
|
|
return $ SessionCookie a b c
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
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
|