diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -67,6 +67,7 @@ , exceptionResponseForDebug , defaultShouldDisplayException -- * Data types + , Transport (..) , HostPreference (..) , Port , InvalidRequest (..) diff --git a/Network/Wai/Handler/Warp/RequestHeader.hs b/Network/Wai/Handler/Warp/RequestHeader.hs --- a/Network/Wai/Handler/Warp/RequestHeader.hs +++ b/Network/Wai/Handler/Warp/RequestHeader.hs @@ -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) 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 @@ -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 diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -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 diff --git a/test/ResponseSpec.hs b/test/ResponseSpec.hs --- a/test/ResponseSpec.hs +++ b/test/ResponseSpec.hs @@ -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") diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -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