wip http2 debug

libs/http2-manager/default.nix

@@ -20,6 +20,7 @@
 , streaming-commons
 , text
 , time-manager
+, utf8-string
 }:
 mkDerivation {
   pname = "http2-manager";
@@ -36,7 +37,7 @@ mkDerivation {
     stm
     streaming-commons
     text
-    time-manager
+    utf8-string
   ];
   testHaskellDepends = [
     async

libs/http2-manager/http2-manager.cabal

@@ -44,7 +44,7 @@ library
     , stm
     , streaming-commons
     , text
-    , time-manager
+    , utf8-string
 
   default-language: Haskell2010
 

libs/http2-manager/src/HTTP2/Client/Manager/Internal.hs

@@ -15,6 +15,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Data.ByteString
 import qualified Data.ByteString as BS
+import Data.ByteString.UTF8 as UTF8
 import Data.IORef
 import Data.Map
 import qualified Data.Map as Map
@@ -23,13 +24,11 @@ import Data.Streaming.Network
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Unique
-import Foreign.Marshal.Alloc (mallocBytes)
 import GHC.IO.Exception
 import qualified Network.HTTP2.Client as HTTP2
 import qualified Network.Socket as NS
 import qualified OpenSSL.Session as SSL
 import System.IO.Error
-import qualified System.TimeManager
 import System.Timeout
 import Prelude
 
@@ -89,7 +88,7 @@ defaultHttp2Manager = do
   SSL.contextSetVerificationMode ctx $
     SSL.VerifyPeer
       { vpFailIfNoPeerCert = True,
-        -- Only relvant when running as server
+        -- Only relevant when running as server
         vpClientOnce = False,
         vpCallback = Nothing
       }
@@ -225,9 +224,9 @@ getConnection mgr target = do
         Nothing -> pure (Just conn)
         Just _ -> do
           -- Maybe there is value in logging any exceptions we
-          -- recieve here. But logging in STM will be tricky, and the threads
+          -- receive here. But logging in STM will be tricky, and the threads
           -- running requests on the connection which got an exception would've
-          -- anyway recieved the exception, so maybe it is not as valueable.
+          -- anyway received the exception, so maybe it is not as valuable.
           writeTVar (connections mgr) $ Map.delete target conns
           pure Nothing
 
@@ -291,9 +290,9 @@ startPersistentHTTP2Connection ::
 startPersistentHTTP2Connection ctx (tlsEnabled, hostname, port) cl removeTrailingDot tcpConnectTimeout sendReqMVar = do
   liveReqs <- newIORef mempty
   let clientConfig =
-        HTTP2.ClientConfig
+        HTTP2.defaultClientConfig
           { HTTP2.scheme = if tlsEnabled then "https" else "http",
-            HTTP2.authority = hostname,
+            HTTP2.authority = UTF8.toString hostname,
             HTTP2.cacheLimit = cl
           }
       -- Sends error to requests which show up too late, i.e. after the
@@ -333,7 +332,7 @@ startPersistentHTTP2Connection ctx (tlsEnabled, hostname, port) cl removeTrailin
     bracket connectTCPWithTimeout NS.close $ \sock -> do
       bracket (mkTransport sock transportConfig) cleanupTransport $ \transport ->
         bracket (allocHTTP2Config transport) HTTP2.freeSimpleConfig $ \http2Cfg -> do
-          let runAction = HTTP2.run clientConfig http2Cfg $ \sendReq -> do
+          let runAction = HTTP2.run clientConfig http2Cfg $ \sendReq _aux -> do
                 handleRequests liveReqs sendReq
           -- Any request threads still hanging about after 'runAction' finishes
           -- are canceled with 'ConnectionAlreadyClosed'.
@@ -397,7 +396,7 @@ type SendReqFn = HTTP2.Request -> (HTTP2.Response -> IO ()) -> IO ()
 
 data Transport
   = InsecureTransport NS.Socket
-  | SecureTransport SSL.SSL
+  | SecureTransport SSL.SSL NS.Socket
 
 data TLSParams = TLSParams
   { context :: SSL.SSLContext,
@@ -414,11 +413,11 @@ mkTransport sock (Just TLSParams {..}) = do
   SSL.setTlsextHostName ssl hostnameStr
   SSL.enableHostnameValidation ssl hostnameStr
   SSL.connect ssl
-  pure $ SecureTransport ssl
+  pure $ SecureTransport ssl sock
 
 cleanupTransport :: Transport -> IO ()
 cleanupTransport (InsecureTransport _) = pure ()
-cleanupTransport (SecureTransport ssl) = SSL.shutdown ssl SSL.Unidirectional
+cleanupTransport (SecureTransport ssl _) = SSL.shutdown ssl SSL.Unidirectional
 
 data ConnectionAlreadyClosed = ConnectionAlreadyClosed
   deriving (Show)
@@ -430,33 +429,34 @@ bufsize = 4096
 
 allocHTTP2Config :: Transport -> IO HTTP2.Config
 allocHTTP2Config (InsecureTransport sock) = HTTP2.allocSimpleConfig sock bufsize
-allocHTTP2Config (SecureTransport ssl) = do
-  buf <- mallocBytes bufsize
-  timmgr <- System.TimeManager.initialize $ 30 * 1000000
-  -- Sometimes the frame header says that the payload length is 0. Reading 0
-  -- bytes multiple times seems to be causing errors in openssl. I cannot figure
-  -- out why. The previous implementation didn't try to read from the socket
-  -- when trying to read 0 bytes, so special handling for 0 maintains that
-  -- behaviour.
-  let readData acc 0 = pure acc
-      readData acc n = do
-        -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
-        -- (some sites terminate SSL connection right after returning the data).
-        chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty
-        let chunkLen = BS.length chunk
-        if
-            | chunkLen == 0 || chunkLen == n ->
-                pure (acc <> chunk)
-            | chunkLen > n ->
-                error "openssl: SSL.read returned more bytes than asked for, this is probably a bug"
-            | otherwise ->
-                readData (acc <> chunk) (n - chunkLen)
-  pure
-    HTTP2.Config
-      { HTTP2.confWriteBuffer = buf,
-        HTTP2.confBufferSize = bufsize,
-        HTTP2.confSendAll = SSL.write ssl,
-        HTTP2.confReadN = readData mempty,
-        HTTP2.confPositionReadMaker = HTTP2.defaultPositionReadMaker,
-        HTTP2.confTimeoutManager = timmgr
+allocHTTP2Config (SecureTransport ssl sock) = do
+  config <- HTTP2.allocSimpleConfig sock bufsize
+  pure $
+    config
+      { HTTP2.confSendAll = SSL.write ssl,
+        HTTP2.confReadN = readData
       }
+  where
+    -- Sometimes the frame header says that the payload length is 0. Reading 0
+    -- bytes multiple times seems to be causing errors in openssl. I cannot figure
+    -- out why. The previous implementation didn't try to read from the socket
+    -- when trying to read 0 bytes, so special handling for 0 maintains that
+    -- behaviour.
+    readData :: Int -> IO ByteString
+    readData 0 = pure mempty
+    readData n = loop mempty n
+
+    loop :: ByteString -> Int -> IO ByteString
+    loop acc 0 = pure acc
+    loop acc n = do
+      -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
+      -- (some sites terminate SSL connection right after returning the data).
+      chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty
+      let chunkLen = BS.length chunk
+      if
+          | chunkLen == 0 || chunkLen == n ->
+              pure (acc <> chunk)
+          | chunkLen > n ->
+              error "openssl: SSL.read returned more bytes than asked for, this is probably a bug"
+          | otherwise ->
+              loop (acc <> chunk) (n - chunkLen)

libs/http2-manager/test/Test/HTTP2/Client/ManagerSpec.hs

@@ -26,7 +26,6 @@ import qualified Data.Map as Map
 import Data.Maybe (isJust)
 import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP)
 import Data.Unique
-import Foreign.Marshal.Alloc (mallocBytes)
 import GHC.IO.Exception
 import HTTP2.Client.Manager
 import HTTP2.Client.Manager.Internal
@@ -37,7 +36,6 @@ import qualified Network.HTTP2.Server as Server
 import Network.Socket
 import qualified OpenSSL.Session as SSL
 import System.Random (randomRIO)
-import qualified System.TimeManager
 import Test.Hspec
 
 echoTest :: Http2Manager -> TLSEnabled -> Int -> Expectation
@@ -270,59 +268,50 @@ withTestServerOnSocket mCtx action (serverPort, listenSock) = do
   bracket (async $ testServerOnSocket mCtx listenSock acceptedConns liveConns) cleanupServer $ \serverThread ->
     action TestServer {..}
 
-allocServerConfig :: Either Socket SSL.SSL -> IO Server.Config
-allocServerConfig (Left sock) = HTTP2.allocSimpleConfig sock 4096
-allocServerConfig (Right ssl) = do
-  buf <- mallocBytes bufsize
-  timmgr <- System.TimeManager.initialize $ 30 * 1000000
-  -- Sometimes the frame header says that the payload length is 0. Reading 0
-  -- bytes multiple times seems to be causing errors in openssl. I cannot figure
-  -- out why. The previous implementation didn't try to read from the socket
-  -- when trying to read 0 bytes, so special handling for 0 maintains that
-  -- behaviour.
-  let readData prevChunk 0 = pure prevChunk
-      readData prevChunk n = do
-        -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
-        -- (some sites terminate SSL connection right after returning the data).
-        chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty
-        let chunkLen = BS.length chunk
-        if
-            | chunkLen == 0 || chunkLen == n ->
-                pure (prevChunk <> chunk)
-            | chunkLen > n ->
-                error "openssl: SSL.read returned more bytes than asked for, this is probably a bug"
-            | otherwise ->
-                readData (prevChunk <> chunk) (n - chunkLen)
-  pure
-    Server.Config
-      { Server.confWriteBuffer = buf,
-        Server.confBufferSize = bufsize,
-        Server.confSendAll = SSL.write ssl,
-        Server.confReadN = readData mempty,
-        Server.confPositionReadMaker = Server.defaultPositionReadMaker,
-        Server.confTimeoutManager = timmgr
+allocServerConfig :: Socket -> Maybe SSL.SSL -> IO Server.Config
+allocServerConfig sock Nothing = HTTP2.allocSimpleConfig sock 4096
+allocServerConfig sock (Just ssl) = do
+  config <- HTTP2.allocSimpleConfig sock 4096
+  pure $
+    config
+      { Server.confReadN = readData mempty,
+        Server.confSendAll = SSL.write ssl
       }
+  where
+    readData prevChunk 0 = pure prevChunk
+    readData prevChunk n = do
+      -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
+      -- (some sites terminate SSL connection right after returning the data).
+      chunk <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty
+      let chunkLen = BS.length chunk
+      if
+          | chunkLen == 0 || chunkLen == n ->
+              pure (prevChunk <> chunk)
+          | chunkLen > n ->
+              error "openssl: SSL.read returned more bytes than asked for, this is probably a bug"
+          | otherwise ->
+              readData (prevChunk <> chunk) (n - chunkLen)
 
 testServerOnSocket :: Maybe SSL.SSLContext -> Socket -> IORef Int -> IORef (Map Unique (Async ())) -> IO ()
 testServerOnSocket mCtx listenSock connsCounter conns = do
   listen listenSock 1024
   forever $ do
     (sock, _) <- accept listenSock
-    serverCfgParam <- case mCtx of
-      Nothing -> pure $ Left sock
+    sslMaybe <- case mCtx of
+      Nothing -> pure Nothing
       Just ctx -> do
         ssl <- SSL.connection ctx sock
         SSL.accept ssl
-        pure (Right ssl)
+        pure $ Just ssl
     connKey <- newUnique
     modifyIORef connsCounter (+ 1)
-    let shutdownSSL = case serverCfgParam of
-          Left _ -> pure ()
-          Right ssl -> SSL.shutdown ssl SSL.Bidirectional
+    let shutdownSSL = case sslMaybe of
+          Nothing -> pure ()
+          Just ssl -> SSL.shutdown ssl SSL.Bidirectional
         cleanup cfg = do
           Server.freeSimpleConfig cfg `finally` (shutdownSSL `finally` close sock)
-    thread <- async $ bracket (allocServerConfig serverCfgParam) cleanup $ \cfg -> do
-      Server.run cfg testServer `finally` modifyIORef conns (Map.delete connKey)
+    thread <- async $ bracket (allocServerConfig sock sslMaybe) cleanup $ \cfg -> do
+      Server.run Server.defaultServerConfig cfg testServer `finally` modifyIORef conns (Map.delete connKey)
     modifyIORef conns $ Map.insert connKey thread
 
 testServer :: Server.Request -> Server.Aux -> (Server.Response -> [Server.PushPromise] -> IO ()) -> IO ()

nix/haskell-pins.nix

@@ -140,6 +140,17 @@ let
       };
     };
 
+    # We forked to add a handler for the ConnectionIsClosed signal
+    # since it was threated as a halting exception instead of a 
+    # clean exit.
+    http2 = {
+      src = fetchgit {
+        url = "https://github.com/wireapp/http2";
+        rev = "eb5831a64e5d99d58f65626025503ac287492542";
+        sha256 = "sha256-bTLaq7p7qeXpBTcLvgjic0KhJYR6aU2+UuNmJILiDgg=";
+      };
+    };
+
     # PR: https://gitlab.com/twittner/cql/-/merge_requests/11
     cql = {
       src = fetchgit {
@@ -236,14 +247,20 @@ let
     warp = {
       src = fetchgit {
         url = "https://github.com/wireapp/wai";
-        rev = "bedd6a835f6d98128880465c30e8115fa986e3f6";
-        sha256 = "sha256-0r/d9YwcKZIZd10EhL2TP+W14Wjk0/S8Q4pVvZuZLaY=";
+        rev = "a48f8f31ad42f26057d7b96d70f897c1a3f69a3c";
+        sha256 = "sha256-fFkiKLlViiV+F1wdQXak3RI454kgWvyRsoDz6g4c5Ks=";
       };
       packages = {
         "warp" = "warp";
+        "warp-tls" = "warp-tls";
+        "wai-app-static" = "wai-app-static";
+        "wai" = "wai";
+        "wai-extra" = "wai-extra";
+        "wai-websockets" = "wai-websockets";
       };
     };
   };
+
   hackagePins = {
     # Major re-write upstream, we should get rid of this dependency rather than
     # adapt to upstream, this will go away when completing servantification.
@@ -252,6 +269,11 @@ let
       sha256 = "sha256-DSMckKIeVE/buSMg8Mq+mUm1bYPYB7veA11Ns7vTBbc=";
     };
 
+    network-control = {
+      version = "0.0.2";
+      sha256 = "sha256-0EvnVu7cktMmSRVk9Ufm0oE4JLQrKLSRYpFpgcJguY0=";
+    };
+
     # these are not yet in nixpkgs
     ghc-source-gen = {
       version = "0.4.4.0";