diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.37 + +* Add `setWeakEtag` function in Yesod.Core.Handler module. + ## 1.4.36 * Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416) diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -123,6 +123,7 @@ , alreadyExpired , expiresAt , setEtag + , setWeakEtag -- * Session , SessionMap , lookupSession @@ -851,12 +852,24 @@ expiresAt :: MonadHandler m => UTCTime -> m () expiresAt = setHeader "Expires" . formatRFC1123 +data Etag + = WeakEtag !S.ByteString + -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are + -- semantically identical but make no guarantees about being bytewise identical. + | StrongEtag !S.ByteString + -- ^ Signifies that contents should be byte-for-byte identical if they match + -- the provided ETag + | InvalidEtag !S.ByteString + -- ^ Anything else that ends up in a header that expects an ETag but doesn't + -- properly follow the ETag format specified in RFC 7232, section 2.3 + deriving (Show, Eq) + -- | Check the if-none-match header and, if it matches the given value, return -- a 304 not modified response. Otherwise, set the etag header to the given -- value. -- -- Note that it is the responsibility of the caller to ensure that the provided --- value is a value etag value, no sanity checking is performed by this +-- value is a valid etag value, no sanity checking is performed by this -- function. -- -- @since 1.4.4 @@ -864,22 +877,53 @@ setEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch - if encodeUtf8 etag `elem` matches + baseTag = encodeUtf8 etag + strongTag = StrongEtag baseTag + badTag = InvalidEtag baseTag + if any (\tag -> tag == strongTag || tag == badTag) matches then notModified else addHeader "etag" $ T.concat ["\"", etag, "\""] --- | Parse an if-none-match field according to the spec. Does not parsing on --- weak matches, which are not supported by setEtag. -parseMatch :: S.ByteString -> [S.ByteString] + +-- | Parse an if-none-match field according to the spec. +parseMatch :: S.ByteString -> [Etag] parseMatch = map clean . S.split W8._comma where - clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace + clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace - stripQuotes bs + classify bs | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl - = S.init $ S.tail bs - | otherwise = bs + = StrongEtag $ S.init $ S.tail bs + | S.length bs >= 4 && + S.head bs == W8._W && + S.index bs 1 == W8._slash && + S.index bs 2 == W8._quotedbl && + S.last bs == W8._quotedbl + = WeakEtag $ S.init $ S.drop 3 bs + | otherwise = InvalidEtag bs + +-- | Check the if-none-match header and, if it matches the given value, return +-- a 304 not modified response. Otherwise, set the etag header to the given +-- value. +-- +-- A weak etag is only expected to be semantically identical to the prior content, +-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for +-- dynamically generated content that may be difficult to perform bytewise hashing +-- upon. +-- +-- Note that it is the responsibility of the caller to ensure that the provided +-- value is a valid etag value, no sanity checking is performed by this +-- function. +-- +-- @since 1.4.37 +setWeakEtag :: MonadHandler m => Text -> m () +setWeakEtag etag = do + mmatch <- lookupHeader "if-none-match" + let matches = maybe [] parseMatch mmatch + if WeakEtag (encodeUtf8 etag) `elem` matches + then notModified + else addHeader "etag" $ T.concat ["W/\"", etag, "\""] -- | Set a variable in the user's session. -- diff --git a/test/YesodCoreTest/Redirect.hs b/test/YesodCoreTest/Redirect.hs --- a/test/YesodCoreTest/Redirect.hs +++ b/test/YesodCoreTest/Redirect.hs @@ -6,7 +6,7 @@ ) where import YesodCoreTest.YesodTest -import Yesod.Core.Handler (redirectWith, setEtag) +import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag) import qualified Network.HTTP.Types as H data Y = Y @@ -17,6 +17,7 @@ /r307 R307 GET /rregular RRegular GET /etag EtagR GET +/weak-etag WeakEtagR GET |] instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO () @@ -28,12 +29,13 @@ postRootR :: Handler () postRootR = return () -getR301, getR303, getR307, getRRegular, getEtagR :: Handler () +getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR getEtagR = setEtag "hello world" +getWeakEtagR = setWeakEtag "hello world" specs :: Spec specs = describe "Redirect" $ do @@ -77,6 +79,8 @@ res <- request defaultRequest { pathInfo = ["etag"] } assertStatus 200 res assertHeader "etag" "\"hello world\"" res + -- Note: this violates the RFC around ETag format, but is being left as is + -- out of concerns that it might break existing users with misbehaving clients. it "single, unquoted if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] @@ -102,9 +106,27 @@ , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")] } assertStatus 304 res - it "ignore weak" $ app $ do + it "ignore weak when provided normal etag" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] + } + assertStatus 200 res + it "weak etag" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] + } + assertStatus 304 res + it "different if-none-match for weak etag" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "W/\"foo\"")] + } + assertStatus 200 res + it "ignore strong when expecting weak" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")] } assertStatus 200 res diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.36 +version: 1.4.37 license: MIT license-file: LICENSE author: Michael Snoyman