warp-tls 3.4.14 → 3.4.15
raw patch · 6 files changed
+206/−15 lines, 6 filesdep +asyncdep +hspecdep +warp-tlsdep ~bytestringdep ~networkdep ~waiPVP ok
version bump matches the API change (PVP)
Dependencies added: async, hspec, warp-tls
Dependency ranges changed: bytestring, network, wai, warp
API changes (from Hackage documentation)
Files
- ChangeLog.md +17/−0
- Network/Wai/Handler/WarpTLS.hs +58/−12
- certificate.pem +15/−0
- key.pem +15/−0
- test/Spec.hs +83/−0
- warp-tls.cabal +18/−3
ChangeLog.md view
@@ -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`.
Network/Wai/Handler/WarpTLS.hs view
@@ -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
+ certificate.pem view
@@ -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-----
+ key.pem view
@@ -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-----
+ test/Spec.hs view
@@ -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
warp-tls.cabal view
@@ -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 <http://www.stackage.org/package/warp-tls>.-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