diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # ChangeLog for warp +## 3.3.30 + +* Length of `ResponseBuilder` responses will now also be passed to the logger. + [#946](https://github.com/yesodweb/wai/pull/946) +* Using `If-(None-)Match` headers simultaneously with `If-(Un)Modified-Since` headers now + follow the RFC 9110 standard. So `If-(Un)Modified-Since` headers will be correctly ignored + if their respective `-Match` counterpart is also present in the request headers. + [#945](https://github.com/yesodweb/wai/pull/945) +* Fixed adding superfluous `Server` header when using HTTP/2.0 if response already has it. + [#943](https://github.com/yesodweb/wai/pull/943) + ## 3.3.29 * Preparing coming "http2" v4.2.0. diff --git a/Network/Wai/Handler/Warp/Counter.hs b/Network/Wai/Handler/Warp/Counter.hs --- a/Network/Wai/Handler/Warp/Counter.hs +++ b/Network/Wai/Handler/Warp/Counter.hs @@ -21,7 +21,7 @@ waitForZero :: Counter -> IO () waitForZero (Counter ref) = atomically $ do x <- readTVar ref - unless (x == 0) retry + when (x > 0) retry increase :: Counter -> IO () increase (Counter ref) = atomically $ modifyTVar' ref $ \x -> x + 1 diff --git a/Network/Wai/Handler/Warp/File.hs b/Network/Wai/Handler/Warp/File.hs --- a/Network/Wai/Handler/Warp/File.hs +++ b/Network/Wai/Handler/Warp/File.hs @@ -35,22 +35,38 @@ 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 @@ ---------------------------------------------------------------- -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 + -- 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 -> Integer -> HTTPDate -> Maybe RspFileInfo -ifunmodified reqidx size mtime = do +ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo +ifunmodified reqidx mtime = do date <- ifUnmodifiedSince reqidx - return $ if date == mtime - then unconditional reqidx size - else WithoutBody H.preconditionFailed412 + -- 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 -ifrange :: IndexedHeader -> Integer -> HTTPDate -> Maybe RspFileInfo -ifrange reqidx size mtime = do +-- 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 ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/HTTP2/Response.hs b/Network/Wai/Handler/Warp/HTTP2/Response.hs --- a/Network/Wai/Handler/Warp/HTTP2/Response.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Response.hs @@ -6,17 +6,18 @@ fromResponse ) where -import qualified UnliftIO import qualified Data.ByteString.Builder as BB +import qualified Data.List as L (find) import qualified Network.HTTP.Types as H import qualified Network.HTTP2.Server as H2 import Network.Wai hiding (responseFile, responseBuilder, responseStream) import Network.Wai.Internal (Response(..)) +import qualified UnliftIO import Network.Wai.Handler.Warp.File +import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data) import Network.Wai.Handler.Warp.HTTP2.Types -import Network.Wai.Handler.Warp.Header import qualified Network.Wai.Handler.Warp.Response as R import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types @@ -28,14 +29,14 @@ date <- getDate ii rspst@(h2rsp, st, hasBody) <- case rsp of ResponseFile st rsphdr path mpart -> do - let rsphdr' = add date svr rsphdr - responseFile st rsphdr' isHead path mpart ii reqhdr + let rsphdr' = add date rsphdr + responseFile st rsphdr' method path mpart ii reqhdr ResponseBuilder st rsphdr builder -> do - let rsphdr' = add date svr rsphdr - return $ responseBuilder st rsphdr' isHead builder + let rsphdr' = add date rsphdr + return $ responseBuilder st rsphdr' method builder ResponseStream st rsphdr strmbdy -> do - let rsphdr' = add date svr rsphdr - return $ responseStream st rsphdr' isHead strmbdy + let rsphdr' = add date rsphdr + return $ responseStream st rsphdr' method strmbdy _ -> error "ResponseRaw is not supported in HTTP/2" mh2data <- getHTTP2Data req case mh2data of @@ -45,68 +46,69 @@ !h2rsp' = H2.setResponseTrailersMaker h2rsp trailers return (h2rsp', st, hasBody) where - !isHead = requestMethod req == H.methodHead + !method = requestMethod req !reqhdr = requestHeaders req - !svr = S.settingsServerName settings - add date server rsphdr = R.addAltSvc settings $ - (H.hDate, date) : (H.hServer, server) : rsphdr - -- fixme: not adding svr if already exists + !server = S.settingsServerName settings + add date rsphdr = + let hasServerHdr = L.find ((== H.hServer) . fst) rsphdr + addSVR = + maybe ((H.hServer, server) :) (const id) hasServerHdr + in R.addAltSvc settings $ + (H.hDate, date) : addSVR rsphdr ---------------------------------------------------------------- -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) ---------------------------------------------------------------- diff --git a/Network/Wai/Handler/Warp/Header.hs b/Network/Wai/Handler/Warp/Header.hs --- a/Network/Wai/Handler/Warp/Header.hs +++ b/Network/Wai/Handler/Warp/Header.hs @@ -31,35 +31,50 @@ | 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 @@ 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 diff --git a/Network/Wai/Handler/Warp/IO.hs b/Network/Wai/Handler/Warp/IO.hs --- a/Network/Wai/Handler/Warp/IO.hs +++ b/Network/Wai/Handler/Warp/IO.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Network.Wai.Handler.Warp.IO where import Control.Exception (mask_) @@ -10,19 +8,20 @@ import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types -toBufIOWith :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO () +toBufIOWith :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer toBufIOWith maxRspBufSize writeBufferRef io builder = do writeBuffer <- readIORef writeBufferRef - loop writeBuffer firstWriter + loop writeBuffer firstWriter 0 where firstWriter = runBuilder builder - loop writeBuffer writer = do + loop writeBuffer writer bytesSent = do let buf = bufBuffer writeBuffer size = bufSize writeBuffer (len, signal) <- writer buf size bufferIO buf len io + let totalBytesSent = toInteger len + bytesSent case signal of - Done -> return () + Done -> return totalBytesSent More minSize next | size < minSize -> do when (minSize > maxRspBufSize) $ @@ -40,8 +39,8 @@ biggerWriteBuffer <- createWriteBuffer minSize writeIORef writeBufferRef biggerWriteBuffer return biggerWriteBuffer - loop biggerWriteBuffer next - | otherwise -> loop writeBuffer next + loop biggerWriteBuffer next totalBytesSent + | otherwise -> loop writeBuffer next totalBytesSent Chunk bs next -> do io bs - loop writeBuffer next + loop writeBuffer next totalBytesSent diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -95,7 +95,7 @@ -- -- Simple applications should specify 'Nothing' to -- 'Maybe' 'FilePart'. The size of the specified file is obtained --- by disk access or from the file infor cache. +-- by disk access or from the file info cache. -- If-Modified-Since, If-Unmodified-Since, If-Range and Range -- are processed. Since a proper status is chosen, 'Status' is -- ignored. Last-Modified is inserted. @@ -118,14 +118,14 @@ -- and status, the response to HEAD is processed here. -- -- See definition of rsp below for proper body stripping. - (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize rsp + (ms, mlen) <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method rsp case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen T.tickle th return ret else do - _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize RspNoBody + _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody logger req s Nothing T.tickle th return isPersist @@ -142,7 +142,8 @@ (isPersist,isChunked0) = infoFromRequest req reqidxhdr isChunked = not isHead && isChunked0 (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist,isChunked) - isHead = requestMethod req == H.methodHead + method = requestMethod req + isHead = method == H.methodHead rsp = case response of ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr isHead (T.tickle th) ResponseBuilder _ _ b @@ -202,12 +203,13 @@ -> H.ResponseHeaders -> IndexedHeader -- Response -> Int -- maxBuilderResponseBufferSize + -> H.Method -> Rsp -> IO (Maybe H.Status, Maybe Integer) ---------------------------------------------------------------- -sendRsp conn _ _ ver s hs _ _ RspNoBody = do +sendRsp conn _ _ ver s hs _ _ _ RspNoBody = do -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn @@ -215,19 +217,19 @@ ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ maxRspBufSize (RspBuilder body needsChunked) = do +sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked let hdrBdy | needsChunked = header <> chunkedTransferEncoding body <> chunkedTransferTerminator | otherwise = header <> body writeBufferRef = connWriteBuffer conn - toBufIOWith maxRspBufSize writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy - return (Just s, Nothing) -- fixme: can we tell the actual sent bytes? + len <- toBufIOWith maxRspBufSize writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy + return (Just s, Just len) ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ _ (RspStream streamingBody needsChunked) = do +sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy $ toBuilderBuffer $ connWriteBuffer conn @@ -251,7 +253,7 @@ ---------------------------------------------------------------- -sendRsp conn _ th _ _ _ _ _ (RspRaw withApp src) = do +sendRsp conn _ th _ _ _ _ _ _ (RspRaw withApp src) = do withApp recv send return (Nothing, Nothing) where @@ -265,8 +267,8 @@ -- Sophisticated WAI applications. -- We respect s0. s0 MUST be a proper value. -sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize (RspFile path (Just part) _ isHead hook) = - sendRspFile2XX conn ii th ver s0 hs rspidxhdr maxRspBufSize path beg len isHead hook +sendRsp conn ii th ver s0 hs0 rspidxhdr maxRspBufSize method (RspFile path (Just part) _ isHead hook) = + sendRspFile2XX conn ii th ver s0 hs rspidxhdr maxRspBufSize method path beg len isHead hook where beg = filePartOffset part len = filePartByteCount part @@ -276,17 +278,17 @@ -- Simple WAI applications. -- Status is ignored -sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize (RspFile path Nothing reqidxhdr isHead hook) = do +sendRsp conn ii th ver _ hs0 rspidxhdr maxRspBufSize method (RspFile path Nothing reqidxhdr isHead hook) = do efinfo <- UnliftIO.tryIO $ getFileInfo ii path case efinfo of Left (_ex :: UnliftIO.IOException) -> #ifdef WARP_DEBUG print _ex >> #endif - sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize - Right finfo -> case conditionalRequest finfo hs0 rspidxhdr reqidxhdr of - WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize RspNoBody - WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize path beg len isHead hook + sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method + Right finfo -> case conditionalRequest finfo hs0 method rspidxhdr reqidxhdr of + WithoutBody s -> sendRsp conn ii th ver s hs0 rspidxhdr maxRspBufSize method RspNoBody + WithBody s hs beg len -> sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook ---------------------------------------------------------------- @@ -298,14 +300,15 @@ -> H.ResponseHeaders -> IndexedHeader -> Int + -> H.Method -> FilePath -> Integer -> Integer -> Bool -> IO () -> IO (Maybe H.Status, Maybe Integer) -sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize path beg len isHead hook - | isHead = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize RspNoBody +sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len isHead hook + | isHead = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody | otherwise = do lheader <- composeHeader ver s hs (mfd, fresher) <- getFd ii path @@ -321,8 +324,10 @@ -> H.ResponseHeaders -> IndexedHeader -> Int + -> H.Method -> IO (Maybe H.Status, Maybe Integer) -sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize = sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize (RspBuilder body True) +sendRspFile404 conn ii th ver hs0 rspidxhdr maxRspBufSize method = + sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method (RspBuilder body True) where s = H.notFound404 hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0 diff --git a/test/FileSpec.hs b/test/FileSpec.hs --- a/test/FileSpec.hs +++ b/test/FileSpec.hs @@ -2,44 +2,117 @@ module FileSpec (main, spec) where +import Data.ByteString +import Data.String (fromString) import Network.HTTP.Types import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header +import System.IO.Unsafe (unsafePerformIO) import Test.Hspec main :: IO () main = hspec spec +changeHeaders :: (ResponseHeaders -> ResponseHeaders) -> RspFileInfo -> RspFileInfo +changeHeaders f rfi = + case rfi of + WithBody s hs off len -> WithBody s (f hs) off len + other -> other + +getHeaders :: RspFileInfo -> ResponseHeaders +getHeaders rfi = + case rfi of + WithBody _ hs _ _ -> hs + _ -> [] + testFileRange :: String - -> RequestHeaders -> FilePath + -> RequestHeaders -> RspFileInfo -> Spec -testFileRange desc reqhs file ans = it desc $ do - finfo <- getInfo file - let WithBody s hs off len = ans - hs' = ("Last-Modified",fileInfoDate finfo) : hs - ans' = WithBody s hs' off len - conditionalRequest finfo [] (indexResponseHeader hs) (indexRequestHeader reqhs) `shouldBe` ans' +testFileRange desc reqhs ans = it desc $ do + finfo <- getInfo "attic/hex" + let f = (:) ("Last-Modified", fileInfoDate finfo) + hs = getHeaders ans + ans' = changeHeaders f ans + conditionalRequest + finfo + [] + methodGet + (indexResponseHeader hs) + (indexRequestHeader reqhs) `shouldBe` ans' +farPast, farFuture :: ByteString +farPast = "Thu, 01 Jan 1970 00:00:00 GMT" +farFuture = "Sun, 05 Oct 3000 00:00:00 GMT" + +regularBody :: RspFileInfo +regularBody = WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 + +make206Body :: Integer -> Integer -> RspFileInfo +make206Body start len = + WithBody status206 [crHeader, lenHeader, ("Accept-Ranges","bytes")] start len + where + lenHeader = ("Content-Length", fromString $ show len) + crHeader = ("Content-Range", fromString $ "bytes " <> show start <> "-" <> show (start + len - 1) <> "/16") + spec :: Spec spec = do describe "conditionalRequest" $ do testFileRange "gets a file size from file system" - [] "attic/hex" - $ WithBody ok200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 + [] + regularBody testFileRange "gets a file size from file system and handles Range and returns Partical Content" - [("Range","bytes=2-14")] "attic/hex" - $ WithBody status206 [("Content-Range","bytes 2-14/16"),("Content-Length","13"),("Accept-Ranges","bytes")] 2 13 + [("Range","bytes=2-14")] + $ make206Body 2 13 testFileRange "truncates end point of range to file size" - [("Range","bytes=10-20")] "attic/hex" - $ WithBody status206 [("Content-Range","bytes 10-15/16"),("Content-Length","6"),("Accept-Ranges","bytes")] 10 6 + [("Range","bytes=10-20")] + $ make206Body 10 6 testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire" - [("Range:","bytes=0-15")] "attic/hex" - $ WithBody status200 [("Content-Length","16"),("Accept-Ranges","bytes")] 0 16 - + [("Range:","bytes=0-15")] + regularBody + testFileRange + "returns a 412 if the file has been changed in the meantime" + [("If-Unmodified-Since", farPast)] + $ WithoutBody status412 + testFileRange + "gets a file if the file has not been changed in the meantime" + [("If-Unmodified-Since", farFuture)] + regularBody + testFileRange + "ignores the If-Unmodified-Since header if an If-Match header is also present" + [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast)] + regularBody + testFileRange + "still gives only a range, even after conditionals" + [("If-Match", "SomeETag"), ("If-Unmodified-Since", farPast), ("Range","bytes=10-20")] + $ make206Body 10 6 + testFileRange + "gets a file if the file has been changed in the meantime" + [("If-Modified-Since", farPast)] + regularBody + testFileRange + "returns a 304 if the file has not been changed in the meantime" + [("If-Modified-Since", farFuture)] + $ WithoutBody status304 + testFileRange + "ignores the If-Modified-Since header if an If-None-Match header is also present" + [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture)] + regularBody + testFileRange + "still gives only a range, even after conditionals" + [("If-None-Match", "SomeETag"), ("If-Modified-Since", farFuture), ("Range","bytes=10-13")] + $ make206Body 10 4 + testFileRange + "gives the a range, if the condition is met" + [("If-Range", fileInfoDate (unsafePerformIO $ getInfo "attic/hex")), ("Range","bytes=2-7")] + $ make206Body 2 6 + testFileRange + "gives the entire body and ignores the Range header if the condition isn't met" + [("If-Range", farPast), ("Range","bytes=2-7")] + regularBody diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -21,7 +21,6 @@ import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders) -import Network.Wai.Internal (getRequestBodyChunk) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) diff --git a/test/WithApplicationSpec.hs b/test/WithApplicationSpec.hs --- a/test/WithApplicationSpec.hs +++ b/test/WithApplicationSpec.hs @@ -11,11 +11,16 @@ import Network.Wai.Handler.Warp.WithApplication +-- All these tests assume the "curl" process can be called directly. spec :: Spec spec = do runIO $ do unsetEnv "http_proxy" unsetEnv "https_proxy" + describe "\"curl\" dependency" $ + let msg = "All \"WithApplication\" tests assume the \"curl\" process can be called directly." + underline = replicate (length msg) '^' + in it (msg ++ "\n " ++ underline) True describe "withApplication" $ do it "runs a wai Application while executing the given action" $ do let mkApp = return $ \ _request respond -> respond $ responseLBS ok200 [] "foo" @@ -32,14 +37,6 @@ describe "testWithApplication" $ do it "propagates exceptions from the server to the executing thread" $ do let mkApp = return $ \ _request _respond -> throwString "foo" - (testWithApplication mkApp $ \ port -> do + testWithApplication mkApp (\ port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "") `shouldThrow` (\(StringException str _) -> str == "foo") - -{- The future netwrok library will not export MkSocket. - describe "withFreePort" $ do - it "closes the socket before exiting" $ do - MkSocket _ _ _ _ statusMVar <- withFreePort $ \ (_, sock) -> do - return sock - readMVar statusMVar `shouldReturn` Closed --} diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.29 +Version: 3.3.30 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE @@ -212,7 +212,7 @@ , text , time-manager , vault - , wai >= 3.2 && < 3.3 + , wai >= 3.2.2.1 && < 3.3 , word8 , unliftio if flag(x509)