diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 7df9437f..7911877d 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -59,6 +59,8 @@ import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Safe (readMay) import System.Environment (getEnvironment) +import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) +import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride @@ -82,11 +84,13 @@ toWaiAppPlain site = do logger <- makeLogger site sb <- makeSessionBackend site gen <- MWC.createSystemRandom + getMaxExpires <- getGetMaxExpires return $ toWaiAppYre $ YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = gen + , yreGetMaxExpires = getMaxExpires } toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application @@ -139,11 +143,13 @@ toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger logger site = do sb <- makeSessionBackend site gen <- MWC.createSystemRandom + getMaxExpires <- getGetMaxExpires let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb , yreGen = gen + , yreGetMaxExpires = getMaxExpires } messageLoggerSource site @@ -230,3 +236,9 @@ warpEnv site = do case readMay portS of Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Just port -> warp port site + +getGetMaxExpires :: IO (IO Text) +getGetMaxExpires = mkAutoUpdate defaultUpdateSettings + { updateAction = getCurrentMaxExpiresRFC1123 + , updateFreq = 24 * 60 * 60 * 1000000 -- Update once per day + } diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 6ff08c64..af4e8aff 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -733,7 +733,7 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat -- is never (realistically) expired. neverExpires :: MonadHandler m => m () neverExpires = do - askHandlerEnv >>= liftIO . rheGetMaxExpires >>= setHeader "Expires" + setHeader "Expires" . rheMaxExpires =<< askHandlerEnv cacheSeconds oneYear where oneYear :: Int diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index d051dd49..e80d3d62 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -34,7 +34,6 @@ 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 @@ -48,11 +47,9 @@ import Yesod.Core.Class.Yesod import Yesod.Core.Types import Yesod.Core.Internal.Request (parseWaiRequest, tooLargeResponse) -import Yesod.Core.Internal.Util (formatRFC1123) +import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!)) -import Control.Monad (liftM) -import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap #if MIN_VERSION_bytestring(0, 10, 0) @@ -199,7 +196,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 + maxExpires <- getCurrentMaxExpiresRFC1123 let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () let yapp = runHandler @@ -210,7 +207,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheUpload = fileUpload site , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler - , rheGetMaxExpires = getMaxExpires + , rheMaxExpires = maxExpires } handler' errHandler err req = do @@ -261,7 +258,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 + maxExpires <- yreGetMaxExpires let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let yreq = case mkYesodReq of @@ -280,7 +277,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse , rheUpload = fileUpload yreSite , rheLog = log' , rheOnError = safeEh log' - , rheGetMaxExpires = getMaxExpires + , rheMaxExpires = maxExpires } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler @@ -294,12 +291,6 @@ 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 - , updateFreq = 60 * 60 * 1000000 -- Update once per hour - } - yesodRender :: Yesod y => y -> ResolvedApproot diff --git a/yesod-core/Yesod/Core/Internal/Util.hs b/yesod-core/Yesod/Core/Internal/Util.hs index 27f70a52..96d87073 100644 --- a/yesod-core/Yesod/Core/Internal/Util.hs +++ b/yesod-core/Yesod/Core/Internal/Util.hs @@ -5,13 +5,16 @@ module Yesod.Core.Internal.Util , formatW3 , formatRFC1123 , formatRFC822 + , getCurrentMaxExpiresRFC1123 ) where import Data.Int (Int64) import Data.Serialize (Get, Put, Serialize (..)) import qualified Data.Text as T import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), - DiffTime, UTCTime (..), formatTime) + DiffTime, UTCTime (..), formatTime, + getCurrentTime, addUTCTime) +import Control.Monad (liftM) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) @@ -50,3 +53,9 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" -- | Format as per RFC 822. formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" + +{- | Get the time 365 days from now in RFC 1123 format. For use as an expiry +date on a resource that never expires. See RFC 2616 section 14.21 for details. +-} +getCurrentMaxExpiresRFC1123 :: IO T.Text +getCurrentMaxExpiresRFC1123 = liftM (formatRFC1123 . addUTCTime (60*60*24*365)) getCurrentTime diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 99e48267..d8a2b2e0 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -183,10 +183,10 @@ 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 + , rheMaxExpires :: !Text } data HandlerData site parentRoute = HandlerData @@ -202,6 +202,7 @@ data YesodRunnerEnv site = YesodRunnerEnv , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) , yreGen :: !MWC.GenIO + , yreGetMaxExpires :: IO Text } data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv