Improve etag supported fpco/stackage-server#29 #868 #869

yesod-core/Yesod/Core/Handler.hs

@@ -211,6 +211,7 @@ import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
                     , Sink
                    )
 import qualified Yesod.Core.TypeCache as Cache
+import qualified Data.Word8 as W8
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -712,13 +713,31 @@ expiresAt = setHeader "Expires" . formatRFC1123
 -- 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
+-- function.
+--
 -- Since 1.4.4
 setEtag :: MonadHandler m => Text -> m ()
 setEtag etag = do
     mmatch <- lookupHeader "if-none-match"
-    case mmatch of
-        Just x | encodeUtf8 etag == x -> notModified
-        _ -> addHeader "etag" etag
+    let matches = maybe [] parseMatch mmatch
+    if encodeUtf8 etag `elem` 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]
+parseMatch =
+    map clean . S.split W8._comma
+  where
+    clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace
+
+    stripQuotes bs
+        | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl
+            = S.init $ S.tail bs
+        | otherwise = bs
 
 -- | Set a variable in the user's session.
 --

yesod-core/test/YesodCoreTest/Redirect.hs

@@ -2,7 +2,7 @@
 module YesodCoreTest.Redirect (specs, Widget) where
 
 import YesodCoreTest.YesodTest
-import Yesod.Core.Handler (redirectWith)
+import Yesod.Core.Handler (redirectWith, setEtag)
 import qualified Network.HTTP.Types as H
 
 data Y = Y
@@ -12,6 +12,7 @@ mkYesod "Y" [parseRoutes|
 /r303 R303 GET
 /r307 R307 GET
 /rregular RRegular GET
+/etag EtagR GET
 |]
 instance Yesod Y where approot = ApprootStatic "http://test"
 app :: Session () -> IO ()
@@ -23,11 +24,12 @@ getRootR = return ()
 postRootR :: Handler ()
 postRootR = return ()
 
-getR301, getR303, getR307, getRRegular :: Handler ()
+getR301, getR303, getR307, getRRegular, getEtagR :: Handler ()
 getR301 = redirectWith H.status301 RootR
 getR303 = redirectWith H.status303 RootR
 getR307 = redirectWith H.status307 RootR
 getRRegular = redirect RootR
+getEtagR = setEtag "hello world"
 
 specs :: Spec
 specs = describe "Redirect" $ do
@@ -65,3 +67,40 @@ specs = describe "Redirect" $ do
       }
       assertStatus 302 res
       assertBodyContains "" res
+
+    describe "etag" $ do
+      it "no if-none-match" $ app $ do
+        res <- request defaultRequest { pathInfo = ["etag"] }
+        assertStatus 200 res
+        assertHeader "etag" "\"hello world\"" res
+      it "single, unquoted if-none-match" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["etag"]
+            , requestHeaders = [("if-none-match", "hello world")]
+            }
+        assertStatus 304 res
+      it "different if-none-match" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["etag"]
+            , requestHeaders = [("if-none-match", "hello world!")]
+            }
+        assertStatus 200 res
+        assertHeader "etag" "\"hello world\"" res
+      it "single, quoted if-none-match" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["etag"]
+            , requestHeaders = [("if-none-match", "\"hello world\"")]
+            }
+        assertStatus 304 res
+      it "multiple quoted if-none-match" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["etag"]
+            , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")]
+            }
+        assertStatus 304 res
+      it "ignore weak" $ app $ do
+        res <- request defaultRequest
+            { pathInfo = ["etag"]
+            , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")]
+            }
+        assertStatus 200 res