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

changelog.d/5-internal/reuse-manager

@@ -0,0 +1,4 @@
+- reuse the http manager wherever possible
+- don't reuse the http manager in legalhold scenarios
+- don't concurrently modify the ssl context in such ways that
+  it can create race conditions 

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

@@ -182,17 +182,18 @@ 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
   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)
+      if not (any (constEqBytes fp . fingerprintBytes) fprs)
         then pure False
         else do
           -- Check if the certificate is self-signed.

services/brig/src/Brig/App.hs

@@ -46,6 +46,7 @@ module Brig.App
     httpManager,
     http2Manager,
     extGetManager,
+    initExtGetManager,
     nexmoCreds,
     twilioCreds,
     settings,
@@ -71,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,
@@ -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,9 @@ newEnv o = do
       pure Nothing
   kpLock <- newMVar ()
   rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) o.rabbitmq
+  fprVar <- newIORef []
+  extMgr <- initExtGetManager fprVar
+
   pure $!
     Env
       { _cargohold = mkEndpoint $ Opt.cargohold o,
@@ -267,7 +271,7 @@ newEnv o = do
         _templateBranding = branding,
         _httpManager = mgr,
         _http2Manager = h2Mgr,
-        _extGetManager = initExtGetManager,
+        _extGetManager = (extMgr, fprVar),
         _settings = sett,
         _nexmoCreds = nxm,
         _twilioCreds = twl,
@@ -359,8 +363,8 @@ 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
   ctx <- SSL.context
   SSL.contextAddOption ctx SSL_OP_NO_SSLv2
   SSL.contextAddOption ctx SSL_OP_NO_SSLv3
@@ -369,8 +373,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

@@ -35,7 +35,7 @@ import Brig.App
 import Brig.Provider.DB (ServiceConn (..))
 import Brig.RPC
 import Control.Error
-import Control.Lens (set, view, (^.))
+import Control.Lens (set, (^.))
 import Control.Monad.Catch
 import Control.Retry (recovering)
 import Data.Aeson
@@ -71,8 +71,9 @@ 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
+  -- fresh http manager
+  man <- liftIO do
+    initExtGetManager =<< newIORef fprs
   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

@@ -54,11 +54,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,7 +68,7 @@ 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
   ctx <- Ssl.context
   Ssl.contextAddOption ctx SSL_OP_NO_SSLv2

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

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

@@ -17,6 +17,7 @@
 
 module Galley.External.LegalHoldService.Internal
   ( makeVerifiedRequest,
+    makeVerifiedRequestFreshManager,
   )
 where
 
@@ -77,6 +78,19 @@ 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
+  mgr <- liftIO . initExtEnv =<< newIORef [fpr]
   makeVerifiedRequestWithManager mgr url reqBuilder