yesod-core 1.1.6.1 → 1.1.7
raw patch · 4 files changed
+165/−32 lines, 4 files
Files
- Yesod/Core.hs +2/−0
- Yesod/Internal/Core.hs +58/−11
- Yesod/Internal/Session.hs +104/−20
- yesod-core.cabal +1/−1
Yesod/Core.hs view
@@ -35,6 +35,8 @@ , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend+ , clientSessionBackend2+ , clientSessionDateCacher , loadClientSession , Header(..) , BackendSession
Yesod/Internal/Core.hs view
@@ -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 <li>#{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
Yesod/Internal/Session.hs view
@@ -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'
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.1.6.1+version: 1.1.7 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>