warp 3.3.29 → 3.3.30
raw patch · 11 files changed
+267/−134 lines, 11 filesdep ~wainew-uploader
Dependency ranges changed: wai
Files
- ChangeLog.md +11/−0
- Network/Wai/Handler/Warp/Counter.hs +1/−1
- Network/Wai/Handler/Warp/File.hs +58/−26
- Network/Wai/Handler/Warp/HTTP2/Response.hs +32/−30
- Network/Wai/Handler/Warp/Header.hs +35/−20
- Network/Wai/Handler/Warp/IO.hs +8/−9
- Network/Wai/Handler/Warp/Response.hs +25/−20
- test/FileSpec.hs +89/−16
- test/RunSpec.hs +0/−1
- test/WithApplicationSpec.hs +6/−9
- warp.cabal +2/−2
ChangeLog.md view
@@ -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.
Network/Wai/Handler/Warp/Counter.hs view
@@ -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
Network/Wai/Handler/Warp/File.hs view
@@ -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 ----------------------------------------------------------------
Network/Wai/Handler/Warp/HTTP2/Response.hs view
@@ -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) ----------------------------------------------------------------
Network/Wai/Handler/Warp/Header.hs view
@@ -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
Network/Wai/Handler/Warp/IO.hs view
@@ -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
Network/Wai/Handler/Warp/Response.hs view
@@ -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
test/FileSpec.hs view
@@ -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
test/RunSpec.hs view
@@ -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)
test/WithApplicationSpec.hs view
@@ -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--}
warp.cabal view
@@ -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)