neverExpires sets 'Expires' header to be a year from now.
This commit is contained in:
parent
5d771e49bb
commit
42f098ff64
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user