diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 3.3.1 + +* Using gracefullClose of network 3.1.1 or later if available. +* If the first line of an HTTP request is really invalid, + don't send an error response + ## 3.3.0 * Switching from the original implementation to HTTP/2 server library. diff --git a/Network/Wai/Handler/Warp/Recv.hs b/Network/Wai/Handler/Warp/Recv.hs --- a/Network/Wai/Handler/Warp/Recv.hs +++ b/Network/Wai/Handler/Warp/Recv.hs @@ -17,7 +17,12 @@ import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, castPtr, plusPtr) import GHC.Conc (threadWaitRead) -import Network.Socket (Socket, fdSocket) +import Network.Socket (Socket) +#if MIN_VERSION_network(3,1,0) +import Network.Socket (withFdSocket) +#else +import Network.Socket (fdSocket) +#endif import System.Posix.Types (Fd(..)) import Network.Wai.Handler.Warp.Buffer @@ -91,7 +96,9 @@ receive :: Socket -> BufferPool -> Recv receive sock pool = withBufferPool pool $ \ (ptr, size) -> do -#if MIN_VERSION_network(3,0,0) +#if MIN_VERSION_network(3,1,0) + withFdSocket sock $ \fd -> do +#elif MIN_VERSION_network(3,0,0) fd <- fdSocket sock #else let fd = fdSocket sock @@ -101,7 +108,9 @@ receiveBuf :: Socket -> RecvBuf receiveBuf sock buf0 siz0 = do -#if MIN_VERSION_network(3,0,0) +#if MIN_VERSION_network(3,1,0) + withFdSocket sock $ \fd -> do +#elif MIN_VERSION_network(3,0,0) fd <- fdSocket sock #else let fd = fdSocket sock 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 @@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Network.Wai.Handler.Warp.Run where @@ -22,6 +23,9 @@ import GHC.IO.Exception (IOException(..)) import qualified Network.HTTP2 as H2 import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) +#if MIN_VERSION_network(3,1,1) +import Network.Socket (gracefulClose) +#endif import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived)) @@ -63,7 +67,11 @@ connSendMany = Sock.sendMany s , connSendAll = sendall , connSendFile = sendFile s writeBuf bufferSize sendall +#if MIN_VERSION_network(3,1,1) + , connClose = gracefulClose s 5000 +#else , connClose = close s +#endif , connFree = freeBuffer writeBuf , connRecv = receive s bufferPool , connRecvBuf = receiveBuf s @@ -343,13 +351,16 @@ leftoverSource src bs addr <- getProxyProtocolAddr src http1 True addr istatus src `E.catch` \e -> - case fromException e of - -- See comment below referencing - -- https://github.com/yesodweb/wai/issues/618 - Just NoKeepAliveRequest -> return () - Nothing -> do - _ <- sendErrorResponse (dummyreq addr) istatus e - throwIO e + case () of + () + -- See comment below referencing + -- https://github.com/yesodweb/wai/issues/618 + | Just NoKeepAliveRequest <- fromException e -> return () + -- No valid request + | Just (BadFirstLine _) <- fromException e -> return () + | otherwise -> do + _ <- sendErrorResponse (dummyreq addr) istatus e + throwIO e where getProxyProtocolAddr src = diff --git a/test/ResponseSpec.hs b/test/ResponseSpec.hs --- a/test/ResponseSpec.hs +++ b/test/ResponseSpec.hs @@ -10,7 +10,7 @@ import Network.Wai hiding (responseHeaders) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Response -import RunSpec (withApp, msClose, msWrite, msRead, connectTo) +import RunSpec (withApp, msWrite, msRead, withMySocket) import Test.Hspec main :: IO () @@ -20,15 +20,13 @@ -> String -- ^ expected output -> Maybe String -- ^ expected content-range value -> Spec -testRange range out crange = it title $ withApp defaultSettings app $ \port -> do - handle <- connectTo port - msWrite handle "GET / HTTP/1.0\r\n" - msWrite handle "Range: bytes=" - msWrite handle range - msWrite handle "\r\n\r\n" +testRange range out crange = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.0\r\n" + msWrite ms "Range: bytes=" + msWrite ms range + msWrite ms "\r\n\r\n" threadDelay 10000 - bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024 - msClose handle + bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 last bss `shouldBe` out let hs = mapMaybe toHeader bss lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange @@ -46,12 +44,10 @@ -> Integer -- ^ byte count -> String -- ^ expected output -> Spec -testPartial size offset count out = it title $ withApp defaultSettings app $ \port -> do - handle <- connectTo port - msWrite handle "GET / HTTP/1.0\r\n\r\n" +testPartial size offset count out = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.0\r\n\r\n" threadDelay 10000 - bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead handle 1024 - msClose handle + bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024 out `shouldBe` last bss let hs = mapMaybe toHeader bss lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss) diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module RunSpec (main, spec, withApp, connectTo, MySocket, msWrite, msRead, msClose) where +module RunSpec (main, spec, withApp, MySocket, msWrite, msRead, withMySocket) where import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) @@ -37,7 +37,7 @@ data MySocket = MySocket { msSocket :: !Socket - , _msBuffer :: !(I.IORef ByteString) + , msBuffer :: !(I.IORef ByteString) } msWrite :: MySocket -> ByteString -> IO () @@ -70,10 +70,17 @@ msClose = Network.Socket.close . msSocket connectTo :: Int -> IO MySocket -connectTo port = MySocket - <$> (fst <$> getSocketTCP "127.0.0.1" port) - <*> I.newIORef mempty +connectTo port = do + s <- fst <$> getSocketTCP "127.0.0.1" port + ref <- I.newIORef mempty + return MySocket { + msSocket = s + , msBuffer = ref + } +withMySocket :: (MySocket -> IO a) -> Int -> IO a +withMySocket body port = bracket (connectTo port) msClose body + incr :: MonadIO m => Counter -> m () incr icount = liftIO $ I.atomicModifyIORef icount $ \ecount -> ((case ecount of @@ -150,8 +157,7 @@ -> IO () runTest expected app chunks = do ref <- I.newIORef (Right 0) - withApp defaultSettings (app ref) $ \port -> do - ms <- connectTo port + withApp defaultSettings (app ref) $ withMySocket $ \ms -> do forM_ chunks $ \chunk -> msWrite ms chunk _ <- timeout 100000 $ replicateM_ expected $ msRead ms 4096 res <- I.readIORef ref @@ -168,10 +174,9 @@ runTerminateTest expected input = do ref <- I.newIORef Nothing let onExc _ = I.writeIORef ref . Just - withApp (setOnException onExc defaultSettings) dummyApp $ \port -> do - handle <- connectTo port - msWrite handle input - msClose handle + withApp (setOnException onExc defaultSettings) dummyApp $ withMySocket $ \ms -> do + msWrite ms input + msClose ms -- explicitly threadDelay 1000 res <- I.readIORef ref show res `shouldBe` show (Just expected) @@ -242,13 +247,11 @@ let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "GET / HTTP/1.1\r\nfoo: bar\r\n baz\r\n\tbin\r\n\r\n" ] - msWrite handle input - msClose handle + msWrite ms input threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe` @@ -259,13 +262,11 @@ let app req f = do liftIO $ I.writeIORef iheaders $ requestHeaders req f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do let input = S.concat [ "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n" ] - msWrite handle input - msClose handle + msWrite ms input threadDelay 1000 headers <- I.readIORef iheaders headers `shouldBe` @@ -281,16 +282,14 @@ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do 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" ] - msWrite handle input - msClose handle + msWrite ms input atomically $ do count <- readTVar countVar check $ count == 2 @@ -307,14 +306,12 @@ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do 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_ (msWrite handle) input - msClose handle + mapM_ (msWrite ms) input atomically $ do count <- readTVar countVar check $ count == 2 @@ -330,16 +327,14 @@ liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) atomically $ modifyTVar countVar (+ 1) f $ responseLBS status200 [] "" - withApp defaultSettings app $ \port -> do - handle <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do 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_ (msWrite handle) $ map S.singleton $ S.unpack input - msClose handle + mapM_ (msWrite ms) $ map S.singleton $ S.unpack input atomically $ do count <- readTVar countVar check $ count == 2 @@ -360,20 +355,18 @@ E.throwIO (e :: E.SomeException) liftIO $ I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss:), ()) f $ responseLBS status200 [] "" - withApp (setTimeout 1 defaultSettings) app $ \port -> do + withApp (setTimeout 1 defaultSettings) app $ withMySocket $ \ms -> do let bs1 = S.replicate 2048 88 bs2 = "This is short" bs = S.append bs1 bs2 - 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" + msWrite ms "POST / HTTP/1.1\r\n" + msWrite ms "content-length: " + msWrite ms $ S8.pack $ show $ S.length bs + msWrite ms "\r\n\r\n" threadDelay 100000 - msWrite handle bs1 + msWrite ms bs1 threadDelay 100000 - msWrite handle bs2 - msClose handle + msWrite ms bs2 threadDelay 5000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs @@ -389,8 +382,7 @@ loop loop doubleBS = S.concatMap $ \w -> S.pack [w, w] - withApp defaultSettings app $ \port -> do - ms <- connectTo port + withApp defaultSettings app $ withMySocket $ \ms -> do msWrite ms "POST / HTTP/1.1\r\n\r\n12345" timeout 100000 (msRead ms 10) >>= (`shouldBe` Just "1122334455") msWrite ms "67890" @@ -418,15 +410,14 @@ atomically $ modifyTVar countVar (+ 1) loop loop - withApp defaultSettings app $ \port -> do - (sock, _addr) <- getSocketTCP "127.0.0.1" port - sendAll sock "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n" + withApp defaultSettings app $ withMySocket $ \ms -> do + msWrite ms "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" + msWrite ms "5\r\nhello\r\n0\r\n\r\n" atomically $ do count <- readTVar countVar check $ count >= 1 - bs <- safeRecv sock 4096 + bs <- safeRecv (msSocket ms) 4096 -- must not use msRead S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" it "streaming response with length" $ do diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.3.0 +Version: 3.3.1 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE