haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make Felipe's session code the default (#415)

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-10 10:08:20 +02:00
parent 2377d70ec8
commit 20091656aa
3 changed files with 9 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
yesod-core/Yesod/Core.hs
View File

@ -35,7 +35,6 @@ module Yesod.Core
, SessionBackend (..)
, defaultClientSessionBackend
, clientSessionBackend
, clientSessionBackend2
, clientSessionDateCacher
, loadClientSession
, Header(..)

64
yesod-core/Yesod/Internal/Core.hs
View File

@ -26,8 +26,6 @@ module Yesod.Internal.Core
, defaultClientSessionBackend
, clientSessionBackend
, loadClientSession
, clientSessionBackend2
, loadClientSession2
, clientSessionDateCacher
, BackendSession
-- * jsLoader
@ -48,7 +46,6 @@ 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 ((***))
@ -435,10 +432,9 @@ defaultYesodRunner :: Yesod master
defaultYesodRunner logger handler' master sub murl toMasterRoute msb req
| W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse
| otherwise = do
let dontSaveSession _ _ = return []
now <- liftIO getCurrentTime -- FIXME remove in next major version bump
let dontSaveSession _ = return []
(session, saveSession) <- liftIO $ do
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) maxLen
let h = {-# SCC "h" #-} do
case murl of
@ -468,7 +464,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
@ -755,67 +751,25 @@ defaultClientSessionBackend = do
key <- CS.getKey CS.defaultKeyFile
let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes
(getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout
return $ clientSessionBackend2 key getCachedDate
return $ clientSessionBackend key getCachedDate
clientSessionBackend :: Yesod master
=> CS.Key -- ^ The encryption key
-> Int -- ^ Inactive session valitity in minutes
-> SessionBackend master
clientSessionBackend key timeout = SessionBackend
{ sbLoadSession = loadClientSession key timeout "_SESSION"
}
{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-}
loadClientSession :: Yesod master
=> CS.Key
-> Int -- ^ timeout
-> S8.ByteString -- ^ session name
-> master
-> W.Request
-> UTCTime
-> IO (BackendSession, SaveSession)
loadClientSession key timeout sessionName master req now = return (sess, save)
where
sess = fromMaybe [] $ do
raw <- lookup "Cookie" $ W.requestHeaders req
val <- lookup sessionName $ parseCookies raw
let host = "" -- fixme, properly lock sessions to client address
decodeClientSessionOld key now host val
save sess' now' = do
-- We should never cache the IV! Be careful!
iv <- liftIO CS.randomIV
return [AddCookie def
{ setCookieName = sessionName
, setCookieValue = sessionVal iv
, setCookiePath = Just (cookiePath master)
, setCookieExpires = Just expires
, setCookieDomain = cookieDomain master
, setCookieHttpOnly = True
}]
where
host = "" -- fixme, properly lock sessions to client address
expires = fromIntegral (timeout * 60) `addUTCTime` now'
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 =
clientSessionBackend key getCachedDate =
SessionBackend {
sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req
sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req
}
loadClientSession2 :: Yesod master
loadClientSession :: 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
loadClientSession key getCachedDate sessionName master req = load
where
load = do
date <- getCachedDate
@ -825,7 +779,7 @@ loadClientSession2 key getCachedDate sessionName master req = load
val <- lookup sessionName $ parseCookies raw
let host = "" -- fixme, properly lock sessions to client address
decodeClientSession key date host val
save date sess' _ = do
save date sess' = do
-- We should never cache the IV! Be careful!
iv <- liftIO CS.randomIV
return [AddCookie def

31
yesod-core/Yesod/Internal/Session.hs
View File

@ -1,13 +1,10 @@
module Yesod.Internal.Session
( encodeClientSession
, encodeClientSessionOld
, decodeClientSession
, decodeClientSessionOld
, clientSessionDateCacher
, ClientSessionDateCache(..)
, BackendSession
, SaveSession
, SaveSessionOld
, SessionBackend(..)
) where
@ -30,17 +27,11 @@ import qualified Network.Wai as W
type BackendSession = [(Text, S8.ByteString)]
type SaveSession = BackendSession -- ^ The session contents after running the handler
-> 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 -- FIXME remove this in the next major version bump
-> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
}
@ -137,25 +128,3 @@ 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'