From 0a72e93a616108759beb241140da426e81f1705c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sat, 26 Dec 2009 23:57:03 +0200
Subject: [PATCH] Client session duration is configurable.

Defaults to 2 hours.
---
 Hack/Middleware/ClientSession.hs | 9 +++++----
 Yesod/Yesod.hs                   | 8 +++++++-
 2 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs
index c9bff08d..7f069c93 100644
--- a/Hack/Middleware/ClientSession.hs
+++ b/Hack/Middleware/ClientSession.hs
@@ -44,8 +44,9 @@ import Control.Monad (guard)
 -- the data to make sure that the user can neither see not tamper with it.
 clientsession :: [String] -- ^ list of cookies to intercept
               -> Word256 -- ^ encryption key
+              -> Int -- ^ minutes to live
               -> Middleware
-clientsession cnames key app env = do
+clientsession cnames key minutesToLive app env = do
     let initCookiesRaw :: String
         initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env
         nonCookies :: [(String, String)]
@@ -71,9 +72,9 @@ clientsession cnames key app env = do
     res <- app env'
     let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames))
                                      $ headers res
-    let twentyMinutes :: Int
-        twentyMinutes = 20 * 60
-    let exp = fromIntegral twentyMinutes `addUTCTime` now
+    let timeToLive :: Int
+        timeToLive = minutesToLive * 60
+    let exp = fromIntegral timeToLive `addUTCTime` now
     let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
     let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies
     let newCookies = map (setCookie key exp formattedExp remoteHost') $
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 5298ef87..83ae306f 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -32,6 +32,11 @@ class Yesod a where
     encryptKey :: a -> IO Word256
     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.
     errorHandler :: ErrorResult -> Handler a RepChooser
     errorHandler = defaultErrorHandler
@@ -64,8 +69,9 @@ toHackApp :: Yesod y => y -> Hack.Application
 toHackApp a env = do
     key <- encryptKey a
     let app' = toHackApp' a
+    let mins = clientSessionDuration a
     (gzip $ cleanPath $ jsonp $ methodOverride
-          $ clientsession [authCookieName] key $ app') env
+          $ clientsession [authCookieName] key mins $ app') env
 
 toHackApp' :: Yesod y => y -> Hack.Application
 toHackApp' y env = do