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

Client session duration is configurable.

Browse Source 
Defaults to 2 hours.
This commit is contained in:
Michael Snoyman 2009-12-26 23:57:03 +02:00
parent fb772f9d9e
commit 0a72e93a61
2 changed files with 12 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Hack/Middleware/ClientSession.hs
View File

@ -44,8 +44,9 @@ import Control.Monad (guard)
-- the data to make sure that the user can neither see not tamper with it. -- the data to make sure that the user can neither see not tamper with it.
clientsession :: [String] -- ^ list of cookies to intercept clientsession :: [String] -- ^ list of cookies to intercept
-> Word256 -- ^ encryption key -> Word256 -- ^ encryption key
-> Int -- ^ minutes to live
-> Middleware -> Middleware
clientsession cnames key app env = do clientsession cnames key minutesToLive app env = do
let initCookiesRaw :: String let initCookiesRaw :: String
initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env
nonCookies :: [(String, String)] nonCookies :: [(String, String)]
@ -71,9 +72,9 @@ clientsession cnames key app env = do
res <- app env' res <- app env'
let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames)) let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames))
$ headers res $ headers res
let twentyMinutes :: Int let timeToLive :: Int
twentyMinutes = 20 * 60 timeToLive = minutesToLive * 60
let exp = fromIntegral twentyMinutes `addUTCTime` now let exp = fromIntegral timeToLive `addUTCTime` now
let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies
let newCookies = map (setCookie key exp formattedExp remoteHost') $ let newCookies = map (setCookie key exp formattedExp remoteHost') $

8
Yesod/Yesod.hs
View File

@ -32,6 +32,11 @@ class Yesod a where
encryptKey :: a -> IO Word256 encryptKey :: a -> IO Word256
encryptKey _ = getKey defaultKeyFile encryptKey _ = getKey defaultKeyFile
-- | Number of minutes before a client session times out. Defaults to
-- 120 (2 hours).
clientSessionDuration :: a -> Int
clientSessionDuration = const 120
-- | Output error response pages. -- | Output error response pages.
errorHandler :: ErrorResult -> Handler a RepChooser errorHandler :: ErrorResult -> Handler a RepChooser
errorHandler = defaultErrorHandler errorHandler = defaultErrorHandler
@ -64,8 +69,9 @@ toHackApp :: Yesod y => y -> Hack.Application
toHackApp a env = do toHackApp a env = do
key <- encryptKey a key <- encryptKey a
let app' = toHackApp' a let app' = toHackApp' a
let mins = clientSessionDuration a
(gzip $ cleanPath $ jsonp $ methodOverride (gzip $ cleanPath $ jsonp $ methodOverride
$ clientsession [authCookieName] key $ app') env $ clientsession [authCookieName] key mins $ app') env
toHackApp' :: Yesod y => y -> Hack.Application toHackApp' :: Yesod y => y -> Hack.Application
toHackApp' y env = do toHackApp' y env = do