Improve usage of http-manager (fixes for fingerprint verification)

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

@@ -38,6 +38,7 @@ import Data.ByteString.Builder
 import Data.Byteable (constEqBytes)
 import Data.Misc (Fingerprint (fingerprintBytes), Rsa)
 import Data.Time.Clock (getCurrentTime)
+import Debug.Trace (traceM)
 import Imports
 import OpenSSL.BN (integerToMPI)
 import OpenSSL.EVP.Digest (Digest, digestLBS, getDigestByName)
@@ -182,19 +183,24 @@ verifyRsaFingerprint d = verifyFingerprint $ \pk ->
 
 -- | this is used as a 'OpenSSL.Session.vpCallback' in 'Brig.App.initExtGetManager'
 --   and 'Galley.Env.initExtEnv'
-extEnvCallback :: [Fingerprint Rsa] -> X509StoreCtx -> IO Bool
+extEnvCallback :: IORef [Fingerprint Rsa] -> X509StoreCtx -> IO Bool
 extEnvCallback fingerprints store = do
   Just sha <- getDigestByName "SHA256"
   cert <- getStoreCtxCert store
   pk <- getPublicKey cert
+  fprs <- readIORef fingerprints
+  traceM (show fprs)
   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
+      if not (any (constEqBytes fp . fingerprintBytes) fprs)
+        then do
+          traceM "fingerprint not contained in fprs"
+          pure False
         else do
+          traceM "fingerprint is contained in fprs"
           -- Check if the certificate is self-signed.
           self <- verifyX509 cert pk
           if (self /= VerifySuccess)

services/brig/src/Brig/App.hs

@@ -124,6 +124,7 @@ import Data.Text.IO qualified as Text
 import Data.Time.Clock
 import Data.Yaml (FromJSON)
 import Database.Bloodhound qualified as ES
+import Debug.Trace (traceM)
 import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx)
 import Imports
 import Network.AMQP qualified as Q
@@ -172,7 +173,7 @@ data Env = Env
     _templateBranding :: TemplateBranding,
     _httpManager :: Manager,
     _http2Manager :: Http2Manager,
-    _extGetManager :: [Fingerprint Rsa] -> IO Manager,
+    _extGetManager :: (Manager, IORef [Fingerprint Rsa]),
     _settings :: Settings,
     _nexmoCreds :: Nexmo.Credentials,
     _twilioCreds :: Twilio.Credentials,
@@ -246,6 +247,10 @@ newEnv o = do
       pure Nothing
   kpLock <- newMVar ()
   rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) o.rabbitmq
+  fprVar <- newIORef []
+  traceM "initExtGetManager brig"
+  extMgr <- initExtGetManager fprVar
+
   pure $!
     Env
       { _cargohold = mkEndpoint $ Opt.cargohold o,
@@ -267,7 +272,7 @@ newEnv o = do
         _templateBranding = branding,
         _httpManager = mgr,
         _http2Manager = h2Mgr,
-        _extGetManager = initExtGetManager,
+        _extGetManager = (extMgr, fprVar),
         _settings = sett,
         _nexmoCreds = nxm,
         _twilioCreds = twl,
@@ -359,8 +364,9 @@ initHttp2Manager = do
 -- faster. So, we reuse the context.
 
 -- TODO: somewhat duplicates Galley.App.initExtEnv
-initExtGetManager :: [Fingerprint Rsa] -> IO Manager
-initExtGetManager fingerprints = do
+initExtGetManager :: IORef [Fingerprint Rsa] -> IO Manager
+initExtGetManager fprVar = do
+  traceM "in init extGetManager in brig"
   ctx <- SSL.context
   SSL.contextAddOption ctx SSL_OP_NO_SSLv2
   SSL.contextAddOption ctx SSL_OP_NO_SSLv3
@@ -369,8 +375,8 @@ initExtGetManager fingerprints = do
     ctx
     SSL.VerifyPeer
       { vpFailIfNoPeerCert = True,
-        vpClientOnce = False,
-        vpCallback = Just \_b -> extEnvCallback fingerprints
+        vpClientOnce = True,
+        vpCallback = Just \_b -> extEnvCallback fprVar
       }
 
   SSL.contextSetDefaultVerifyPaths ctx

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

@@ -71,8 +71,8 @@ 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, fprVar) <- view extGetManager
+  atomicModifyIORef' fprVar \oldFprs -> (nub (fprs <> oldFprs), ())
   extHandleAll onExc $ do
     let req = reqBuilder Http.defaultRequest
     rs <- lift $

services/galley/src/Galley/App.hs

@@ -158,9 +158,11 @@ 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 initExtEnv
+    <*> pure (extEnv, fprVar)
     <*> 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,6 +73,9 @@ interpretLegalHoldStoreToCassandra lh = interpret $ \case
   SetTeamLegalholdWhitelisted tid -> embedClient $ setTeamLegalholdWhitelisted tid
   UnsetTeamLegalholdWhitelisted tid -> embedClient $ unsetTeamLegalholdWhitelisted tid
   IsTeamLegalholdWhitelisted tid -> embedClient $ isTeamLegalholdWhitelisted lh tid
+  -- FUTUREWORK: should this action be part of a separate effect?
+  MakeVerifiedRequestFreshManager fpr url r ->
+    embedApp $ makeVerifiedRequestFreshManager fpr url r
   MakeVerifiedRequest fpr url r ->
     embedApp $ makeVerifiedRequest fpr url r
   ValidateServiceKey sk -> embed @IO $ validateServiceKey sk

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

@@ -36,6 +36,7 @@ module Galley.Effects.LegalHoldStore
 
     -- * Intra actions
     makeVerifiedRequest,
+    makeVerifiedRequestFreshManager,
   )
 where
 
@@ -61,7 +62,12 @@ data LegalHoldStore m a where
   SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m ()
   UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m ()
   IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool
-  -- -- intra actions
+  -- intra actions
+  MakeVerifiedRequestFreshManager ::
+    Fingerprint Rsa ->
+    HttpsUrl ->
+    (Http.Request -> Http.Request) ->
+    LegalHoldStore m (Http.Response LC8.ByteString)
   MakeVerifiedRequest ::
     Fingerprint Rsa ->
     HttpsUrl ->

services/galley/src/Galley/Env.hs

@@ -26,6 +26,7 @@ import Data.Id
 import Data.Metrics.Middleware
 import Data.Misc (Fingerprint (..), HttpsUrl, Rsa)
 import Data.Range
+import Debug.Trace
 import Galley.Aws qualified as Aws
 import Galley.Options
 import Galley.Options qualified as O
@@ -54,11 +55,11 @@ data Env = Env
     _applog :: Logger,
     _manager :: Manager,
     _http2Manager :: Http2Manager,
-    _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time?
+    _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type ----- LegalHold.testLHClaimKeys01 FAIL (34.01 s) -----here? E.g. to avoid fresh connections all the time?
     _brig :: Endpoint, -- FUTUREWORK: see _federator
     _cstate :: ClientState,
     _deleteQueue :: Q.Queue DeleteItem,
-    _extGetManager :: [Fingerprint Rsa] -> IO Manager,
+    _extGetManager :: (Manager, IORef [Fingerprint Rsa]),
     _aEnv :: Maybe Aws.Env,
     _mlsKeys :: SignaturePurpose -> MLSKeys,
     _rabbitmqChannel :: Maybe (MVar Q.Channel),
@@ -68,8 +69,9 @@ data Env = Env
 makeLenses ''Env
 
 -- TODO: somewhat duplicates Brig.App.initExtGetManager
-initExtEnv :: [Fingerprint Rsa] -> IO Manager
+initExtEnv :: IORef [Fingerprint Rsa] -> IO Manager
 initExtEnv fingerprints = do
+  traceM "initExtEnv"
   ctx <- Ssl.context
   Ssl.contextAddOption ctx SSL_OP_NO_SSLv2
   Ssl.contextAddOption ctx SSL_OP_NO_SSLv3
@@ -79,7 +81,7 @@ initExtEnv fingerprints = do
     ctx
     Ssl.VerifyPeer
       { vpFailIfNoPeerCert = True,
-        vpClientOnce = False,
+        vpClientOnce = True,
         vpCallback = Just \_b -> extEnvCallback fingerprints
       }
 

services/galley/src/Galley/External.hs

@@ -151,8 +151,8 @@ urlPort (HttpsUrl u) = do
 
 sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App ()
 sendMessage fprs reqBuilder = do
-  mkMgr <- view extGetManager
-  man <- liftIO $ mkMgr fprs
+  (man, fprVar) <- view extGetManager
+  modifyIORef' fprVar (nub . (<> fprs))
   let req = reqBuilder defaultRequest
   liftIO $ withConnection req man $ \_conn ->
     Http.withResponse req man (const $ pure ())

services/galley/src/Galley/External/LegalHoldService.hs

@@ -60,7 +60,7 @@ checkLegalHoldServiceStatus ::
   HttpsUrl ->
   Sem r ()
 checkLegalHoldServiceStatus fpr url = do
-  resp <- makeVerifiedRequest fpr url reqBuilder
+  resp <- makeVerifiedRequestFreshManager fpr url reqBuilder
   if Bilge.statusCode resp < 400
     then pure ()
     else do
@@ -143,7 +143,7 @@ removeLegalHold tid uid = do
 -- helpers
 
 -- | Lookup legal hold service settings for a team and make a request to the service.  Pins
--- the TSL fingerprint via 'makeVerifiedRequest' and passes the token so the service can
+-- the TSL fingerprint via 'makeVerifiedRequestFreshManager' and passes the token so the service can
 -- authenticate the request.
 makeLegalHoldServiceRequest ::
   ( Member (ErrorS 'LegalHoldServiceNotRegistered) r,
@@ -162,7 +162,7 @@ makeLegalHoldServiceRequest tid reqBuilder = do
           legalHoldServiceFingerprint = fpr,
           legalHoldServiceToken = serviceToken
         } = lhSettings
-  makeVerifiedRequest fpr baseUrl $ mkReqBuilder serviceToken
+  makeVerifiedRequestFreshManager fpr baseUrl $ mkReqBuilder serviceToken
   where
     mkReqBuilder token =
       reqBuilder

services/galley/src/Galley/External/LegalHoldService/Internal.hs

@@ -17,6 +17,7 @@
 
 module Galley.External.LegalHoldService.Internal
   ( makeVerifiedRequest,
+    makeVerifiedRequestFreshManager,
   )
 where
 
@@ -28,6 +29,7 @@ import Control.Retry
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy.Char8 qualified as LC8
 import Data.Misc
+import Debug.Trace
 import Galley.API.Error
 import Galley.Env
 import Galley.Monad
@@ -77,6 +79,20 @@ makeVerifiedRequest ::
   (Http.Request -> Http.Request) ->
   App (Http.Response LC8.ByteString)
 makeVerifiedRequest fpr url reqBuilder = do
-  mkMgr <- view extGetManager
-  mgr <- liftIO $ mkMgr [fpr]
+  (mgr, fprVar) <- view extGetManager
+  modifyIORef' fprVar (nub . ([fpr] <>))
+  makeVerifiedRequestWithManager mgr url reqBuilder
+
+-- | NOTE: Use this function wisely - this creates a new manager _every_ time it is called.
+--   We should really _only_ use it in `checkLegalHoldServiceStatus` for the time being because
+--   this is where we check for signatures, etc. If we reuse the manager, we are likely to reuse
+--   an existing connection which will _not_ cause the new public key to be verified.
+makeVerifiedRequestFreshManager ::
+  Fingerprint Rsa ->
+  HttpsUrl ->
+  (Http.Request -> Http.Request) ->
+  App (Http.Response LC8.ByteString)
+makeVerifiedRequestFreshManager fpr url reqBuilder = do
+  traceM "makeVerifiedRequestFreshManager"
+  mgr <- liftIO . initExtEnv =<< newIORef [fpr]
   makeVerifiedRequestWithManager mgr url reqBuilder