diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,22 @@ # ChangeLog +## 3.4.15 + +* The first read of a connection is given up on when the handshake + deadline passes, rather than interrupted by `timeout`, which does not + reach a socket call on Windows. + +## 3.4.14.1 + +* The accept loop is stopped the way warp's is, by being told rather than by + having its socket closed under it. This needs `warp` 3.5.0 or later; built + against an earlier one, warp-tls is as it was. It needs what warp needs, + too: not Windows, and `network` 3.2.2 or later. + [#1123](https://github.com/yesodweb/wai/pull/1123) + +* Build with `warp-3.5.0`. + [#1095](https://github.com/yesodweb/wai/pull/1095) + ## 3.4.14 * Build with `warp-3.4.13`. diff --git a/Network/Wai/Handler/WarpTLS.hs b/Network/Wai/Handler/WarpTLS.hs --- a/Network/Wai/Handler/WarpTLS.hs +++ b/Network/Wai/Handler/WarpTLS.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} @@ -60,7 +59,7 @@ import Control.Applicative ((<|>)) #if MIN_VERSION_warp(3,4,13) -import Control.Concurrent.STM (newTVarIO, TVar) +import Control.Concurrent.STM (TVar, check, newTVarIO, readTVar, registerDelay) #endif import Control.Exception ( Exception, @@ -80,8 +79,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.IORef as I -import Data.Streaming.Network (bindPortTCP, safeRecv) -import Data.Typeable (Typeable) +import Data.Streaming.Network (bindPortTCP) import GHC.IO.Exception (IOErrorType (..)) import Network.Socket ( SockAddr, @@ -94,7 +92,7 @@ withSocketsDo, ) import Network.Socket.BufferPool -import Network.Socket.ByteString (sendAll) +import Network.Socket.ByteString (recvWith, sendAll) import qualified Network.TLS as TLS import qualified Network.TLS.SessionManager as SM import Network.Wai (Application) @@ -264,25 +262,45 @@ -- specified 'Socket'. runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO () runTLSSocket tlsset set sock app = do +#if MIN_VERSION_warp(3,4,18) + -- The accept loop is stopped by being told, not by having this socket + -- closed under it; the socket is closed once the loop has ended. See + -- 'Network.Wai.Handler.Warp.Internal.Listener'. + listener <- makeListener set sock +#else settingsInstallShutdownHandler set (close sock) +#endif credentials <- loadCredentials tlsset mgr <- getSessionManager tlsset +#if MIN_VERSION_warp(3,4,18) + runTLSSocket' tlsset set listener credentials mgr sock app +#else runTLSSocket' tlsset set credentials mgr sock app +#endif runTLSSocket' :: TLSSettings -> Settings +#if MIN_VERSION_warp(3,4,18) + -> Listener +#endif -> TLS.Credentials -> TLS.SessionManager -> Socket -> Application -> IO () +#if MIN_VERSION_warp(3,4,18) +runTLSSocket' tlsset@TLSSettings{..} set listener credentials mgr sock app = do + (_, newSettings) <- makeServerState set + let get = getter tlsset newSettings listener sock params + runSettingsConnectionMakerSecureWith newSettings listener get app +#elif MIN_VERSION_warp(3,4,13) runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app = do -#if MIN_VERSION_warp(3,4,13) (_, newSettings) <- makeServerState set let get = getter tlsset newSettings sock params runSettingsConnectionMakerSecure newSettings get app #else +runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app = do let get = getter tlsset set sock params runSettingsConnectionMakerSecure set get app #endif @@ -337,13 +355,24 @@ :: TLS.TLSParams params => TLSSettings -> Settings +#if MIN_VERSION_warp(3,4,18) + -> Listener +#endif -> Socket -> params -> IO (IO (Connection, Transport), SockAddr) +#if MIN_VERSION_warp(3,4,18) +getter tlsset set listener _sock params = do + macc <- acceptOrStop listener + (s, sa) <- maybe (throwIO AcceptStopped) return macc + setSocketCloseOnExec s + return (mkConn tlsset set s params, sa) +#else getter tlsset set@Settings{settingsAccept = accept'} sock params = do (s, sa) <- accept' sock setSocketCloseOnExec s return (mkConn tlsset set s params, sa) +#endif mkConn :: TLS.TLSParams params @@ -354,12 +383,23 @@ -> IO (Connection, Transport) mkConn tlsset set s params = do let tm = settingsTimeout set * 1000000 - mbs <- timeout tm recvFirstBS - case mbs of - Nothing -> throwIO IncompleteHeaders - Just bs -> switch bs + -- The first read is given up on when the deadline passes, rather than + -- interrupted by 'timeout': an asynchronous exception does not reach a + -- thread blocked in a socket call on Windows. + expired <- registerDelay tm + ebs <- recvFirstBS expired + case ebs of + Left () -> throwIO IncompleteHeaders + Right bs -> switch bs where - recvFirstBS = safeRecv s 4096 `onException` close s + recvFirstBS expired = + (recvWith s 4096 (check =<< readTVar expired) `E.catch` resetIsEOF) + `onException` close s + -- What streaming-commons' safeRecv did for us: a connection reset is + -- the end of the connection, not an error to report. + resetIsEOF e + | ioeGetErrorType e == ResourceVanished = return $ Right "" + | otherwise = E.throwIO (e :: E.IOException) switch firstBS | S.null firstBS = close s >> throwIO ClientClosedConnectionPrematurely | S.head firstBS == 0x16 = httpOverTls tlsset set s firstBS params @@ -487,8 +527,14 @@ sendfile fid offset len hook headers = do writeBuffer <- I.readIORef writeBufferRef readSendFile +-- readSendFile takes the WriteBuffer itself from 3.5.0, not from 3.4.18: +-- the Listener work went out as 3.4.18 and this did not. +#if MIN_VERSION_warp(3,5,0) + writeBuffer +#else (bufBuffer writeBuffer) (bufSize writeBuffer) +#endif sendall fid offset @@ -588,5 +634,5 @@ data WarpTLSException = InsecureConnectionDenied | ClientClosedConnectionPrematurely - deriving (Show, Typeable) + deriving (Show) instance Exception WarpTLSException diff --git a/certificate.pem b/certificate.pem new file mode 100644 --- /dev/null +++ b/certificate.pem @@ -0,0 +1,15 @@ +-----BEGIN CERTIFICATE----- +MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB +gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx +EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs ++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV +HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM +b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk +D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0 +k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw +VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w== +-----END CERTIFICATE----- diff --git a/key.pem b/key.pem new file mode 100644 --- /dev/null +++ b/key.pem @@ -0,0 +1,15 @@ +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd +thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD +JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB +AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63 +CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM +MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp +ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid +Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B +5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs +eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV +YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv +jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG +T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8= +-----END RSA PRIVATE KEY----- diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Concurrent (newChan, readChan, writeChan, newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.Async (link, mapConcurrently, withAsync) +import Control.Exception (SomeException, bracket, fromException, throwIO) +import Control.Monad (forM_, replicateM, when) +import Data.Word (Word8) +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as B +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Handler.WarpTLS as TLS +import System.Info (os) +import System.Timeout (timeout) +import Test.Hspec + +main :: IO () +main = hspec $ describe "pre-TLS exception peer (#1113)" $ do + it "attributes sequential plaintext and premature-close failures to their sockets" $ + exercise [1, 1] False + it "attributes concurrent plaintext and premature-close failures to their sockets" $ + exercise [1, 1] True + + -- Linux provides the whole 127/8 loopback range without interface aliases. + -- Keep the original two-IP regression there; other platforms still check + -- exact socket addresses (including source ports) above. The maker tests + -- additionally check distinct IPs without binding sockets on every platform. + when (os == "linux") $ do + it "attributes sequential failures from distinct loopback IPs" $ + exercise [1, 2] False + it "attributes concurrent failures from distinct loopback IPs" $ + exercise [1, 2] True + +-- These regressions deliberately leave Warp's accept and fork hooks alone. +-- Keep both peers and failure kinds when changing the exception observer. +exercise :: [Word8] -> Bool -> IO () +exercise hosts concurrent = S.withSocketsDo $ + bracket (S.socket S.AF_INET S.Stream S.defaultProtocol) S.close $ \listener -> do + S.bind listener (S.SockAddrInet 0 (S.tupleToHostAddress (127, 0, 0, 1))) + S.listen listener 10 + port <- S.socketPort listener + events <- newChan + ready <- newEmptyMVar + let report address exception = case fromException exception of + Just tlsException -> writeChan events (address, show (tlsException :: TLS.WarpTLSException)) + Nothing -> throwIO exception + settings = Warp.setBeforeMainLoop (putMVar ready ()) $ observePeer report Warp.defaultSettings + application _ _ = fail "connection must fail before the application" + tls = TLS.tlsSettings "certificate.pem" "key.pem" + clients = [(host, plaintext) | host <- hosts, plaintext <- [True, False]] + send (host, plaintext) = bracket (S.socket S.AF_INET S.Stream S.defaultProtocol) S.close $ \client -> do + S.bind client (S.SockAddrInet 0 (S.tupleToHostAddress (127, 0, 0, host))) + S.connect client (S.SockAddrInet port (S.tupleToHostAddress (127, 0, 0, 1))) + own <- S.getSocketName client + if plaintext + then do + B.sendAll client "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n" + -- Let WarpTLS send its denial before closing the client; + -- an early close could cause a different send exception. + timeout 2000000 (drain client) `shouldReturn` Just () + else S.shutdown client S.ShutdownSend + pure (Just own, if plaintext then "InsecureConnectionDenied" else "ClientClosedConnectionPrematurely") + withAsync (TLS.runTLSSocket tls settings listener application) $ \server -> do + link server + timeout 2000000 (takeMVar ready) `shouldReturn` Just () + if concurrent + then do + expected <- mapConcurrently send clients + actual <- timeout 2000000 (replicateM (length clients) (readChan events)) + fmap length actual `shouldBe` Just (length clients) + maybe (expectationFailure "missing TLS observations") (`shouldMatchList` expected) actual + else forM_ clients $ \client -> do + expected <- send client + timeout 2000000 (readChan events) `shouldReturn` Just expected + +observePeer :: (Maybe S.SockAddr -> SomeException -> IO ()) -> Warp.Settings -> Warp.Settings +observePeer report = Warp.setOnConnectionException (report . Just) + +drain :: S.Socket -> IO () +drain client = do + bytes <- B.recv client 4096 + if bytes == "" then pure () else drain client diff --git a/warp-tls.cabal b/warp-tls.cabal --- a/warp-tls.cabal +++ b/warp-tls.cabal @@ -1,5 +1,5 @@ Name: warp-tls -Version: 3.4.14 +Version: 3.4.15 Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE @@ -15,13 +15,13 @@ HTTP/2 can be negotiated by ALPN. API docs and the README are available at . -extra-source-files: ChangeLog.md README.md +extra-source-files: ChangeLog.md README.md certificate.pem key.pem Library Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.9 , wai >= 3.2 && < 3.3 - , warp >= 3.3.29 && < 3.5 + , warp >= 3.3.29 && < 3.6 , tls >= 2.1.3 && < 2.5 , network >= 2.2.1 , streaming-commons @@ -42,3 +42,18 @@ type: git location: https://github.com/yesodweb/wai.git subdir: warp-tls + +Test-Suite spec + Type: exitcode-stdio-1.0 + Main-Is: Spec.hs + Hs-Source-Dirs: test + Default-Language: Haskell2010 + Ghc-Options: -Wall -threaded + Build-Depends: base >= 4.12 && < 5 + , async + , bytestring + , hspec >= 2 + , network >= 3.2.10 + , wai + , warp >= 3.4.18 && < 3.6 + , warp-tls