diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 9a6f4a79..724e1f85 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -694,7 +694,7 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat -- is never (realistically) expired. neverExpires :: MonadHandler m => m () neverExpires = do - setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" + askHandlerEnv >>= liftIO . rheGetMaxExpires >>= setHeader "Expires" cacheSeconds oneYear where oneYear :: Int diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index 4fa6f601..a8fe383c 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -31,6 +31,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (getCurrentTime, addUTCTime) import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai @@ -45,9 +46,11 @@ import Yesod.Core.Class.Yesod import Yesod.Core.Types import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) +import Yesod.Core.Internal.Util (formatRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import Control.Monad (liftM) +import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction) returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap #if MIN_VERSION_bytestring(0, 10, 0) @@ -194,6 +197,7 @@ runFakeHandler :: (Yesod site, MonadIO m) => -> m (Either ErrorResponse a) runFakeHandler fakeSessionMap logger site handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") + getMaxExpires <- getGetMaxExpires let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () let yapp = runHandler @@ -204,6 +208,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler + , rheGetMaxExpires = getMaxExpires } handler' errHandler err req = do @@ -255,6 +260,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend + getMaxExpires <- getGetMaxExpires let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let yreq = case mkYesodReq of @@ -273,6 +279,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' + , rheGetMaxExpires = getMaxExpires } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler @@ -286,6 +293,10 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse mmaxLen = maximumContentLength yreSite route handler = yesodMiddleware handler' +getGetMaxExpires :: MonadIO m => m (IO Text) +getGetMaxExpires = liftIO $ mkAutoUpdate defaultUpdateSettings + { updateAction = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime } + yesodRender :: Yesod y => y -> ResolvedApproot diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index f763462a..368c38d9 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -177,6 +177,7 @@ data RunHandlerEnv site = RunHandlerEnv , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheOnError :: !(ErrorResponse -> YesodApp) + , rheGetMaxExpires :: IO Text -- ^ How to respond when an error is thrown internally. -- -- Since 1.2.0 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 7c1f5e7f..ac1aba73 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -69,6 +69,7 @@ library , mwc-random , primitive , word8 + , auto-update exposed-modules: Yesod.Core Yesod.Core.Content