neverExpires sets 'Expires' header to be a year from now.

This commit is contained in:
David Turner 2014-11-21 17:17:35 +00:00
parent 5d771e49bb
commit 42f098ff64
4 changed files with 14 additions and 1 deletions

View File

@ -694,7 +694,7 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
-- is never (realistically) expired. -- is never (realistically) expired.
neverExpires :: MonadHandler m => m () neverExpires :: MonadHandler m => m ()
neverExpires = do neverExpires = do
setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" askHandlerEnv >>= liftIO . rheGetMaxExpires >>= setHeader "Expires"
cacheSeconds oneYear cacheSeconds oneYear
where where
oneYear :: Int oneYear :: Int

View File

@ -31,6 +31,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Time (getCurrentTime, addUTCTime)
import Language.Haskell.TH.Syntax (Loc, qLocation) import Language.Haskell.TH.Syntax (Loc, qLocation)
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Network.Wai import Network.Wai
@ -45,9 +46,11 @@ import Yesod.Core.Class.Yesod
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Request (parseWaiRequest, import Yesod.Core.Internal.Request (parseWaiRequest,
tooLargeResponse) tooLargeResponse)
import Yesod.Core.Internal.Util (formatRFC1123)
import Yesod.Routes.Class (Route, renderRoute) import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData) import Control.DeepSeq (($!!), NFData)
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction)
returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
#if MIN_VERSION_bytestring(0, 10, 0) #if MIN_VERSION_bytestring(0, 10, 0)
@ -194,6 +197,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
-> m (Either ErrorResponse a) -> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
getMaxExpires <- getGetMaxExpires
let handler' = do liftIO . I.writeIORef ret . Right =<< handler let handler' = do liftIO . I.writeIORef ret . Right =<< handler
return () return ()
let yapp = runHandler let yapp = runHandler
@ -204,6 +208,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
, rheUpload = fileUpload site , rheUpload = fileUpload site
, rheLog = messageLoggerSource site $ logger site , rheLog = messageLoggerSource site $ logger site
, rheOnError = errHandler , rheOnError = errHandler
, rheGetMaxExpires = getMaxExpires
} }
handler' handler'
errHandler err req = do errHandler err req = do
@ -255,6 +260,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
let dontSaveSession _ = return [] let dontSaveSession _ = return []
(session, saveSession) <- liftIO $ do (session, saveSession) <- liftIO $ do
maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
getMaxExpires <- getGetMaxExpires
let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
let yreq = let yreq =
case mkYesodReq of case mkYesodReq of
@ -273,6 +279,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
, rheUpload = fileUpload yreSite , rheUpload = fileUpload yreSite
, rheLog = log' , rheLog = log'
, rheOnError = safeEh log' , rheOnError = safeEh log'
, rheGetMaxExpires = getMaxExpires
} }
rhe = rheSafe rhe = rheSafe
{ rheOnError = runHandler rheSafe . errorHandler { rheOnError = runHandler rheSafe . errorHandler
@ -286,6 +293,10 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
mmaxLen = maximumContentLength yreSite route mmaxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler' 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 yesodRender :: Yesod y
=> y => y
-> ResolvedApproot -> ResolvedApproot

View File

@ -177,6 +177,7 @@ data RunHandlerEnv site = RunHandlerEnv
, rheUpload :: !(RequestBodyLength -> FileUpload) , rheUpload :: !(RequestBodyLength -> FileUpload)
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
, rheOnError :: !(ErrorResponse -> YesodApp) , rheOnError :: !(ErrorResponse -> YesodApp)
, rheGetMaxExpires :: IO Text
-- ^ How to respond when an error is thrown internally. -- ^ How to respond when an error is thrown internally.
-- --
-- Since 1.2.0 -- Since 1.2.0

View File

@ -69,6 +69,7 @@ library
, mwc-random , mwc-random
, primitive , primitive
, word8 , word8
, auto-update
exposed-modules: Yesod.Core exposed-modules: Yesod.Core
Yesod.Core.Content Yesod.Core.Content