warp 3.0.7 → 3.0.8
raw patch · 7 files changed
+95/−70 lines, 7 files
Files
- Network/Wai/Handler/Warp.hs +1/−0
- Network/Wai/Handler/Warp/RequestHeader.hs +13/−15
- Network/Wai/Handler/Warp/Response.hs +31/−27
- Network/Wai/Handler/Warp/Run.hs +17/−17
- Network/Wai/Handler/Warp/Types.hs +19/−3
- test/ResponseSpec.hs +13/−7
- warp.cabal +1/−1
Network/Wai/Handler/Warp.hs view
@@ -67,6 +67,7 @@ , exceptionResponseForDebug , defaultShouldDisplayException -- * Data types+ , Transport (..) , HostPreference (..) , Port , InvalidRequest (..)
Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -137,23 +137,21 @@ (r, bs3) <- range bs2 ranges (r:) bs3 where- range bs2 =- case stripPrefix "-" bs2 of- Just bs3 -> do- (i, bs4) <- B.readInteger bs3- Just (HH.ByteRangeSuffix i, bs4)- Nothing -> do- (i, bs3) <- B.readInteger bs2+ range bs2 = do+ (i, bs3) <- B.readInteger bs2+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")+ then Just (HH.ByteRangeSuffix (negate i), bs3)+ else do bs4 <- stripPrefix "-" bs3 case B.readInteger bs4 of- Nothing -> Just (HH.ByteRangeFrom i, bs4)- Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)- ranges front bs3 =- case stripPrefix "," bs3 of- Nothing -> Just (front [])- Just bs4 -> do- (r, bs5) <- range bs4- ranges (front . (r:)) bs5+ Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5)+ _ -> Just (HH.ByteRangeFrom i, bs4)+ ranges front bs3 + | S.null bs3 = Just (front [])+ | otherwise = do+ bs4 <- stripPrefix "," bs3+ (r, bs5) <- range bs4+ ranges (front . (r:)) bs5 stripPrefix x y | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)
Network/Wai/Handler/Warp/Response.hs view
@@ -30,9 +30,9 @@ import Data.List (deleteBy) import Data.Maybe (isJust, listToMaybe) #if MIN_VERSION_base(4,5,0)-import Data.Monoid ((<>))+import Data.Monoid ((<>), mempty) #else-import Data.Monoid (mappend)+import Data.Monoid (mappend, mempty) #endif import Data.Version (showVersion) import qualified Network.HTTP.Types as H@@ -109,8 +109,8 @@ isEntire = beg == 0 && len == fileSize checkRange (H.ByteRangeFrom beg) = fromRange beg (fileSize - 1)- checkRange (H.ByteRangeFromTo beg end) = fromRange beg end- checkRange (H.ByteRangeSuffix count) = fromRange (fileSize - count) (fileSize - 1)+ checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (fileSize - 1) end)+ checkRange (H.ByteRangeSuffix count) = fromRange (max 0 (fileSize - count)) (fileSize - 1) fromRange beg end = (beg, end, len, isEntire) where@@ -153,14 +153,15 @@ -- Status is also changed to 206 if necessary. -- -- ['responseBuilder' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Builder' -> 'Response']--- HTTP response body is created from 'Source'.--- Typically, Transfer-Encoding: chunked is used.--- If Content-Length is specified, Transfer-Encoding: chunked is not used.+-- HTTP response body is created from 'Builder'.+-- Transfer-Encoding: chunked is used in HTTP/1.1. ----- ['responseSource' :: 'H.Status' -> 'H.ResponseHeaders' -> 'Source' 'IO' ('Flush' 'Builder') -> 'Response']+-- ['responseStream' :: 'H.Status' -> 'H.ResponseHeaders' -> 'StreamingBody' -> 'Response'] -- HTTP response body is created from 'Builder'.--- Typically, Transfer-Encoding: chunked is used.--- If Content-Length is specified, Transfer-Encoding: chunked is not used.+-- Transfer-Encoding: chunked is used in HTTP/1.1.+--+-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']+-- No header is added and no Transfer-Encoding: is applied. sendResponse :: ByteString -- ^ default server value -> Connection@@ -225,9 +226,11 @@ print _ex >> #endif sendRsp conn ver s2 hs2 (RspBuilder body True)- Right (s, hs1, beg, len) -> do+ Right (s, hs1, beg, len) | len > 0 -> do lheader <- composeHeader ver s hs1 connSendFile conn path beg len hook [lheader]+ | otherwise -> do+ sendRsp conn ver H.status416 hs1 (RspBuilder mempty True) where hs = addAcceptRanges hs0 s2 = H.status404@@ -248,26 +251,26 @@ ---------------------------------------------------------------- -sendRsp conn ver s hs (RspStream withBodyFlush needsChunked th) = do+sendRsp conn ver s hs (RspStream streamingBody needsChunked th) = do header <- composeHeaderBuilder ver s hs needsChunked (recv, finish) <- newBlazeRecv $ reuseBufferStrategy $ toBlazeBuffer (connWriteBuffer conn) (connBufferSize conn)- let addChunk builder = do+ let send builder = do popper <- recv builder let loop = do bs <- popper unless (S.null bs) $ do- connSink conn th bs+ sendFragment conn th bs loop loop- addChunk'- | needsChunked = addChunk . chunkedTransferEncoding- | otherwise = addChunk- addChunk header- withBodyFlush addChunk' (addChunk' flush)- when needsChunked $ addChunk chunkedTransferTerminator+ sendChunk+ | needsChunked = send . chunkedTransferEncoding+ | otherwise = send+ send header+ streamingBody sendChunk (sendChunk flush)+ when needsChunked $ send chunkedTransferTerminator mbs <- finish- maybe (return ()) (connSink conn th) mbs+ maybe (return ()) (sendFragment conn th) mbs ---------------------------------------------------------------- @@ -293,8 +296,8 @@ ---------------------------------------------------------------- -- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> ByteString -> IO ()-connSink Connection { connSendAll = send } th bs = do+sendFragment :: Connection -> T.Handle -> ByteString -> IO ()+sendFragment Connection { connSendAll = send } th bs = do T.resume th send bs T.pause th@@ -373,11 +376,12 @@ range = B.pack -- building with ShowS $ 'b' : 'y': 't' : 'e' : 's' : ' '- : showInt beg- ( '-'- : showInt end+ : (if beg > end then ('*':) else+ (showInt beg)+ . ('-' :)+ . (showInt end)) ( '/'- : showInt total ""))+ : showInt total "") addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of
Network/Wai/Handler/Warp/Run.hs view
@@ -124,7 +124,7 @@ runSettingsConnectionMaker x y = runSettingsConnectionMakerSecure x (go y) where- go = fmap (first (fmap (, False)))+ go = fmap (first (fmap (, TCP))) ---------------------------------------------------------------- @@ -132,7 +132,7 @@ -- which will return 'Connection'. -- -- Since 2.1.4-runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO ()+runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () runSettingsConnectionMakerSecure set getConnMaker app = do settingsBeforeMainLoop set counter <- newCounter@@ -169,7 +169,7 @@ -- -- Our approach is explained in the comments below. acceptConnection :: Settings- -> IO (IO (Connection, Bool), SockAddr)+ -> IO (IO (Connection, Transport), SockAddr) -> Application -> D.DateCache -> Maybe F.MutableFdCache@@ -220,7 +220,7 @@ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork :: Settings- -> IO (Connection, Bool)+ -> IO (Connection, Transport) -> SockAddr -> Application -> D.DateCache@@ -239,7 +239,7 @@ -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked.- bracket mkConn closeConn $ \(conn0, isSecure') ->+ bracket mkConn closeConn $ \(conn0, transport) -> -- We need to register a timeout handler for this thread, and -- cancel that handler as soon as we exit.@@ -260,9 +260,9 @@ -- Actually serve this connection. -- bracket with closeConn above ensures the connection is closed.- when goingon $ serveConnection conn ii addr isSecure' set app+ when goingon $ serveConnection conn ii addr transport set app where- closeConn (conn, _isSecure) = connClose conn+ closeConn (conn, _transport) = connClose conn onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr@@ -270,15 +270,15 @@ serveConnection :: Connection -> InternalInfo -> SockAddr- -> Bool -- ^ is secure?+ -> Transport -> Settings -> Application -> IO ()-serveConnection conn ii origAddr isSecure' settings app = do+serveConnection conn ii origAddr transport settings app = do istatus <- newIORef False src <- mkSource (connSource conn th istatus) addr <- getProxyProtocolAddr src- recvSendLoop addr istatus src `E.catch` \e -> do+ http1 addr istatus src `E.catch` \e -> do sendErrorResponse addr istatus e throwIO (e :: SomeException) @@ -336,19 +336,19 @@ errorResponse e = settingsOnExceptionResponse settings e - recvSendLoop addr istatus fromClient = do- (req', mremainingRef, idxhdr) <- recvRequest settings conn ii addr fromClient- let req = req' { isSecure = isSecure' }- keepAlive <- processRequest istatus fromClient req mremainingRef idxhdr+ http1 addr istatus src = do+ (req', mremainingRef, idxhdr) <- recvRequest settings conn ii addr src+ let req = req' { isSecure = isTransportSecure transport }+ keepAlive <- processRequest istatus src req mremainingRef idxhdr `E.catch` \e -> do -- Call the user-supplied exception handlers, passing the request. sendErrorResponse addr istatus e onE settings (Just req) e -- Don't throw the error again to prevent calling onE twice. return False- when keepAlive $ recvSendLoop addr istatus fromClient+ when keepAlive $ http1 addr istatus src - processRequest istatus fromClient req mremainingRef idxhdr = do+ processRequest istatus src req mremainingRef idxhdr = do -- Let the application run for as long as it wants T.pause th @@ -364,7 +364,7 @@ writeIORef istatus False keepAlive <- sendResponse (settingsServerName settings)- conn ii req idxhdr (readSource fromClient) res+ conn ii req idxhdr (readSource src) res writeIORef keepAliveRef keepAlive return ResponseReceived keepAlive <- readIORef keepAliveRef
Network/Wai/Handler/Warp/Types.hs view
@@ -6,15 +6,16 @@ import Control.Exception import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.Typeable (Typeable)+import Data.Word (Word16) import Network.HTTP.Types.Header import Network.Socket (Socket)+import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize) import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F import qualified Network.Wai.Handler.Warp.Timeout as T-import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)-import qualified Data.ByteString as S-import Data.IORef (IORef, readIORef, writeIORef, newIORef) ---------------------------------------------------------------- @@ -120,3 +121,18 @@ readLeftoverSource :: Source -> IO ByteString readLeftoverSource (Source ref _) = readIORef ref++----------------------------------------------------------------++-- | What kind of transport is used for this connection?+data Transport = TCP -- ^ Plain channel: TCP+ | TLS {+ tlsMajorVersion :: Int+ , tlsMinorVersion :: Int+ , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301+ , tlsChiperID :: Word16+ } -- ^ Encrypted channel: TLS or SSL++isTransportSecure :: Transport -> Bool+isTransportSecure TCP = False+isTransportSecure _ = True
test/ResponseSpec.hs view
@@ -19,7 +19,7 @@ testRange :: S.ByteString -- ^ range value -> String -- ^ expected output- -> String -- ^ expected content-range value+ -> Maybe String -- ^ expected content-range value -> Spec testRange range out crange = it title $ withApp defaultSettings app $ \port -> do handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port@@ -31,9 +31,9 @@ threadDelay 10000 bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024 hClose handle- out `shouldBe` last bss+ last bss `shouldBe` out let hs = mapMaybe toHeader bss- lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange)+ lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) where app _ = ($ responseFile status200 [] "attic/hex" Nothing)@@ -83,10 +83,12 @@ spec :: Spec spec = do describe "range requests" $ do- testRange "2-3" "23" "2-3/16"- testRange "5-" "56789abcdef" "5-15/16"- testRange "5-8" "5678" "5-8/16"- testRange "-3" "def" "13-15/16"+ testRange "2-3" "23" $ Just "2-3/16"+ testRange "5-" "56789abcdef" $ Just "5-15/16"+ testRange "5-8" "5678" $ Just "5-8/16"+ testRange "-3" "def" $ Just "13-15/16"+ testRange "16-" "" $ Just "*/16"+ testRange "-17" "0123456789abcdef" Nothing describe "partial files" $ do testPartial 16 2 2 "23"@@ -114,6 +116,10 @@ "gets a file size from file system and handles Range and returns Partical Content" status200 [] "attic/hex" Nothing (Just "bytes=2-14") $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13")],2,13)+ testFileRange+ "truncates end point of range to file size"+ status200 [] "attic/hex" Nothing (Just "bytes=10-20")+ $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6")],10,6) testFileRange "gets a file size from file system and handles Range and returns OK if Range means the entire" status200 [] "attic/hex" Nothing (Just "bytes=0-15")
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.0.7+Version: 3.0.8 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE