warp 3.2.26 → 3.2.27
raw patch · 11 files changed
+228/−115 lines, 11 filesdep −silentlydep ~http-types
Dependencies removed: silently
Dependency ranges changed: http-types
Files
- ChangeLog.md +12/−0
- Network/Wai/Handler/Warp/HTTP2/Receiver.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2/Worker.hs +7/−2
- Network/Wai/Handler/Warp/Run.hs +24/−14
- Network/Wai/Handler/Warp/Settings.hs +22/−4
- Network/Wai/Handler/Warp/Types.hs +14/−0
- test/ResponseHeaderSpec.hs +2/−2
- test/ResponseSpec.hs +12/−18
- test/RunSpec.hs +116/−56
- test/WithApplicationSpec.hs +10/−14
- warp.cabal +8/−4
ChangeLog.md view
@@ -1,3 +1,15 @@+## 3.2.27++* Internally, use `lookupEnv` instead of `getEnvironment` to get the+ value of the `PORT` environment variable+ [#736](https://github.com/yesodweb/wai/pull/736)+* Throw 413 for too large payload+* Throw 431 for too large headers+ [#741](https://github.com/yesodweb/wai/pull/741)+* Use exception response handler in HTTP/2 & improve connection preservation+ in HTTP/1.x if uncaught exceptions are thrown in an `Application`.+ [#738](https://github.com/yesodweb/wai/pull/738)+ ## 3.2.26 * Support network package version 3
Network/Wai/Handler/Warp/HTTP2/Receiver.hs view
@@ -171,7 +171,7 @@ E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease" else do -- consider the stream idle when (ftyp `notElem` [FrameHeaders,FramePriority]) $- E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idel stream: " `BS.append` C8.pack (show ftyp)+ E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp) when (ftyp == FrameHeaders) $ do writeIORef clientStreamId streamId cnt <- readIORef concurrency
Network/Wai/Handler/Warp/HTTP2/Worker.hs view
@@ -119,7 +119,7 @@ -- They also pass 'Response's from 'Application's to this function. -- This function enqueues commands for the HTTP/2 sender. response :: S.Settings -> Context -> Manager -> Responder-response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of+response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of ResponseStream s0 hs0 strmbdy | noBody s0 -> responseNoBody s0 hs0 | isHead -> responseNoBody s0 hs0@@ -255,7 +255,12 @@ return bs !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th) $ vault req !req' = req { vault = vaultValue, requestBody = body' }- app req' $ responder ii' reqvt tcont strm req'+ mr <- E.try $ app req' $ responder ii' reqvt tcont strm req'+ case mr of+ Right ok -> return ok+ Left e@(SomeException _)+ | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'+ | otherwise -> responder ii' reqvt tcont strm req' (S.settingsOnExceptionResponse set e) cont1 <- case ex of Right ResponseReceived -> return True Left e@(SomeException _)
Network/Wai/Handler/Warp/Run.hs view
@@ -23,7 +23,7 @@ import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived))-import System.Environment (getEnvironment)+import System.Environment (lookupEnv) import System.Timeout (timeout) import Network.Wai.Handler.Warp.Buffer@@ -80,7 +80,7 @@ -- Since 3.0.9 runEnv :: Port -> Application -> IO () runEnv p app = do- mp <- lookup "PORT" <$> getEnvironment+ mp <- lookupEnv "PORT" maybe (run p app) runReadPort mp @@ -293,7 +293,7 @@ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do let ii1 = toInternalInfo1 ii0 th -- We now have fully registered a connection close handler in- -- the case of all exceptions, so it is safe to one again+ -- the case of all exceptions, so it is safe to once again -- allow async exceptions. unmask . -- Call the user-supplied code for connection open and@@ -396,9 +396,11 @@ sendErrorResponse req istatus e = do status <- readIORef istatus- when (shouldSendErrorResponse e && status) $ do- let ii = toInternalInfo ii1 0 -- dummy- void $ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)+ if (shouldSendErrorResponse e && status)+ then do+ let ii = toInternalInfo ii1 0 -- dummy+ sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)+ else return False dummyreq addr = defaultRequest { remoteHost = addr } @@ -409,8 +411,6 @@ let req = req' { isSecure = isTransportSecure transport } keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii `E.catch` \e -> do- -- Call the user-supplied exception handlers, passing the request.- sendErrorResponse req istatus e settingsOnException settings (Just req) e -- Don't throw the error again to prevent calling settingsOnException twice. return False@@ -433,7 +433,7 @@ -- creating the request, we need to make sure that we don't get -- an async exception before calling the ResponseSource. keepAliveRef <- newIORef $ error "keepAliveRef not filled"- _ <- app req $ \res -> do+ r <- E.try $ app req $ \res -> do T.resume th -- FIXME consider forcing evaluation of the res here to -- send more meaningful error messages to the user.@@ -442,21 +442,29 @@ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res writeIORef keepAliveRef keepAlive return ResponseReceived+ case r of+ Right ResponseReceived -> return ()+ Left e@(SomeException _)+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'+ | otherwise -> do+ keepAlive <- sendErrorResponse req istatus e+ settingsOnException settings (Just req) e+ writeIORef keepAliveRef keepAlive+ keepAlive <- readIORef keepAliveRef -- We just send a Response and it takes a time to -- receive a Request again. If we immediately call recv,- -- it is likely to fail and the IO manager works.- -- It is very costly. So, we yield to another Haskell+ -- it is likely to fail and cause the IO manager to do some work.+ -- It is very costly, so we yield to another Haskell -- thread hoping that the next Request will arrive -- when this Haskell thread will be re-scheduled. -- This improves performance at least when -- the number of cores is small. Conc.yield - if not keepAlive then- return False- else+ if keepAlive+ then -- If there is an unknown or large amount of data to still be read -- from the request body, simple drop this connection instead of -- reading it all in to satisfy a keep-alive request.@@ -482,6 +490,8 @@ else return False Nothing -> tryKeepAlive+ else+ return False flushEntireBody :: IO ByteString -> IO () flushEntireBody src =
Network/Wai/Handler/Warp/Settings.hs view
@@ -8,12 +8,14 @@ import Control.Exception import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as C8+import Data.ByteString.Lazy (fromStrict) import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO import Data.Version (showVersion) import GHC.IO.Exception (IOErrorType(..)) import qualified Network.HTTP.Types as H+import Network.HTTP2( HTTP2Error (..), ErrorCodeId (..) ) import Network.Socket (SockAddr) import Network.Wai import qualified Paths_warp@@ -168,13 +170,29 @@ when (defaultShouldDisplayException e) $ TIO.hPutStrLn stderr $ T.pack $ show e --- | Sending 400 for bad requests. Sending 500 for internal server errors.---+-- | Sending 400 for bad requests.+-- Sending 500 for internal server errors. -- Since: 3.1.0+-- Sending 413 for too large payload.+-- Sending 431 for too large headers.+-- Since 3.2.27 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e- | Just (_ :: InvalidRequest) <- fromException e = responseLBS H.badRequest400 [(H.hContentType, "text/plain; charset=utf-8")] "Bad Request"- | otherwise = responseLBS H.internalServerError500 [(H.hContentType, "text/plain; charset=utf-8")] "Something went wrong"+ | Just (_ :: InvalidRequest) <-+ fromException e = responseLBS H.badRequest400+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Bad Request"+ | Just (ConnectionError (UnknownErrorCode 413) t) <-+ fromException e = responseLBS H.status413+ [(H.hContentType, "text/plain; charset=utf-8")]+ (fromStrict t)+ | Just (ConnectionError (UnknownErrorCode 431) t) <-+ fromException e = responseLBS H.status431+ [(H.hContentType, "text/plain; charset=utf-8")]+ (fromStrict t)+ | otherwise = responseLBS H.internalServerError500+ [(H.hContentType, "text/plain; charset=utf-8")]+ "Something went wrong" -- | Exception handler for the debugging purpose. -- 500, text/plain, a showed exception.
Network/Wai/Handler/Warp/Types.hs view
@@ -52,6 +52,20 @@ ---------------------------------------------------------------- +-- | Exception thrown if something goes wrong while in the midst of+-- sending a response, since the status code can't be altered at that+-- point.+--+-- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe+-- or irrecoverable.++newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody SomeException+ deriving (Show, Typeable)++instance Exception ExceptionInsideResponseBody++----------------------------------------------------------------+ -- | Data type to abstract file identifiers. -- On Unix, a file descriptor would be specified to make use of -- the file descriptor cache.
test/ResponseHeaderSpec.hs view
@@ -71,11 +71,11 @@ headers :: H.ResponseHeaders headers = [ ("Date", "Mon, 13 Aug 2012 04:22:55 GMT")- , ("Content-Lenght", "151")+ , ("Content-Length", "151") , ("Server", "Mighttpd/2.5.8") , ("Last-Modified", "Fri, 22 Jun 2012 01:18:08 GMT") , ("Content-Type", "text/html") ] composedHeader :: ByteString-composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Lenght: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"+composedHeader = "HTTP/1.1 200 OK\r\nDate: Mon, 13 Aug 2012 04:22:55 GMT\r\nContent-Length: 151\r\nServer: Mighttpd/2.5.8\r\nLast-Modified: Fri, 22 Jun 2012 01:18:08 GMT\r\nContent-Type: text/html\r\n\r\n"
test/ResponseSpec.hs view
@@ -10,13 +10,9 @@ import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response-import RunSpec (withApp)-import System.IO (hClose, hFlush)+import RunSpec (withApp, msClose, msWrite, msRead, connectTo) import Test.Hspec --- import HTTP-import RunSpec (connectTo)- main :: IO () main = hspec spec @@ -25,15 +21,14 @@ -> Maybe String -- ^ expected content-range value -> Spec testRange range out crange = it title $ withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port- S.hPutStr handle "GET / HTTP/1.0\r\n"- S.hPutStr handle "Range: bytes="- S.hPutStr handle range- S.hPutStr handle "\r\n\r\n"- hFlush handle+ handle <- connectTo port+ msWrite handle "GET / HTTP/1.0\r\n"+ msWrite handle "Range: bytes="+ msWrite handle range+ msWrite handle "\r\n\r\n" threadDelay 10000- bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024- hClose handle+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024+ msClose handle last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange@@ -52,12 +47,11 @@ -> String -- ^ expected output -> Spec testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port- S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"- hFlush handle+ handle <- connectTo port+ msWrite handle "GET / HTTP/1.0\r\n\r\n" threadDelay 10000- bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024- hClose handle+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024+ msClose handle out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
test/RunSpec.hs view
@@ -2,15 +2,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module RunSpec (main, spec, withApp, connectTo) where+module RunSpec (main, spec, withApp, connectTo, MySocket, msWrite, msRead, msClose) where import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent.STM import qualified Control.Exception as E import Control.Exception.Lifted (bracket, try, IOException, onException) import Control.Monad (forM_, replicateM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.ByteString (ByteString, hPutStr, hGetSome)+import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString) import qualified Data.ByteString.Char8 as S8@@ -22,7 +23,6 @@ import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp-import System.IO (hFlush, hClose, Handle, IOMode(..)) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec@@ -35,14 +35,45 @@ type Counter = I.IORef (Either String Int) type CounterApplication = Counter -> Application -connectTo :: HostName -> Int -> IO Handle-connectTo host port = do- let hints = defaultHints { addrSocketType = Stream }- addr:_ <- getAddrInfo (Just hints) (Just host) (Just $ show port)- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)- connect sock $ addrAddress addr- socketToHandle sock ReadWriteMode+data MySocket = MySocket+ { msSocket :: !Socket+ , _msBuffer :: !(I.IORef ByteString)+ } +msWrite :: MySocket -> ByteString -> IO ()+msWrite ms bs = sendAll (msSocket ms) bs++msRead :: MySocket -> Int -> IO ByteString+msRead (MySocket s ref) expected = do+ bs <- I.readIORef ref+ inner (bs:) (S.length bs)+ where+ inner front total =+ case compare total expected of+ EQ -> do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ GT -> do+ let bs = S.concat $ front []+ (x, y) = S.splitAt expected bs+ I.writeIORef ref y+ pure x+ LT -> do+ bs <- safeRecv s 4096+ if S.null bs+ then do+ I.writeIORef ref mempty+ pure $ S.concat $ front []+ else inner (front . (bs:)) (total + S.length bs)++msClose :: MySocket -> IO ()+msClose = Network.Socket.close . msSocket++connectTo :: Int -> IO MySocket+connectTo port = MySocket+ <$> (fst <$> getSocketTCP "127.0.0.1" port)+ <*> I.newIORef mempty+ incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> ((case ecount of@@ -105,7 +136,13 @@ bracket (forkIO $ runSettings settings' app `onException` putMVar baton ()) killThread- (const $ takeMVar baton >> f port)+ (const $ do+ takeMVar baton+ -- use timeout to make sure we don't take too long+ mres <- timeout (60 * 1000 * 1000) (f port)+ case mres of+ Nothing -> error "Timeout triggered, too slow!"+ Just a -> pure a) runTest :: Int -- ^ expected number of requests -> CounterApplication@@ -114,9 +151,9 @@ runTest expected app chunks = do ref <- I.newIORef (Right 0) withApp defaultSettings (app ref) $ \port -> do- handle <- connectTo "127.0.0.1" port- forM_ chunks $ \chunk -> hPutStr handle chunk >> hFlush handle- _ <- timeout 100000 $ replicateM_ expected $ hGetSome handle 4096+ ms <- connectTo port+ forM_ chunks $ \chunk -> msWrite ms chunk+ _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096 res <- I.readIORef ref case res of Left s -> error s@@ -132,10 +169,9 @@ ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do- handle <- connectTo "127.0.0.1" port- hPutStr handle input- hFlush handle- hClose handle+ handle <- connectTo port+ msWrite handle input+ msClose handle threadDelay 1000 res <- I.readIORef ref show res `shouldBe` show (Just expected)@@ -207,13 +243,12 @@ liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port+ handle <- connectTo port let input = S.concat [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" ]- hPutStr handle input- hFlush handle- hClose handle+ msWrite handle input+ msClose handle threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe`@@ -225,13 +260,12 @@ liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port+ handle <- connectTo port let input = S.concat [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" ]- hPutStr handle input- hFlush handle- hClose handle+ msWrite handle input+ msClose handle threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe`@@ -240,67 +274,83 @@ describe "chunked bodies" $ do it "works" $ do+ countVar <- newTVarIO (0 :: Int) ifront <- I.newIORef id let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port+ handle <- connectTo port let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ]- hPutStr handle input- hFlush handle- hClose handle- threadDelay 1000+ msWrite handle input+ msClose handle+ atomically $ do+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ]+#if !WINDOWS+-- Too slow on Windows it "lots of chunks" $ do ifront <- I.newIORef id+ countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ requestBody req I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port+ handle <- connectTo port let input = concat $ replicate 2 $ ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"] ++ (replicate 50 "5\r\n12345\r\n") ++ ["0\r\n\r\n"]- mapM_ (\bs -> hPutStr handle bs >> hFlush handle) input- hClose handle- threadDelay 100000 -- FIXME why does this delay need to be so high?+ mapM_ (msWrite handle) input+ msClose handle+ atomically $ do+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")+-- For some reason, the following test on Windows causes the socket+-- to be killed prematurely. Worth investigating in the future if possible. it "in chunks" $ do ifront <- I.newIORef id+ countVar <- newTVarIO (0 :: Int) let app req f = do bss <- consumeBody $ requestBody req liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ())+ atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port+ handle <- connectTo port let input = S.concat [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n" , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n" , "b\r\nHello World\r\n0\r\n\r\n" ]- mapM_ (\bs -> hPutStr handle bs >> hFlush handle) $ map S.singleton $ S.unpack input- hClose handle- threadDelay 1000+ mapM_ (msWrite handle) $ map S.singleton $ S.unpack input+ msClose handle+ atomically $ do+ count <- readTVar countVar+ check $ count == 2 front <- I.readIORef ifront front [] `shouldBe` [ "Hello World\nBye" , "Hello World" ]+#endif it "timeout in request body" $ do ifront <- I.newIORef id let app req f = do@@ -317,16 +367,16 @@ let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2- handle <- connectTo "127.0.0.1" port- hPutStr handle "POST / HTTP/1.1\r\n"- hPutStr handle "content-length: "- hPutStr handle $ S8.pack $ show $ S.length bs- hPutStr handle "\r\n\r\n"+ handle <- connectTo port+ msWrite handle "POST / HTTP/1.1\r\n"+ msWrite handle "content-length: "+ msWrite handle $ S8.pack $ show $ S.length bs+ msWrite handle "\r\n\r\n" threadDelay 100000- hPutStr handle bs1+ msWrite handle bs1 threadDelay 100000- hPutStr handle bs2- hClose handle+ msWrite handle bs2+ msClose handle threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs@@ -343,30 +393,36 @@ loop doubleBS = S.concatMap $ \w -> S.pack [w, w] withApp defaultSettings app $ \port -> do- handle <- connectTo "127.0.0.1" port- hPutStr handle "POST / HTTP/1.1\r\n\r\n12345"- hFlush handle- timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "1122334455")- hPutStr handle "67890"- hFlush handle- timeout 100000 (S.hGet handle 10) >>= (`shouldBe` Just "6677889900")+ ms <- connectTo port+ msWrite ms "POST / HTTP/1.1\r\n\r\n12345"+ timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455")+ msWrite ms "67890"+ timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "6677889900") +#if !WINDOWS+-- No idea why this test is so unreliable on Windows+-- It fails in multiple ways on CI it "only one date and server header" $ do let app _ f = f $ responseLBS status200 [ ("server", "server") , ("date", "date") ] ""+ getValues key = map snd+ . filter (\(key', _) -> key == key')+ . responseHeaders withApp defaultSettings app $ \port -> do res <- sendGET $ "http://127.0.0.1:" ++ show port- getHeaderValue hServer (responseHeaders res) `shouldBe` Just "server"- getHeaderValue hDate (responseHeaders res) `shouldBe` Just "date"+ getValues hServer res `shouldBe` ["server"]+ getValues hDate res `shouldBe` ["date"] it "streaming echo #249" $ do+ countVar <- newTVarIO (0 :: Int) let app req f = f $ responseStream status200 [] $ \write _ -> do let loop = do bs <- requestBody req unless (S.null bs) $ do write $ byteString bs+ atomically $ modifyTVar countVar (+ 1) loop loop withApp defaultSettings app $ \port -> do@@ -374,8 +430,12 @@ sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" threadDelay 10000 sendAll sock "5\r\nhello\r\n0\r\n\r\n"+ atomically $ do+ count <- readTVar countVar+ check $ count >= 1 bs <- safeRecv sock 4096 S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"+#endif it "streaming response with length" $ do let app _ f = f $ responseStream status200 [("content-length", "20")] $ \write _ -> do
test/WithApplicationSpec.hs view
@@ -6,8 +6,6 @@ import Network.HTTP.Types import Network.Wai import System.Environment-import System.IO-import System.IO.Silently import System.Process import Test.Hspec @@ -25,20 +23,18 @@ output <- readProcess "curl" ["-s", "localhost:" ++ show port] "" output `shouldBe` "foo" - it "does not propagate exceptions from the server to the executing thread" $- hSilence [stderr] $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"- withApplication mkApp $ \ port -> do- output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldContain` "Something went wron"+ it "does not propagate exceptions from the server to the executing thread" $ do+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ withApplication mkApp $ \ port -> do+ output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""+ output `shouldContain` "Something went wron" describe "testWithApplication" $ do- it "propagates exceptions from the server to the executing thread" $- hSilence [stderr] $ do- let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"- (testWithApplication mkApp $ \ port -> do- readProcess "curl" ["-s", "localhost:" ++ show port] "")- `shouldThrow` (errorCall "foo")+ it "propagates exceptions from the server to the executing thread" $ do+ let mkApp = return $ \ _request _respond -> throwIO $ ErrorCall "foo"+ (testWithApplication mkApp $ \ port -> do+ readProcess "curl" ["-s", "localhost:" ++ show port] "")+ `shouldThrow` (errorCall "foo") {- The future netwrok library will not export MkSocket. describe "withFreePort" $ do
warp.cabal view
@@ -1,5 +1,5 @@ Name: warp-Version: 3.2.26+Version: 3.2.27 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE@@ -120,6 +120,8 @@ Main-Is: doctests.hs Build-Depends: base >= 4.8 && < 5 , doctest >= 0.10.1+ if os(windows)+ Buildable: False Test-Suite spec Main-Is: Spec.hs@@ -171,6 +173,7 @@ Network.Wai.Handler.Warp.Settings Network.Wai.Handler.Warp.Timeout Network.Wai.Handler.Warp.Types+ Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication Paths_warp @@ -200,7 +203,6 @@ , time , text , streaming-commons >= 0.1.10- , silently , async , vault , stm >= 2.3@@ -219,7 +221,8 @@ Cpp-Options: -DSENDFILEFD Build-Depends: unix if os(windows)- Cpp-Options: -DWINDOWS+ Cpp-Options: -DWINDOWS+ Build-Depends: time Benchmark parser Type: exitcode-stdio-1.0@@ -251,7 +254,8 @@ Cpp-Options: -DSENDFILEFD Build-Depends: unix if os(windows)- Cpp-Options: -DWINDOWS+ Cpp-Options: -DWINDOWS+ Build-Depends: time Source-Repository head Type: git