diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -35,6 +35,8 @@ , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend + , clientSessionBackend2 + , clientSessionDateCacher , loadClientSession , Header(..) , BackendSession diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -25,6 +25,9 @@ , defaultClientSessionBackend , clientSessionBackend , loadClientSession + , clientSessionBackend2 + , loadClientSession2 + , clientSessionDateCacher , BackendSession -- * jsLoader , ScriptLoadPosition (..) @@ -41,8 +44,10 @@ import Yesod.Content import Yesod.Handler hiding (lift, getExpires) +import Control.Monad.Logger (logErrorS) import Yesod.Routes.Class +import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Data.Word (Word64) import Control.Arrow ((***)) @@ -69,7 +74,6 @@ 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) @@ -351,9 +355,7 @@ -- -- 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. -- @@ -437,9 +439,9 @@ [("Content-Type", "text/plain")] "Request body too large to be processed." | otherwise = do - now <- liftIO getCurrentTime let dontSaveSession _ _ = return [] - (session, saveSession) <- liftIO $ + now <- liftIO getCurrentTime -- FIXME remove in next major version bump + (session, saveSession) <- liftIO $ do maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb rr <- liftIO $ parseWaiRequest req session (isJust msb) len let h = {-# SCC "h" #-} do @@ -547,7 +549,8 @@ $forall msg <- ia
  • #{msg} |] -defaultErrorHandler (InternalError e) = +defaultErrorHandler (InternalError e) = do + $logErrorS "yesod-core" e applyLayout' "Internal Server Error" [hamlet| $newline never @@ -758,9 +761,11 @@ 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 $ clientSessionBackend2 key getCachedDate + clientSessionBackend :: Yesod master => CS.Key -- ^ The encryption key -> Int -- ^ Inactive session valitity in minutes @@ -768,6 +773,7 @@ clientSessionBackend key timeout = SessionBackend { sbLoadSession = loadClientSession key timeout "_SESSION" } +{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-} loadClientSession :: Yesod master => CS.Key @@ -783,7 +789,7 @@ 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 + decodeClientSessionOld key now host val save sess' now' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV @@ -798,7 +804,48 @@ where host = "" -- fixme, properly lock sessions to client address expires = fromIntegral (timeout * 60) `addUTCTime` now' - sessionVal iv = encodeClientSession key iv expires host sess' + sessionVal iv = encodeClientSessionOld key iv expires host sess' +{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-} + +clientSessionBackend2 :: Yesod master + => CS.Key -- ^ The encryption key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> SessionBackend master +clientSessionBackend2 key getCachedDate = + SessionBackend { + sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req + } + +loadClientSession2 :: Yesod master + => CS.Key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> S8.ByteString -- ^ session name + -> master + -> W.Request + -> IO (BackendSession, SaveSession) +loadClientSession2 key getCachedDate sessionName master req = load + where + 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 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 = encodeClientSession key iv date host sess' + , setCookiePath = Just (cookiePath master) + , setCookieExpires = Just (csdcExpires date) + , setCookieDomain = cookieDomain master + , setCookieHttpOnly = True + }] + where + host = "" -- fixme, properly lock sessions to client address -- | Run a 'GHandler' completely outside of Yesod. This diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs --- a/Yesod/Internal/Session.hs +++ b/Yesod/Internal/Session.hs @@ -1,77 +1,161 @@ 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.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 + -> UTCTime -- FIXME remove this in the next major version bump -> IO [Header] +type SaveSessionOld = BackendSession -- ^ The session contents after running the handler + -> UTCTime + -> IO [Header] + newtype SessionBackend master = SessionBackend { sbLoadSession :: master -> W.Request - -> UTCTime + -> UTCTime -- FIXME remove this in the next major version bump -> 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 + +encodeClientSessionOld :: CS.Key + -> CS.IV + -> UTCTime -- ^ expire time + -> ByteString -- ^ remote host + -> [(Text, ByteString)] -- ^ session + -> ByteString -- ^ cookie value +encodeClientSessionOld key iv expire rhost session' = + CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session' + +decodeClientSessionOld :: CS.Key + -> UTCTime -- ^ current time + -> ByteString -- ^ remote host field + -> ByteString -- ^ cookie value + -> 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' diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.1.6.1 +version: 1.1.7 license: MIT license-file: LICENSE author: Michael Snoyman