diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # ChangeLog for warp +## 3.4.21 + +Requires network 3.2.12. + +* `setUnsafeClose` closes connections with network's `unsafeClose` and + `unsafeGracefulClose`. Off by default, since a `responseRaw` + application may leave threads on the socket. +* The listening socket is closed with `unsafeClose` once the accept loop + has ended. +* Sends use network's `sendAllWith` on every platform, so the timeout + reaches a send on Windows too. +* An HTTP/2 connection which ends normally is no longer reported to + `settingsOnException` as http2's `ConnectionIsClosed`; the default + printed it for every such connection. + ## 3.4.20 * Building with GHC 9.0 again. 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 @@ -80,6 +80,7 @@ setMaxTotalHeaderLength, setAltSvc, setMaxBuilderResponseBufferSize, + setUnsafeClose, -- ** Getters getPort, @@ -93,6 +94,7 @@ getGracefulCloseTimeout2, getOpenConnectionCounter, getServerState, + getUnsafeClose, -- ** Internal server state -- @@ -555,6 +557,14 @@ setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings setMaxBuilderResponseBufferSize maxRspBufSize settings = settings{settingsMaxBuilderResponseBufferSize = maxRspBufSize} +-- | Close connections with network's 'unsafeClose' and +-- 'unsafeGracefulClose'. See 'settingsUnsafeClose' for when it is safe. +-- Default: 'False'. +-- +-- @since 3.4.21 +setUnsafeClose :: Bool -> Settings -> Settings +setUnsafeClose x y = y{settingsUnsafeClose = x} + -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For @@ -636,6 +646,13 @@ -- @since 3.4.12 getServerState :: Settings -> Maybe ServerState getServerState = settingsServerState + +-- | Whether connections are closed with network's 'unsafeClose' and +-- 'unsafeGracefulClose'. +-- +-- @since 3.4.21 +getUnsafeClose :: Settings -> Bool +getUnsafeClose = settingsUnsafeClose #ifdef MIN_VERSION_crypton_x509 -- | Getting information of client certificate. diff --git a/Network/Wai/Handler/Warp/HTTP2.hs b/Network/Wai/Handler/Warp/HTTP2.hs --- a/Network/Wai/Handler/Warp/HTTP2.hs +++ b/Network/Wai/Handler/Warp/HTTP2.hs @@ -14,6 +14,7 @@ import Data.IORef (readIORef) import qualified Data.IORef as I import GHC.Conc.Sync (labelThread, myThreadId) +import qualified Network.HTTP2.Client as H2C import qualified Network.HTTP2.Frame as H2 import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr) @@ -77,9 +78,15 @@ ok <- checkTLS setConnHTTP2 conn True when ok $ - H2.run H2.defaultServerConfig conf $ - http2server "Warp HTTP/2" settings ii transport peersa app + endedNormally $ + H2.run H2.defaultServerConfig conf $ + http2server "Warp HTTP/2" settings ii transport peersa app where + -- http2 ends a connection which has run its course with + -- 'ConnectionIsClosed', which is no exception to report. + endedNormally = E.handle $ \e -> case e of + H2C.ConnectionIsClosed -> return () + _ -> E.throwIO e -- A GOAWAY ends the connection, so there is nothing left to serve -- on it. checkTLS = case transport 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 @@ -11,6 +11,8 @@ import Control.Arrow (first) import Control.Concurrent.STM ( + STM, + retry, TVar, atomically, check, @@ -37,12 +39,13 @@ getSocketName, isClosedSocketError, isTransientAcceptError, + unsafeClose, withReadable, setSocketOption, withSocketsDo, ) #if MIN_VERSION_network(3,1,1) -import Network.Socket (gracefulClose) +import Network.Socket (gracefulClose, unsafeGracefulClose) #endif import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock @@ -92,9 +95,12 @@ if h2 then settingsGracefulCloseTimeout2 set else settingsGracefulCloseTimeout1 set + (closer, gracefulCloser) + | settingsUnsafeClose set = (unsafeClose, unsafeGracefulClose) + | otherwise = (close, gracefulClose) if tm <= 0 - then close s - else gracefulClose s tm `E.catch` throughAsync (return ()) + then closer s + else gracefulCloser s tm `E.catch` throughAsync (return ()) #else , connClose = close s #endif @@ -135,8 +141,14 @@ else Nothing ) E.throwIO - $ Sock.sendAll s bs + $ killableSendAll s bs +-- | 'Sock.sendAll' which the timeout can kill. On Windows a plain send is +-- a foreign call no asynchronous exception reaches; this one waits in STM, +-- and is cancelled if the waiting thread is killed. +killableSendAll :: Socket -> ByteString -> IO () +killableSendAll s bs = void $ Sock.sendAllWith s bs (retry :: STM ()) + -- | Create a 'Recv' which stops receiving when the server is shutting down -- and no 'Application' is still using this 'Socket'. -- @@ -231,7 +243,7 @@ { acceptOrStop = closedAsStopped $ do r <- withReadable socket (told stopping) $ settingsAccept set socket return $ either (const Nothing) Just r - , closeListener = close socket + , closeListener = unsafeClose socket } where told stopping = check =<< readTVar stopping diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -224,6 +224,15 @@ -- Default: 'Nothing' (warp creates its own internal state) -- -- @since 3.4.13 + , settingsUnsafeClose :: Bool + -- ^ Whether to close connections with network's 'unsafeClose' and + -- 'unsafeGracefulClose', which skip the IO manager. Use this only if + -- no thread uses a connection's socket after warp closes it, which + -- 'responseRaw' applications cannot always promise. + -- + -- Default: 'False'. + -- + -- @since 3.4.21 } -- | Specify usage of the PROXY protocol. @@ -352,6 +361,7 @@ , settingsMaxBuilderResponseBufferSize = 1049000000 , settingsConnectionCounter = Nothing , settingsServerState = Nothing + , settingsUnsafeClose = False } -- | Create 'defaultSettings' with a connection counter. diff --git a/test/HTTP2Spec.hs b/test/HTTP2Spec.hs --- a/test/HTTP2Spec.hs +++ b/test/HTTP2Spec.hs @@ -2,6 +2,7 @@ module HTTP2Spec (spec) where +import Control.Concurrent (threadDelay) import Control.Exception (bracket, throwIO) import Data.ByteString (ByteString) import Data.IORef @@ -19,7 +20,16 @@ import Test.Hspec spec :: Spec -spec = describe "http2server" $ +spec = describe "http2server" $ do + it "reports nothing for a connection the client closes" $ do + excs <- newIORef [] + let settings = setOnException (\_ e -> modifyIORef' excs (show e :)) defaultSettings + withApplicationSettings settings (pure hello) $ \port -> do + get port `shouldReturn` (Just ok200, "hello") + -- The connection ends once the client has closed it. + threadDelay 100000 + -- http2's ConnectionIsClosed used to be reported here. + readIORef excs `shouldReturn` [] it "keeps the response of an application which throws after it" $ do excs <- newIORef (0 :: Int) logged <- newIORef [] @@ -32,6 +42,9 @@ -- The second response used to go out and be logged, so the -- log said 500 where the client had been answered 200. readIORef logged `shouldReturn` [ok200] + +hello :: Application +hello _ respond = respond $ responseLBS status200 [] "hello" -- | Answers, then throws. The response has gone out by then, so -- nothing can replace it. diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -775,6 +775,21 @@ res <- sendGET $ "http://127.0.0.1:" ++ show port responseBody res `shouldBe` "HelloHelloHelloHello" + describe "setUnsafeClose" $ do + let app _ f = f $ responseLBS status200 [("content-length", "6")] "unsafe" + readAll s = do + bs <- safeRecv s 4096 + if S.null bs then return [] else (bs :) <$> readAll s + closes tm = + withApp (setGracefulCloseTimeout1 tm $ setUnsafeClose True defaultSettings) app $ + withMySocket $ \ms -> do + msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nconnection: close\r\n\r\n" + bs <- S.concat <$> readAll (msSocket ms) + S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK" + snd (S.breakSubstring "\r\n\r\n" bs) `shouldBe` "\r\n\r\nunsafe" + it "closes with unsafeClose" $ closes 0 + it "closes with unsafeGracefulClose" $ closes 1000 + describe "head requests" $ do let fp = "test/head-response" let app req f = diff --git a/test/SendFileSpec.hs b/test/SendFileSpec.hs --- a/test/SendFileSpec.hs +++ b/test/SendFileSpec.hs @@ -10,9 +10,7 @@ import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Types import System.Directory -import System.Exit import qualified System.IO as IO -import System.Process (system) import Test.Hspec main :: IO () @@ -53,11 +51,11 @@ describe "readSendFile" $ do it "sends a file correctly (1)" $ - tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess + tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` True it "sends a file correctly (2)" $ - tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess + tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` True it "sends a file correctly (3)" $ - tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess + tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` True tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf -> @@ -77,7 +75,7 @@ send = BS.appendFile outputFile hook = return () -tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode +tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO Bool tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do mapM_ (BS.appendFile expectedFile) hdrs copyfile inputFile expectedFile off len @@ -105,8 +103,12 @@ return $ bs == bs' else return $ bs == "" -compareFiles :: FilePath -> FilePath -> IO ExitCode -compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2 +-- | Whether two files hold the same bytes. +-- +-- This used to shell out to @cmp@, which Windows does not have, so these +-- three were the only tests here that could not pass there. +compareFiles :: FilePath -> FilePath -> IO Bool +compareFiles file1 file2 = (==) <$> BS.readFile file1 <*> BS.readFile file2 copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len = diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: warp -version: 3.4.20 +version: 3.4.21 license: MIT license-file: LICENSE maintainer: michael@snoyman.com @@ -132,7 +132,7 @@ network-bytestring >=0.1.3 && <0.1.4 else - build-depends: network >=3.2.10 + build-depends: network >=3.2.12 if flag(warp-debug) cpp-options: -DWARP_DEBUG