Merge PR yesodweb#945

wai-app-static/Network/Wai/Application/Static.hs

@@ -157,6 +157,7 @@ serveFile StaticSettings {..} req file
     -- First check etag values, if turned on
     | ssUseHash = do
         mHash <- fileGetHash file
+        -- FIXME: Doesn't support multiple hashes in 'If-None-Match' header
         case (mHash, lookup "if-none-match" $ W.requestHeaders req) of
             -- if-none-match matches the actual hash, return a 304
             (Just hash, Just lastHash) | hash == lastHash -> return NotModified

warp/Network/Wai/Handler/Warp/File.hs

@@ -35,22 +35,38 @@ data RspFileInfo = WithoutBody H.Status
 
 conditionalRequest :: I.FileInfo
                    -> H.ResponseHeaders
+                   -> H.Method
                    -> IndexedHeader -- ^ Response
                    -> IndexedHeader -- ^ Request
                    -> RspFileInfo
-conditionalRequest finfo hs0 rspidx reqidx = case condition of
+conditionalRequest finfo hs0 method rspidx reqidx = case condition of
     nobody@(WithoutBody _) -> nobody
-    WithBody s _ off len   -> let !hs1 = addContentHeaders hs0 off len size
-                                  !hasLM = isJust $ rspidx ! fromEnum ResLastModified
-                                  !hs = [ (H.hLastModified,date) | not hasLM ] ++ hs1
-                              in WithBody s hs off len
+    WithBody s _ off len   ->
+        let !hs1 = addContentHeaders hs0 off len size
+            !hs = case rspidx ! fromEnum ResLastModified of
+                Just _ -> hs1
+                Nothing -> (H.hLastModified,date) : hs1
+        in WithBody s hs off len
   where
     !mtime = I.fileInfoTime finfo
     !size  = I.fileInfoSize finfo
     !date  = I.fileInfoDate finfo
-    !mcondition = ifmodified    reqidx size mtime
-              <|> ifunmodified  reqidx size mtime
-              <|> ifrange       reqidx size mtime
+    -- According to RFC 9110:
+    -- "A recipient cache or origin server MUST evaluate the request
+    -- preconditions defined by this specification in the following order:
+    -- - If-Match
+    -- - If-Unmodified-Since
+    -- - If-None-Match
+    -- - If-Modified-Since
+    -- - If-Range
+    --
+    -- We don't actually implement the If-(None-)Match logic, but
+    -- we also don't want to block middleware or applications from
+    -- using ETags. And sending If-(None-)Match headers in a request
+    -- to a server that doesn't use them is requester's problem.
+    !mcondition = ifunmodified  reqidx mtime
+              <|> ifmodified    reqidx mtime method
+              <|> ifrange       reqidx mtime method size
     !condition = fromMaybe (unconditional reqidx size) mcondition
 
 ----------------------------------------------------------------
@@ -66,32 +82,48 @@ ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate
 
 ----------------------------------------------------------------
 
-ifmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
-ifmodified reqidx size mtime = do
+ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo
+ifmodified reqidx mtime method = do
     date <- ifModifiedSince reqidx
-    return $ if date /= mtime
-             then unconditional reqidx size
-             else WithoutBody H.notModified304
-
-ifunmodified :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
-ifunmodified reqidx size mtime = do
+    -- According to RFC 9110:
+    -- "A recipient MUST ignore If-Modified-Since if the request
+    -- contains an If-None-Match header field; [...]"
+    guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch
+    -- "A recipient MUST ignore the If-Modified-Since header field
+    -- if [...] the request method is neither GET nor HEAD."
+    guard $ method == H.methodGet || method == H.methodHead
+    guard $ date == mtime || date > mtime
+    Just $ WithoutBody H.notModified304
+
+ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo
+ifunmodified reqidx mtime = do
     date <- ifUnmodifiedSince reqidx
-    return $ if date == mtime
-             then unconditional reqidx size
-             else WithoutBody H.preconditionFailed412
-
-ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo
-ifrange reqidx size mtime = do
+    -- According to RFC 9110:
+    -- "A recipient MUST ignore If-Unmodified-Since if the request
+    -- contains an If-Match header field; [...]"
+    guard . isNothing $ reqidx ! fromEnum ReqIfMatch
+    guard $ date /= mtime && date < mtime
+    Just $ WithoutBody H.preconditionFailed412
+
+-- TODO: Should technically also strongly match on ETags.
+ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo
+ifrange reqidx mtime method size = do
+    -- According to RFC 9110:
+    -- "When the method is GET and both Range and If-Range are
+    -- present, evaluate the If-Range precondition:"
     date <- ifRange reqidx
     rng  <- reqidx ! fromEnum ReqRange
-    return $ if date == mtime
-             then parseRange rng size
-             else WithBody H.ok200 [] 0 size
+    guard $ method == H.methodGet
+    return $
+        if date == mtime
+            then parseRange rng size
+            else WithBody H.ok200 [] 0 size
 
 unconditional :: IndexedHeader -> Integer -> RspFileInfo
-unconditional reqidx size = case reqidx ! fromEnum ReqRange of
-    Nothing  -> WithBody H.ok200 [] 0 size
-    Just rng -> parseRange rng size
+unconditional reqidx =
+    case reqidx ! fromEnum ReqRange of
+        Nothing  -> WithBody H.ok200 [] 0
+        Just rng -> parseRange rng
 
 ----------------------------------------------------------------
 

warp/Network/Wai/Handler/Warp/HTTP2/Response.hs

@@ -30,13 +30,13 @@ fromResponse settings ii req rsp = do
     rspst@(h2rsp, st, hasBody) <- case rsp of
       ResponseFile    st rsphdr path mpart -> do
           let rsphdr' = add date rsphdr
-          responseFile    st rsphdr' isHead path mpart ii reqhdr
+          responseFile    st rsphdr' method path mpart ii reqhdr
       ResponseBuilder st rsphdr builder -> do
           let rsphdr' = add date rsphdr
-          return $ responseBuilder st rsphdr' isHead builder
+          return $ responseBuilder st rsphdr' method builder
       ResponseStream  st rsphdr strmbdy -> do
           let rsphdr' = add date rsphdr
-          return $ responseStream  st rsphdr' isHead strmbdy
+          return $ responseStream  st rsphdr' method strmbdy
       _ -> error "ResponseRaw is not supported in HTTP/2"
     mh2data <- getHTTP2Data req
     case mh2data of
@@ -46,7 +46,7 @@ fromResponse settings ii req rsp = do
               !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers
           return (h2rsp', st, hasBody)
   where
-    !isHead = requestMethod req == H.methodHead
+    !method = requestMethod req
     !reqhdr = requestHeaders req
     !server = S.settingsServerName settings
     add date rsphdr =
@@ -58,59 +58,57 @@ fromResponse settings ii req rsp = do
 
 ----------------------------------------------------------------
 
-responseFile :: H.Status -> H.ResponseHeaders -> Bool
+responseFile :: H.Status -> H.ResponseHeaders -> H.Method
              -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders
              -> IO (H2.Response, H.Status, Bool)
 responseFile st rsphdr _ _ _ _ _
   | noBody st = return $ responseNoBody st rsphdr
 
-responseFile st rsphdr isHead path (Just fp) _ _ =
-    return $ responseFile2XX st rsphdr isHead fileSpec
+responseFile st rsphdr method path (Just fp) _ _ =
+    return $ responseFile2XX st rsphdr method fileSpec
   where
     !off'   = fromIntegral $ filePartOffset fp
     !bytes' = fromIntegral $ filePartByteCount fp
     !fileSpec = H2.FileSpec path off' bytes'
 
-responseFile _ rsphdr isHead path Nothing ii reqhdr = do
+responseFile _ rsphdr method path Nothing ii reqhdr = do
     efinfo <- UnliftIO.tryIO $ getFileInfo ii path
     case efinfo of
         Left (_ex :: UnliftIO.IOException) -> return $ response404 rsphdr
         Right finfo -> do
             let reqidx = indexRequestHeader reqhdr
                 rspidx = indexResponseHeader rsphdr
-            case conditionalRequest finfo rsphdr rspidx reqidx of
+            case conditionalRequest finfo rsphdr method rspidx reqidx of
                 WithoutBody s                -> return $ responseNoBody s rsphdr
                 WithBody s rsphdr' off bytes -> do
                     let !off'   = fromIntegral off
                         !bytes' = fromIntegral bytes
                         !fileSpec = H2.FileSpec path off' bytes'
-                    return $ responseFile2XX s rsphdr' isHead fileSpec
+                    return $ responseFile2XX s rsphdr' method fileSpec
 
 ----------------------------------------------------------------
 
-responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> (H2.Response, H.Status, Bool)
-responseFile2XX st rsphdr isHead fileSpec
-  | isHead = responseNoBody st rsphdr
+responseFile2XX :: H.Status -> H.ResponseHeaders -> H.Method -> H2.FileSpec -> (H2.Response, H.Status, Bool)
+responseFile2XX st rsphdr method fileSpec
+  | method == H.methodHead = responseNoBody st rsphdr
   | otherwise = (H2.responseFile st rsphdr fileSpec, st, True)
 
 ----------------------------------------------------------------
 
-responseBuilder :: H.Status -> H.ResponseHeaders -> Bool
+responseBuilder :: H.Status -> H.ResponseHeaders -> H.Method
                 -> BB.Builder
                 -> (H2.Response, H.Status, Bool)
-responseBuilder st rsphdr isHead builder
-  | noBody st = responseNoBody st rsphdr
-  | isHead    = responseNoBody st rsphdr
+responseBuilder st rsphdr method builder
+  | method == H.methodHead || noBody st = responseNoBody st rsphdr
   | otherwise = (H2.responseBuilder st rsphdr builder, st, True)
 
 ----------------------------------------------------------------
 
-responseStream :: H.Status -> H.ResponseHeaders -> Bool
+responseStream :: H.Status -> H.ResponseHeaders -> H.Method
                -> StreamingBody
                -> (H2.Response, H.Status, Bool)
-responseStream st rsphdr isHead strmbdy
-  | noBody st = responseNoBody st rsphdr
-  | isHead    = responseNoBody st rsphdr
+responseStream st rsphdr method strmbdy
+  | method == H.methodHead || noBody st = responseNoBody st rsphdr
   | otherwise = (H2.responseStreaming st rsphdr strmbdy, st, True)
 
 ----------------------------------------------------------------

warp/Network/Wai/Handler/Warp/Header.hs

@@ -31,35 +31,50 @@ data RequestHeaderIndex = ReqContentLength
                         | ReqIfRange
                         | ReqReferer
                         | ReqUserAgent
+                        | ReqIfMatch
+                        | ReqIfNoneMatch
                         deriving (Enum,Bounded)
 
 -- | The size for 'IndexedHeader' for HTTP Request.
---   From 0 to this corresponds to \"Content-Length\", \"Transfer-Encoding\",
---   \"Expect\", \"Connection\", \"Range\", \"Host\",
---   \"If-Modified-Since\", \"If-Unmodified-Since\" and \"If-Range\".
+--   From 0 to this corresponds to:
+--
+-- - \"Content-Length\"
+-- - \"Transfer-Encoding\"
+-- - \"Expect\"
+-- - \"Connection\"
+-- - \"Range\"
+-- - \"Host\"
+-- - \"If-Modified-Since\"
+-- - \"If-Unmodified-Since\"
+-- - \"If-Range\"
+-- - \"Referer\"
+-- - \"User-Agent\"
+-- - \"If-Match\"
+-- - \"If-None-Match\"
 requestMaxIndex :: Int
 requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)
 
 requestKeyIndex :: HeaderName -> Int
 requestKeyIndex hn = case BS.length bs of
-   4  -> if bs == "host" then fromEnum ReqHost else -1
-   5  -> if bs == "range" then fromEnum ReqRange else -1
-   6  -> if bs == "expect" then fromEnum ReqExpect else -1
-   7  -> if bs == "referer" then fromEnum ReqReferer else -1
-   8  -> if bs == "if-range" then fromEnum ReqIfRange else -1
-   10 -> if bs == "user-agent" then fromEnum ReqUserAgent else
-         if bs == "connection" then fromEnum ReqConnection else -1
-   14 -> if bs == "content-length" then fromEnum ReqContentLength else -1
-   17 -> if bs == "transfer-encoding" then fromEnum ReqTransferEncoding else
-         if bs == "if-modified-since" then fromEnum ReqIfModifiedSince
-         else -1
-   19 -> if bs == "if-unmodified-since" then fromEnum ReqIfUnmodifiedSince else -1
+   4  | bs == "host" -> fromEnum ReqHost
+   5  | bs == "range" -> fromEnum ReqRange
+   6  | bs == "expect" -> fromEnum ReqExpect
+   7  | bs == "referer" -> fromEnum ReqReferer
+   8  | bs == "if-range" -> fromEnum ReqIfRange
+      | bs == "if-match" -> fromEnum ReqIfMatch
+   10 | bs == "user-agent" -> fromEnum ReqUserAgent
+      | bs == "connection" -> fromEnum ReqConnection
+   13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch
+   14 | bs == "content-length" -> fromEnum ReqContentLength
+   17 | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding
+      | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince
+   19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince
    _  -> -1
   where
     bs = foldedCase hn
 
 defaultIndexRequestHeader :: IndexedHeader
-defaultIndexRequestHeader = array (0,requestMaxIndex) [(i,Nothing)|i<-[0..requestMaxIndex]]
+defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0..requestMaxIndex]]
 
 ----------------------------------------------------------------
 
@@ -78,10 +93,10 @@ responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)
 
 responseKeyIndex :: HeaderName -> Int
 responseKeyIndex hn = case BS.length bs of
-    4  -> if bs == "date" then fromEnum ResDate else -1
-    6  -> if bs == "server" then fromEnum ResServer else -1
-    13 -> if bs == "last-modified" then fromEnum ResLastModified else -1
-    14 -> if bs == "content-length" then fromEnum ResContentLength else -1
+    4  | bs == "date" -> fromEnum ResDate
+    6  | bs == "server" -> fromEnum ResServer
+    13 | bs == "last-modified" -> fromEnum ResLastModified
+    14 | bs == "content-length" -> fromEnum ResContentLength
     _  -> -1
   where
     bs = foldedCase hn