From 642dc52138bde1a356ea68b712f6fd53841cc5bb Mon Sep 17 00:00:00 2001
From: Stefan Matting <smatting@users.noreply.github.com>
Date: Fri, 22 Sep 2023 16:03:23 +0200
Subject: [PATCH] federator-client: Use a new http2 connection on every request
 (#3602)

---
 changelog.d/3-bug-fixes/WPB-4787              |  1 +
 .../http2-manager/src/HTTP2/Client/Manager.hs |  4 ++++
 libs/wire-api-federation/default.nix          |  2 ++
 .../src/Wire/API/Federation/Client.hs         | 21 ++++++++++++++++---
 .../wire-api-federation.cabal                 |  1 +
 5 files changed, 26 insertions(+), 3 deletions(-)
 create mode 100644 changelog.d/3-bug-fixes/WPB-4787

diff --git a/changelog.d/3-bug-fixes/WPB-4787 b/changelog.d/3-bug-fixes/WPB-4787
new file mode 100644
index 00000000000..97cb562182e
--- /dev/null
+++ b/changelog.d/3-bug-fixes/WPB-4787
@@ -0,0 +1 @@
+Create a new http2 connection in every federator client request instead of using a shared connection.
diff --git a/libs/http2-manager/src/HTTP2/Client/Manager.hs b/libs/http2-manager/src/HTTP2/Client/Manager.hs
index 89a96517211..2cf1278061b 100644
--- a/libs/http2-manager/src/HTTP2/Client/Manager.hs
+++ b/libs/http2-manager/src/HTTP2/Client/Manager.hs
@@ -15,6 +15,10 @@ module HTTP2.Client.Manager
     ConnectionAlreadyClosed (..),
     disconnectTarget,
     disconnectTargetWithTimeout,
+    startPersistentHTTP2Connection,
+    sendRequestWithConnection,
+    HTTP2Conn (..),
+    ConnectionAction (..),
   )
 where
 
diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix
index 0275616b33e..48b8b6ae525 100644
--- a/libs/wire-api-federation/default.nix
+++ b/libs/wire-api-federation/default.nix
@@ -6,6 +6,7 @@
 , aeson
 , aeson-pretty
 , amqp
+, async
 , base
 , bytestring
 , bytestring-conversion
@@ -51,6 +52,7 @@ mkDerivation {
   libraryHaskellDepends = [
     aeson
     amqp
+    async
     base
     bytestring
     bytestring-conversion
diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs
index f9f0473306f..4104c41d92d 100644
--- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs
+++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs
@@ -32,6 +32,7 @@ module Wire.API.Federation.Client
   )
 where
 
+import Control.Concurrent.Async
 import Control.Exception qualified as E
 import Control.Monad.Catch
 import Control.Monad.Codensity
@@ -58,6 +59,7 @@ import Network.HTTP.Media qualified as HTTP
 import Network.HTTP.Types qualified as HTTP
 import Network.HTTP2.Client qualified as HTTP2
 import Network.Wai.Utilities.Error qualified as Wai
+import OpenSSL.Session qualified as SSL
 import Servant.Client
 import Servant.Client.Core
 import Servant.Types.SourceT
@@ -113,13 +115,26 @@ liftCodensity = FederatorClient . lift . lift . lift
 headersFromTable :: HTTP2.HeaderTable -> [HTTP.Header]
 headersFromTable (headerList, _) = flip map headerList $ first HTTP2.tokenKey
 
+-- This opens a new http2 connection. Using a http2-manager leads to this problem https://wearezeta.atlassian.net/browse/WPB-4787
+-- FUTUREWORK: Replace with H2Manager.withHTTP2Request once the bugs are solved.
+withNewHttpRequest :: H2Manager.Target -> HTTP2.Request -> (HTTP2.Response -> IO a) -> IO a
+withNewHttpRequest target req k = do
+  ctx <- SSL.context
+  let cacheLimit = 20
+      sslRemoveTrailingDot = False
+      tcpConnectionTimeout = 30_000_000
+  sendReqMVar <- newEmptyMVar
+  thread <- liftIO . async $ H2Manager.startPersistentHTTP2Connection ctx target cacheLimit sslRemoveTrailingDot tcpConnectionTimeout sendReqMVar
+  let newConn = H2Manager.HTTP2Conn thread (putMVar sendReqMVar H2Manager.CloseConnection) sendReqMVar
+  H2Manager.sendRequestWithConnection newConn req k
+
 performHTTP2Request ::
   Http2Manager ->
   H2Manager.Target ->
   HTTP2.Request ->
   IO (Either FederatorClientHTTP2Error (ResponseF Builder))
-performHTTP2Request mgr target req = try $ do
-  H2Manager.withHTTP2Request mgr target req $ consumeStreamingResponseWith $ \resp -> do
+performHTTP2Request _mgr target req = try $ do
+  withNewHttpRequest target req $ consumeStreamingResponseWith $ \resp -> do
     b <-
       fmap (fromRight mempty)
         . runExceptT
@@ -210,7 +225,7 @@ withHTTP2StreamingRequest successfulStatus req handleResponse = do
     either throwError pure <=< liftCodensity $
       Codensity $ \k ->
         E.catches
-          (H2Manager.withHTTP2Request (ceHttp2Manager env) (False, hostname, port) req' (consumeStreamingResponseWith (k . Right)))
+          (withNewHttpRequest (False, hostname, port) req' (consumeStreamingResponseWith (k . Right)))
           [ E.Handler $ k . Left . FederatorClientHTTP2Error,
             E.Handler $ k . Left . FederatorClientHTTP2Error . FederatorClientConnectionError,
             E.Handler $ k . Left . FederatorClientHTTP2Error . FederatorClientHTTP2Exception,
diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal
index b19ff51c99d..d6e73abc4eb 100644
--- a/libs/wire-api-federation/wire-api-federation.cabal
+++ b/libs/wire-api-federation/wire-api-federation.cabal
@@ -82,6 +82,7 @@ library
   build-depends:
       aeson                  >=2.0.1.0
     , amqp
+    , async
     , base                   >=4.6     && <5.0
     , bytestring
     , bytestring-conversion