Re-add http-client extension for connection re-use

libs/bilge/src/Bilge/IO.hs

@@ -172,7 +172,8 @@ instance MonadIO m => MonadHttp (SessionT m) where
             responseBody = bodyReader,
             responseOriginalRequest = originalReq,
             Client.responseCookieJar = mempty,
-            Client.responseClose' = Client.ResponseClose $ pure ()
+            Client.responseClose' = Client.ResponseClose $ pure (),
+            Client.responseEarlyHints = mempty
           }
       lookupHeader :: CI ByteString -> Client.Request -> Maybe ByteString
       lookupHeader headerName r = lookup headerName (Client.requestHeaders r)

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

@@ -29,24 +29,24 @@ module Ssl.Util
     -- * to be used when initializing SSL Contexts to obtain SSL enabled
 
     --   'Network.HTTP.Client.ManagerSettings'
-    extEnvCallback,
+    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 ------------------------------------------------------------
 
@@ -170,6 +170,8 @@ verifyRsaFingerprint d = verifyFingerprint $ \pk ->
     Nothing -> pure Nothing
     Just k -> Just <$> rsaFingerprint d (k :: RSAPubKey)
 
+-- Utilities -----------------------------------------------------------------
+
 -- [Note: Hostname verification]
 -- Ideally, we would like to perform proper hostname verification, which
 -- is not done automatically by OpenSSL [1]. However, the necessary APIs
@@ -180,28 +182,32 @@ 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 :: [Fingerprint Rsa] -> X509StoreCtx -> IO Bool
-extEnvCallback fingerprints store = do
-  Just sha <- getDigestByName "SHA256"
-  cert <- getStoreCtxCert store
-  pk <- getPublicKey cert
-  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) fingerprints)
-        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)
+-- | 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
     , imports
-    , time          >=1.5
-    , types-common
+    , time         >=1.5
 
   default-language:   GHC2021

nix/haskell-pins.nix

@@ -79,6 +79,20 @@ let
       };
     };
 
+    http-client = {
+      src = fetchgit {
+        url = "https://github.com/elland/http-client";
+        rev = "97ffd0b39ac4e2f7a381bb267a40de4a8e46158c";
+        sha256 = "sha256-2h9xoHmw/gjiZ0QDow4H8fPP8M7uxDSc0GhhnGHOwG0=";
+      };
+      packages = {
+        http-client = "http-client";
+        http-client-openssl = "http-client-openssl";
+        http-client-tls = "http-client-tls";
+        http-conduit = "http-conduit";
+      };
+    };
+
     saml2-web-sso = {
       src = fetchgit {
         url = "https://github.com/wireapp/saml2-web-sso";

nix/manual-overrides.nix

@@ -48,7 +48,7 @@ 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;
+  # 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/src/Brig/App.hs

@@ -112,6 +112,7 @@ import Control.Error
 import Control.Lens hiding (index, (.=))
 import Control.Monad.Catch
 import Control.Monad.Trans.Resource
+import Data.ByteString.Conversion (toByteString')
 import Data.Domain (Domain)
 import Data.Metrics (Metrics)
 import Data.Metrics.Middleware qualified as Metrics
@@ -172,7 +173,7 @@ data Env = Env
     _templateBranding :: TemplateBranding,
     _httpManager :: Manager,
     _http2Manager :: Http2Manager,
-    _extGetManager :: [Fingerprint Rsa] -> IO Manager,
+    _extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()),
     _settings :: Settings,
     _nexmoCreds :: Nexmo.Credentials,
     _twilioCreds :: Twilio.Credentials,
@@ -246,6 +247,7 @@ newEnv o = do
       pure Nothing
   kpLock <- newMVar ()
   rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) o.rabbitmq
+  ext <- initExtGetManager
   pure $!
     Env
       { _cargohold = mkEndpoint $ Opt.cargohold o,
@@ -267,7 +269,7 @@ newEnv o = do
         _templateBranding = branding,
         _httpManager = mgr,
         _http2Manager = h2Mgr,
-        _extGetManager = initExtGetManager,
+        _extGetManager = ext,
         _settings = sett,
         _nexmoCreds = nxm,
         _twilioCreds = twl,
@@ -359,28 +361,31 @@ initHttp2Manager = do
 -- faster. So, we reuse the context.
 
 -- TODO: somewhat duplicates Galley.App.initExtEnv
-initExtGetManager :: [Fingerprint Rsa] -> IO Manager
-initExtGetManager fingerprints = 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 = False,
-        vpCallback = Just \_b -> extEnvCallback fingerprints
-      }
+  -- 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

@@ -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,17 +72,16 @@ data ServiceError
 createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppT r) NewBotResponse
 createBot scon new = do
   let fprs = toList (sconFingerprints scon)
-  manF <- view extGetManager
-  man <- liftIO $ manF 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/galley/src/Galley/App.hs

@@ -160,7 +160,7 @@ createEnv m o l = do
   codeURIcfg <- validateOptions o
   Env (RequestId "N/A") m o l mgr h2mgr (o ^. O.federator) (o ^. O.brig) cass
     <$> Q.new 16000
-    <*> pure initExtEnv
+    <*> initExtEnv
     <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal)
     <*> loadAllMLSKeys (fold (o ^. settings . mlsPrivateKeyPaths))
     <*> traverse (mkRabbitMqChannelMVar l) (o ^. rabbitmq)

services/galley/src/Galley/Cassandra/LegalHold.hs

@@ -73,8 +73,8 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case
   SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid
   UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid
   IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid
-  MakeVerifiedRequest fpr url r ->
-    embedApp $ makeVerifiedRequest fpr url r
+  MakeVerifiedRequest reuse fpr url r ->
+    embedApp $ makeVerifiedRequest reuse fpr url r
   ValidateServiceKey sk -> embed @IO $ validateServiceKey sk
 
 -- | Returns 'False' if legal hold is not enabled for this team

services/galley/src/Galley/Effects/LegalHoldStore.hs

@@ -63,6 +63,7 @@ data LegalHoldStore m a where
   IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool
   -- -- intra actions
   MakeVerifiedRequest ::
+    Http.Reuse ->
     Fingerprint Rsa ->
     HttpsUrl ->
     (Http.Request -> Http.Request) ->

services/galley/src/Galley/Env.hs

@@ -22,9 +22,10 @@ module Galley.Env where
 
 import Cassandra
 import Control.Lens hiding ((.=))
+import Data.ByteString.Conversion (toByteString')
 import Data.Id
 import Data.Metrics.Middleware
-import Data.Misc (Fingerprint (..), HttpsUrl, Rsa)
+import Data.Misc (Fingerprint, HttpsUrl, Rsa)
 import Data.Range
 import Galley.Aws qualified as Aws
 import Galley.Options
@@ -35,7 +36,9 @@ import Imports
 import Network.AMQP qualified as Q
 import Network.HTTP.Client
 import Network.HTTP.Client.OpenSSL
+import OpenSSL.EVP.Digest
 import OpenSSL.Session as Ssl
+import OpenSSL.Session qualified as SSL
 import Ssl.Util
 import System.Logger
 import Util.Options
@@ -58,7 +61,7 @@ data Env = Env
     _brig :: Endpoint, -- FUTUREWORK: see _federator
     _cstate :: ClientState,
     _deleteQueue :: Q.Queue DeleteItem,
-    _extGetManager :: [Fingerprint Rsa] -> IO Manager,
+    _extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()),
     _aEnv :: Maybe Aws.Env,
     _mlsKeys :: SignaturePurpose -> MLSKeys,
     _rabbitmqChannel :: Maybe (MVar Q.Channel),
@@ -68,28 +71,30 @@ data Env = Env
 makeLenses ''Env
 
 -- TODO: somewhat duplicates Brig.App.initExtGetManager
-initExtEnv :: [Fingerprint Rsa] -> IO Manager
-initExtEnv fingerprints = do
+initExtEnv :: IO (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ())
+initExtEnv = do
   ctx <- Ssl.context
   Ssl.contextAddOption ctx SSL_OP_NO_SSLv2
   Ssl.contextAddOption ctx SSL_OP_NO_SSLv3
   Ssl.contextAddOption ctx SSL_OP_NO_TLSv1
   Ssl.contextSetCiphers ctx rsaCiphers
-  Ssl.contextSetVerificationMode
-    ctx
-    Ssl.VerifyPeer
-      { vpFailIfNoPeerCert = True,
-        vpClientOnce = False,
-        vpCallback = Just \_b -> extEnvCallback fingerprints
-      }
-
+  -- 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))
-      { managerResponseTimeout = responseTimeoutMicro 10000000,
-        managerConnCount = 100
-      }
+  mgr <-
+    newManager
+      (opensslManagerSettings (pure ctx))
+        { managerResponseTimeout = responseTimeoutMicro 10000000,
+          managerConnCount = 100
+        }
+  Just sha <- getDigestByName "SHA256"
+  pure $ (mgr, mkVerify sha)
+  where
+    mkVerify sha fprs =
+      let pinset = map toByteString' fprs
+       in verifyRsaFingerprint sha pinset
 
 reqIdMsg :: RequestId -> Msg -> Msg
 reqIdMsg = ("request" .=) . unRequestId