Merge branch 'faster-session' of https://github.com/meteficha/yesod
This commit is contained in:
Michael Snoyman
commit
f4674f9465
@ -70,7 +70,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Web.Cookie (parseCookies)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
@ -352,9 +351,7 @@ $doctype 5
|
||||
--
|
||||
-- Default: Uses clientsession with a 2 hour timeout.
|
||||
makeSessionBackend :: a -> IO (Maybe (SessionBackend a))
|
||||
makeSessionBackend _ = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
return $ Just $ clientSessionBackend key 120
|
||||
makeSessionBackend _ = fmap Just defaultClientSessionBackend
|
||||
|
||||
-- | How to store uploaded files.
|
||||
--
|
||||
@ -438,10 +435,9 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
[("Content-Type", "text/plain")]
|
||||
"Request body too large to be processed."
|
||||
| otherwise = do
|
||||
now <- liftIO getCurrentTime
|
||||
let dontSaveSession _ _ = return []
|
||||
let dontSaveSession _ = return []
|
||||
(session, saveSession) <- liftIO $
|
||||
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
|
||||
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb
|
||||
rr <- liftIO $ parseWaiRequest req session (isJust msb) len
|
||||
let h = {-# SCC "h" #-} do
|
||||
case murl of
|
||||
@ -471,7 +467,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
|
||||
newSess
|
||||
(\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
|
||||
(reqToken rr)
|
||||
sessionHeaders <- liftIO (saveSession nsToken now)
|
||||
sessionHeaders <- liftIO (saveSession nsToken)
|
||||
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
|
||||
_ -> return []
|
||||
return $ yarToResponse yar extraHeaders
|
||||
@ -760,47 +756,49 @@ resolveApproot master req =
|
||||
defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)
|
||||
defaultClientSessionBackend = do
|
||||
key <- CS.getKey CS.defaultKeyFile
|
||||
let timeout = 120 -- 120 minutes
|
||||
return $ clientSessionBackend key timeout
|
||||
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
|
||||
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
|
||||
return $ clientSessionBackend key getCachedDate
|
||||
|
||||
clientSessionBackend :: Yesod master
|
||||
=> CS.Key -- ^ The encryption key
|
||||
-> Int -- ^ Inactive session valitity in minutes
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> SessionBackend master
|
||||
clientSessionBackend key timeout = SessionBackend
|
||||
{ sbLoadSession = loadClientSession key timeout "_SESSION"
|
||||
}
|
||||
clientSessionBackend key getCachedDate =
|
||||
SessionBackend {
|
||||
sbLoadSession = loadClientSession key getCachedDate "_SESSION"
|
||||
}
|
||||
|
||||
loadClientSession :: Yesod master
|
||||
=> CS.Key
|
||||
-> Int -- ^ timeout
|
||||
-> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
|
||||
-> S8.ByteString -- ^ session name
|
||||
-> master
|
||||
-> W.Request
|
||||
-> UTCTime
|
||||
-> IO (BackendSession, SaveSession)
|
||||
loadClientSession key timeout sessionName master req now = return (sess, save)
|
||||
loadClientSession key getCachedDate sessionName master req = load
|
||||
where
|
||||
sess = fromMaybe [] $ do
|
||||
load = do
|
||||
date <- getCachedDate
|
||||
return (sess date, save date)
|
||||
sess date = fromMaybe [] $ do
|
||||
raw <- lookup "Cookie" $ W.requestHeaders req
|
||||
val <- lookup sessionName $ parseCookies raw
|
||||
let host = "" -- fixme, properly lock sessions to client address
|
||||
decodeClientSession key now host val
|
||||
save sess' now' = do
|
||||
decodeClientSession key date host val
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie def
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = sessionVal iv
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just (cookiePath master)
|
||||
, setCookieExpires = Just expires
|
||||
, setCookieExpires = Just (csdcExpires date)
|
||||
, setCookieDomain = cookieDomain master
|
||||
, setCookieHttpOnly = True
|
||||
}]
|
||||
where
|
||||
host = "" -- fixme, properly lock sessions to client address
|
||||
expires = fromIntegral (timeout * 60) `addUTCTime` now'
|
||||
sessionVal iv = encodeClientSession key iv expires host sess'
|
||||
|
||||
|
||||
-- | Run a 'GHandler' completely outside of Yesod. This
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
module Yesod.Internal.Session
|
||||
( encodeClientSession
|
||||
, decodeClientSession
|
||||
, clientSessionDateCacher
|
||||
, ClientSessionDateCache(..)
|
||||
, BackendSession
|
||||
, SaveSession
|
||||
, SessionBackend(..)
|
||||
@ -8,70 +10,121 @@ module Yesod.Internal.Session
|
||||
|
||||
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 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 -- ^ 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
|
||||
-> ClientSessionDateCache -- ^ 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'
|
||||
encodeClientSession key iv date rhost session' =
|
||||
CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
|
||||
where expires = Right (csdcExpiresSerialized date)
|
||||
|
||||
decodeClientSession :: CS.Key
|
||||
-> UTCTime -- ^ current time
|
||||
-> ClientSessionDateCache -- ^ current time
|
||||
-> ByteString -- ^ remote host field
|
||||
-> ByteString -- ^ cookie value
|
||||
-> Maybe [(Text, ByteString)]
|
||||
decodeClientSession key now rhost encrypted = do
|
||||
decodeClientSession key date rhost encrypted = do
|
||||
decrypted <- CS.decrypt key encrypted
|
||||
SessionCookie expire rhost' session' <-
|
||||
SessionCookie (Left expire) rhost' session' <-
|
||||
either (const Nothing) Just $ decode decrypted
|
||||
guard $ expire > now
|
||||
guard $ expire > csdcNow date
|
||||
guard $ rhost' == rhost
|
||||
return session'
|
||||
|
||||
data SessionCookie = SessionCookie UTCTime ByteString [(Text, ByteString)]
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = putTime a >> put b >> put (map (first unpack) c)
|
||||
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 a b c
|
||||
return $ SessionCookie (Left a) b c
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
-- 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.
|
||||
|
||||
data ClientSessionDateCache =
|
||||
ClientSessionDateCache {
|
||||
csdcNow :: !UTCTime
|
||||
, csdcExpires :: !UTCTime
|
||||
, csdcExpiresSerialized :: !ByteString
|
||||
} deriving (Eq, Show)
|
||||
|
||||
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
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
putTime :: Putter UTCTime
|
||||
putTime t@(UTCTime d _) = do
|
||||
put $ toModifiedJulianDay d
|
||||
let ndt = diffUTCTime t $ UTCTime d 0
|
||||
put $ toRational ndt
|
||||
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
|
||||
d <- get
|
||||
ndt <- get
|
||||
return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user