Use http-client fork again

integration/integration.cabal

@@ -24,7 +24,6 @@ common common-all
   ghc-options:
     -Wall -Wpartial-fields -fwarn-tabs -Wno-incomplete-uni-patterns
 
-  -- NoImportQualifiedPost is required
   default-extensions:
     AllowAmbiguousTypes
     BangPatterns

libs/bilge/src/Bilge/IO.hs

@@ -162,7 +162,7 @@ instance MonadIO m => MonadHttp (SessionT m) where
               Wai.requestHeaderReferer = lookupHeader "REFERER" req,
               Wai.requestHeaderUserAgent = lookupHeader "USER-AGENT" req
             }
-      toBilgeResponse :: BodyReader -> WaiTest.SResponse -> Request -> Response BodyReader
+      toBilgeResponse :: BodyReader -> WaiTest.SResponse -> Client.Request -> Response BodyReader
       toBilgeResponse bodyReader WaiTest.SResponse {WaiTest.simpleStatus, WaiTest.simpleHeaders} originalReq =
         Client.Response
           { responseStatus = simpleStatus,
@@ -171,6 +171,7 @@ instance MonadIO m => MonadHttp (SessionT m) where
             responseHeaders = simpleHeaders,
             responseBody = bodyReader,
             responseOriginalRequest = originalReq,
+            responseEarlyHints = [],
             Client.responseCookieJar = mempty,
             Client.responseClose' = Client.ResponseClose $ pure ()
           }

libs/ssl-util/default.nix

@@ -8,10 +8,10 @@
 , bytestring
 , gitignoreSource
 , HsOpenSSL
+, http-client
 , imports
 , lib
 , time
-, types-common
 }:
 mkDerivation {
   pname = "ssl-util";
@@ -22,9 +22,9 @@ mkDerivation {
     byteable
     bytestring
     HsOpenSSL
+    http-client
     imports
     time
-    types-common
   ];
   description = "SSL-related utilities";
   license = lib.licenses.agpl3Only;

libs/ssl-util/src/Ssl/Util.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
@@ -26,27 +28,25 @@ module Ssl.Util
     -- * Cipher suites
     rsaCiphers,
 
-    -- * to be used when initializing SSL Contexts to obtain SSL enabled
-
-    --   'Network.HTTP.Client.ManagerSettings'
-    extEnvCallback,
+    -- * Network
+    withVerifiedSslConnection,
   )
 where
 
 import Control.Exception
 import Data.ByteString.Builder
 import Data.Byteable (constEqBytes)
-import Data.Misc (Fingerprint (fingerprintBytes), Rsa)
+import Data.Dynamic (fromDynamic)
 import Data.Time.Clock (getCurrentTime)
 import Imports
+import Network.HTTP.Client.Internal
 import OpenSSL.BN (integerToMPI)
-import OpenSSL.EVP.Digest (Digest, digestLBS, getDigestByName)
+import OpenSSL.EVP.Digest (Digest, digestLBS)
 import OpenSSL.EVP.PKey (SomePublicKey, toPublicKey)
 import OpenSSL.EVP.Verify (VerifyStatus (..))
 import OpenSSL.RSA
 import OpenSSL.Session as SSL
 import OpenSSL.X509 as X509
-import OpenSSL.X509.Store (X509StoreCtx, getStoreCtxCert)
 
 -- Cipher Suites ------------------------------------------------------------
 
@@ -180,29 +180,34 @@ verifyRsaFingerprint d = verifyFingerprint $ \pk ->
 -- [1] https://wiki.openssl.org/index.php/Hostname_validation
 -- [2] https://www.cs.utexas.edu/~shmat/shmat_ccs12.pdf
 
--- | this is used as a 'OpenSSL.Session.vpCallback' in 'Brig.App.initExtGetManager'
---   and 'Galley.Env.initExtEnv'
-extEnvCallback :: IORef [Fingerprint Rsa] -> X509StoreCtx -> IO Bool
-extEnvCallback fingerprints store = do
-  Just sha <- getDigestByName "SHA256"
-  cert <- getStoreCtxCert store
-  pk <- getPublicKey cert
-  fprs <- readIORef fingerprints
-  case toPublicKey @RSAPubKey pk of
-    Nothing -> pure False
-    Just k -> do
-      fp <- rsaFingerprint sha k
-      -- find at least one matching fingerprint to continue
-      if not (any (constEqBytes fp . fingerprintBytes) fprs)
-        then pure False
-        else do
-          -- Check if the certificate is self-signed.
-          self <- verifyX509 cert pk
-          if (self /= VerifySuccess)
-            then pure False
-            else do
-              -- For completeness, perform a date check as well.
-              now <- getCurrentTime
-              notBefore <- getNotBefore cert
-              notAfter <- getNotAfter cert
-              pure (now >= notBefore && now <= notAfter)
+-- Utilities -----------------------------------------------------------------
+
+-- | Get an SSL connection that has definitely had its fingerprints checked
+-- (internally it just grabs a connection from a pool and does verification
+-- if it's a fresh one).
+--
+-- Throws an error for other types of connections.
+withVerifiedSslConnection ::
+  -- | A function to verify fingerprints given an SSL connection
+  (SSL -> IO ()) ->
+  Manager ->
+  -- | Request builder
+  (Request -> Request) ->
+  -- | This callback will be passed a modified
+  --   request that always uses the verified
+  --   connection
+  (Request -> IO a) ->
+  IO a
+withVerifiedSslConnection verify man reqBuilder act =
+  withConnection' req man Reuse $ \mConn -> do
+    -- If we see this connection for the first time, verify fingerprints
+    let conn = managedResource mConn
+        seen = managedReused mConn
+    unless seen $ case fromDynamic @SSL (connectionRaw conn) of
+      Nothing -> error ("withVerifiedSslConnection: only SSL allowed: " <> show req)
+      Just ssl -> verify ssl
+    -- Make a request using this connection and return it back to the
+    -- pool (that's what 'Reuse' is for)
+    act req {connectionOverride = Just mConn}
+  where
+    req = reqBuilder defaultRequest

libs/ssl-util/ssl-util.cabal

@@ -63,12 +63,12 @@ library
     -Wredundant-constraints -Wunused-packages
 
   build-depends:
-      base          >=4.7  && <5
-    , byteable      >=0.1
-    , bytestring    >=0.10
-    , HsOpenSSL     >=0.11
+      base         >=4.7  && <5
+    , byteable     >=0.1
+    , bytestring   >=0.10
+    , HsOpenSSL    >=0.11
+    , http-client  >=0.7
     , imports
-    , time          >=1.5
-    , types-common
+    , time         >=1.5
 
   default-language:   GHC2021

nix/haskell-pins.nix

@@ -116,6 +116,21 @@ let
       };
     };
 
+    # Our fork because we need to a few special things
+    http-client = {
+      src = fetchgit {
+        url = "https://github.com/wireapp/http-client";
+        rev = "37494bb9a89dd52f97a8dc582746c6ff52943934";
+        sha256 = "sha256-z47GlT+tHsSlRX4ApSGQIpOpaZiBeqr72/tWuvzw8tc=";
+      };
+      packages = {
+        "http-client" = "http-client";
+        "http-client-tls" = "http-client-tls";
+        "http-client-openssl" = "http-client-openssl";
+        "http-conduit" = "http-conduit";
+      };
+    };
+
     # PR: https://github.com/hspec/hspec-wai/pull/49
     hspec-wai = {
       src = fetchgit {

nix/manual-overrides.nix

@@ -48,7 +48,6 @@ hself: hsuper: {
   # (these are fine but will probably need to be adjusted in a future nixpkgs update)
   # -----------------
   hpack = hsuper.hpack_0_36_0;
-  http-client-tls = hsuper.http-client-tls_0_3_6_3;
   linear-generics = hsuper.linear-generics_0_2_2;
   network-conduit-tls = hsuper.network-conduit-tls_1_4_0;
   optparse-generic = hsuper.optparse-generic_1_5_2;

services/brig/brig.cabal

@@ -464,7 +464,7 @@ executable brig-integration
     , HsOpenSSL
     , http-api-data
     , http-client
-    , http-client-tls        >=0.3.6.3
+    , http-client-tls        >=0.3
     , http-media
     , http-reverse-proxy
     , http-types

services/brig/src/Brig/App.hs

@@ -46,7 +46,6 @@ module Brig.App
     httpManager,
     http2Manager,
     extGetManager,
-    initExtGetManager,
     nexmoCreds,
     twilioCreds,
     settings,
@@ -73,7 +72,7 @@ module Brig.App
 
     -- * Crutches that should be removed once Brig has been completely
 
-    -- transitioned to Polysemy
+    -- * transitioned to Polysemy
     wrapClient,
     wrapClientE,
     wrapClientM,
@@ -114,7 +113,8 @@ import Control.Error
 import Control.Lens hiding (index, (.=))
 import Control.Monad.Catch
 import Control.Monad.Trans.Resource
-import Data.Domain (Domain)
+import Data.ByteString.Conversion
+import Data.Domain
 import Data.Metrics (Metrics)
 import Data.Metrics.Middleware qualified as Metrics
 import Data.Misc
@@ -175,7 +175,7 @@ data Env = Env
     _templateBranding :: TemplateBranding,
     _httpManager :: Manager,
     _http2Manager :: Http2Manager,
-    _extGetManager :: (Manager, IORef [Fingerprint Rsa]),
+    _extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()),
     _settings :: Settings,
     _nexmoCreds :: Nexmo.Credentials,
     _twilioCreds :: Twilio.Credentials,
@@ -213,6 +213,7 @@ newEnv o = do
   cas <- initCassandra o lgr
   mgr <- initHttpManager
   h2Mgr <- initHttp2Manager
+  ext <- initExtGetManager
   utp <- loadUserTemplates o
   ptp <- loadProviderTemplates o
   ttp <- loadTeamTemplates o
@@ -250,8 +251,6 @@ newEnv o = do
       pure Nothing
   kpLock <- newMVar ()
   rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) o.rabbitmq
-  fprVar <- newIORef []
-  extMgr <- initExtGetManager fprVar
   let allDisabledVersions = foldMap expandVersionExp (Opt.setDisabledAPIVersions sett)
 
   pure $!
@@ -275,7 +274,7 @@ newEnv o = do
         _templateBranding = branding,
         _httpManager = mgr,
         _http2Manager = h2Mgr,
-        _extGetManager = (extMgr, fprVar),
+        _extGetManager = ext,
         _settings = sett,
         _nexmoCreds = nxm,
         _twilioCreds = twl,
@@ -368,28 +367,29 @@ initHttp2Manager = do
 -- faster. So, we reuse the context.
 
 -- TODO: somewhat duplicates Galley.App.initExtEnv
-initExtGetManager :: IORef [Fingerprint Rsa] -> IO Manager
-initExtGetManager fprVar = do
+initExtGetManager :: IO (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ())
+initExtGetManager = do
   ctx <- SSL.context
   SSL.contextAddOption ctx SSL_OP_NO_SSLv2
   SSL.contextAddOption ctx SSL_OP_NO_SSLv3
   SSL.contextSetCiphers ctx rsaCiphers
-  SSL.contextSetVerificationMode
-    ctx
-    SSL.VerifyPeer
-      { vpFailIfNoPeerCert = True,
-        vpClientOnce = True,
-        vpCallback = Just \_b -> extEnvCallback fprVar
-      }
-
+  -- We use public key pinning with service providers and want to
+  -- support self-signed certificates as well, hence 'VerifyNone'.
+  SSL.contextSetVerificationMode ctx SSL.VerifyNone
   SSL.contextSetDefaultVerifyPaths ctx
-
-  newManager
-    (opensslManagerSettings (pure ctx)) -- see Note [SSL context]
-      { managerConnCount = 100,
-        managerIdleConnectionCount = 512,
-        managerResponseTimeout = responseTimeoutMicro 10000000
-      }
+  mgr <-
+    newManager
+      (opensslManagerSettings (pure ctx)) -- see Note [SSL context]
+        { managerConnCount = 100,
+          managerIdleConnectionCount = 512,
+          managerResponseTimeout = responseTimeoutMicro 10000000
+        }
+  Just sha <- getDigestByName "SHA256"
+  pure (mgr, mkVerify sha)
+  where
+    mkVerify sha fprs =
+      let pinset = map toByteString' fprs
+       in verifyRsaFingerprint sha pinset
 
 initCassandra :: Opts -> Logger -> IO Cas.ClientState
 initCassandra o g =

services/brig/src/Brig/Provider/RPC.hs

@@ -35,7 +35,7 @@ import Brig.App
 import Brig.Provider.DB (ServiceConn (..))
 import Brig.RPC
 import Control.Error
-import Control.Lens (set, (^.))
+import Control.Lens (set, view, (^.))
 import Control.Monad.Catch
 import Control.Retry (recovering)
 import Data.Aeson
@@ -49,6 +49,7 @@ import Imports
 import Network.HTTP.Client qualified as Http
 import Network.HTTP.Types.Method
 import Network.HTTP.Types.Status
+import Ssl.Util (withVerifiedSslConnection)
 import System.Logger.Class (MonadLogger, field, msg, val, (~~))
 import System.Logger.Class qualified as Log
 import URI.ByteString
@@ -71,18 +72,16 @@ data ServiceError
 createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppT r) NewBotResponse
 createBot scon new = do
   let fprs = toList (sconFingerprints scon)
-  -- fresh http manager
-  man <- liftIO do
-    initExtGetManager =<< newIORef fprs
+  (man, verifyFingerprints) <- view extGetManager
   extHandleAll onExc $ do
-    let req = reqBuilder Http.defaultRequest
     rs <- lift $
       wrapHttp $
         recovering x3 httpHandlers $
           const $
             liftIO $
-              Http.withConnection req man $
-                \_conn -> Http.httpLbs req man
+              withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $
+                \req ->
+                  Http.httpLbs req man
     case Bilge.statusCode rs of
       201 -> decodeBytes "External" (responseBody rs)
       409 -> throwE ServiceBotConflict

services/cargohold/cargohold.cabal

@@ -272,7 +272,7 @@ executable cargohold-integration
     , federator
     , http-api-data
     , http-client            >=0.7
-    , http-client-tls        >=0.3.6.3
+    , http-client-tls        >=0.3
     , http-media
     , http-types             >=0.8
     , imports

services/galley/galley.cabal

@@ -25,7 +25,6 @@ common common-all
   default-extensions:
     AllowAmbiguousTypes
     BangPatterns
-    BlockArguments
     ConstraintKinds
     DataKinds
     DefaultSignatures

services/galley/src/Galley/App.hs

@@ -30,7 +30,9 @@ module Galley.App
     cstate,
     deleteQueue,
     createEnv,
+    extEnv,
     aEnv,
+    ExtEnv (..),
     extGetManager,
 
     -- * Running Galley effects
@@ -158,11 +160,9 @@ createEnv m o l = do
   mgr <- initHttpManager o
   h2mgr <- initHttp2Manager
   codeURIcfg <- validateOptions o
-  fprVar <- newIORef []
-  extEnv <- initExtEnv fprVar
   Env (RequestId "N/A") m o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass
     <$> Q.new 16000
-    <*> pure (extEnv, fprVar)
+    <*> initExtEnv
     <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal)
     <*> loadAllMLSKeys (fold (o ^. settings . mlsPrivateKeyPaths))
     <*> traverse (mkRabbitMqChannelMVar l) (o ^. rabbitmq)