From dc6263d1eefd2949a7ae4eaa51ac5d34dc69d549 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 31 Jan 2024 11:30:46 +0100 Subject: [PATCH 1/4] Update http-client fork to latest upstream and use it --- libs/bilge/src/Bilge/IO.hs | 3 ++- nix/haskell-pins.nix | 14 ++++++++++++++ nix/manual-overrides.nix | 1 - 3 files changed, 16 insertions(+), 2 deletions(-) diff --git a/libs/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index f9ec36060e..f1fa331ea0 100644 --- a/libs/bilge/src/Bilge/IO.hs +++ b/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 () } diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 587fce7e9a..809b40095e 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -228,6 +228,20 @@ let "warp" = "warp"; }; }; + + http-client = { + src = fetchgit { + url = "https://github.com/wireapp/http-client"; + rev = "e6beaccdcc8fac892d2437ebbff029fef3551a13"; + 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"; + }; + }; }; hackagePins = { # Major re-write upstream, we should get rid of this dependency rather than diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix index b8d22ef366..90db54af1d 100644 --- a/nix/manual-overrides.nix +++ b/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; From 7aca91c3f7eba04a0b491bc38552fcc1c0d85fc6 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 31 Jan 2024 11:59:33 +0100 Subject: [PATCH 2/4] Revert "Improve usage of http-manager (fixes for fingerprint verification) (#3825)" This reverts commit 38d3398c304c46ba6ce198d1af1ec4b6dc24efa1. --- changelog.d/5-internal/reuse-manager | 4 ---- libs/ssl-util/src/Ssl/Util.hs | 5 ++--- services/brig/src/Brig/App.hs | 17 +++++++---------- services/brig/src/Brig/Provider/RPC.hs | 7 +++---- services/galley/src/Galley/App.hs | 4 +--- .../galley/src/Galley/Cassandra/LegalHold.hs | 3 --- .../src/Galley/Effects/LegalHoldStore.hs | 8 +------- services/galley/src/Galley/Env.hs | 6 +++--- services/galley/src/Galley/External.hs | 4 ++-- .../src/Galley/External/LegalHoldService.hs | 2 +- .../External/LegalHoldService/Internal.hs | 18 ++---------------- 11 files changed, 22 insertions(+), 56 deletions(-) delete mode 100644 changelog.d/5-internal/reuse-manager diff --git a/changelog.d/5-internal/reuse-manager b/changelog.d/5-internal/reuse-manager deleted file mode 100644 index 7ef933fd20..0000000000 --- a/changelog.d/5-internal/reuse-manager +++ /dev/null @@ -1,4 +0,0 @@ -- 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 diff --git a/libs/ssl-util/src/Ssl/Util.hs b/libs/ssl-util/src/Ssl/Util.hs index 1598c100bf..a7375a4084 100644 --- a/libs/ssl-util/src/Ssl/Util.hs +++ b/libs/ssl-util/src/Ssl/Util.hs @@ -182,18 +182,17 @@ verifyRsaFingerprint d = verifyFingerprint $ \pk -> -- | this is used as a 'OpenSSL.Session.vpCallback' in 'Brig.App.initExtGetManager' -- and 'Galley.Env.initExtEnv' -extEnvCallback :: IORef [Fingerprint Rsa] -> X509StoreCtx -> IO Bool +extEnvCallback :: [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) + if not (any (constEqBytes fp . fingerprintBytes) fingerprints) then pure False else do -- Check if the certificate is self-signed. diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 8555db5fec..d178e9867d 100644 --- a/services/brig/src/Brig/App.hs +++ b/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, @@ -175,7 +174,7 @@ data Env = Env _templateBranding :: TemplateBranding, _httpManager :: Manager, _http2Manager :: Http2Manager, - _extGetManager :: (Manager, IORef [Fingerprint Rsa]), + _extGetManager :: [Fingerprint Rsa] -> IO Manager, _settings :: Settings, _nexmoCreds :: Nexmo.Credentials, _twilioCreds :: Twilio.Credentials, @@ -250,8 +249,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 +272,7 @@ newEnv o = do _templateBranding = branding, _httpManager = mgr, _http2Manager = h2Mgr, - _extGetManager = (extMgr, fprVar), + _extGetManager = initExtGetManager, _settings = sett, _nexmoCreds = nxm, _twilioCreds = twl, @@ -368,8 +365,8 @@ initHttp2Manager = do -- faster. So, we reuse the context. -- TODO: somewhat duplicates Galley.App.initExtEnv -initExtGetManager :: IORef [Fingerprint Rsa] -> IO Manager -initExtGetManager fprVar = do +initExtGetManager :: [Fingerprint Rsa] -> IO Manager +initExtGetManager fingerprints = do ctx <- SSL.context SSL.contextAddOption ctx SSL_OP_NO_SSLv2 SSL.contextAddOption ctx SSL_OP_NO_SSLv3 @@ -378,8 +375,8 @@ initExtGetManager fprVar = do ctx SSL.VerifyPeer { vpFailIfNoPeerCert = True, - vpClientOnce = True, - vpCallback = Just \_b -> extEnvCallback fprVar + vpClientOnce = False, + vpCallback = Just \_b -> extEnvCallback fingerprints } SSL.contextSetDefaultVerifyPaths ctx diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index ae42498e4f..7244148216 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/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 @@ -71,9 +71,8 @@ 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 + manF <- view extGetManager + man <- liftIO $ manF fprs extHandleAll onExc $ do let req = reqBuilder Http.defaultRequest rs <- lift $ diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 8004879993..1680941a3e 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -158,11 +158,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) + <*> pure initExtEnv <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal) <*> loadAllMLSKeys (fold (o ^. settings . mlsPrivateKeyPaths)) <*> traverse (mkRabbitMqChannelMVar l) (o ^. rabbitmq) diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index db37db2657..ff09339630 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -73,9 +73,6 @@ 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 diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs index e91dea42f4..56d71864c5 100644 --- a/services/galley/src/Galley/Effects/LegalHoldStore.hs +++ b/services/galley/src/Galley/Effects/LegalHoldStore.hs @@ -36,7 +36,6 @@ module Galley.Effects.LegalHoldStore -- * Intra actions makeVerifiedRequest, - makeVerifiedRequestFreshManager, ) where @@ -62,12 +61,7 @@ data LegalHoldStore m a where SetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () UnsetTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m () IsTeamLegalholdWhitelisted :: TeamId -> LegalHoldStore m Bool - -- intra actions - MakeVerifiedRequestFreshManager :: - Fingerprint Rsa -> - HttpsUrl -> - (Http.Request -> Http.Request) -> - LegalHoldStore m (Http.Response LC8.ByteString) + -- -- intra actions MakeVerifiedRequest :: Fingerprint Rsa -> HttpsUrl -> diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index b4e43adf16..4a9687c3e3 100644 --- a/services/galley/src/Galley/Env.hs +++ b/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 ----- LegalHold.testLHClaimKeys01 FAIL (34.01 s) -----here? E.g. to avoid fresh connections all the time? + _federator :: Maybe Endpoint, -- FUTUREWORK: should we use a better type here? E.g. to avoid fresh connections all the time? _brig :: Endpoint, -- FUTUREWORK: see _federator _cstate :: ClientState, _deleteQueue :: Q.Queue DeleteItem, - _extGetManager :: (Manager, IORef [Fingerprint Rsa]), + _extGetManager :: [Fingerprint Rsa] -> IO Manager, _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 :: IORef [Fingerprint Rsa] -> IO Manager +initExtEnv :: [Fingerprint Rsa] -> IO Manager initExtEnv fingerprints = do ctx <- Ssl.context Ssl.contextAddOption ctx SSL_OP_NO_SSLv2 diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index f56ff3c538..fd775f44e3 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -151,8 +151,8 @@ urlPort (HttpsUrl u) = do sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do - (man, fprVar) <- view extGetManager - modifyIORef' fprVar (nub . (<> fprs)) + mkMgr <- view extGetManager + man <- liftIO $ mkMgr fprs let req = reqBuilder defaultRequest liftIO $ withConnection req man $ \_conn -> Http.withResponse req man (const $ pure ()) diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index cca80ae880..c5555bccc1 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -60,7 +60,7 @@ checkLegalHoldServiceStatus :: HttpsUrl -> Sem r () checkLegalHoldServiceStatus fpr url = do - resp <- makeVerifiedRequestFreshManager fpr url reqBuilder + resp <- makeVerifiedRequest fpr url reqBuilder if Bilge.statusCode resp < 400 then pure () else do diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index d34acd22b5..2106138763 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -17,7 +17,6 @@ module Galley.External.LegalHoldService.Internal ( makeVerifiedRequest, - makeVerifiedRequestFreshManager, ) where @@ -78,19 +77,6 @@ makeVerifiedRequest :: (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) makeVerifiedRequest fpr url reqBuilder = do - (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] + mkMgr <- view extGetManager + mgr <- liftIO $ mkMgr [fpr] makeVerifiedRequestWithManager mgr url reqBuilder From a93866b215b0aad7e5efb0c2edbb503b3d59d68a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 31 Jan 2024 12:16:21 +0100 Subject: [PATCH 3/4] Revert "Migrate from http-client fork, use upstream. (#3801)" Except for changes to amazonka things as we're still using latest http-client (albiet forked) which requires us to upgrade amazonka. --- integration/integration.cabal | 1 - libs/ssl-util/default.nix | 4 +- libs/ssl-util/src/Ssl/Util.hs | 70 ++++++++++--------- libs/ssl-util/ssl-util.cabal | 12 ++-- nix/haskell-pins.nix | 28 ++++---- services/brig/brig.cabal | 2 +- services/brig/src/Brig/App.hs | 43 ++++++------ services/brig/src/Brig/Provider/RPC.hs | 10 +-- services/cargohold/cargohold.cabal | 2 +- services/galley/galley.cabal | 1 - services/galley/src/Galley/App.hs | 4 +- .../galley/src/Galley/Cassandra/LegalHold.hs | 3 + .../src/Galley/Effects/LegalHoldStore.hs | 8 ++- services/galley/src/Galley/Env.hs | 45 +++++++----- services/galley/src/Galley/External.hs | 8 +-- .../src/Galley/External/LegalHoldService.hs | 2 +- .../External/LegalHoldService/Internal.hs | 32 ++++++--- services/gundeck/gundeck.cabal | 2 +- services/proxy/proxy.cabal | 2 +- 19 files changed, 160 insertions(+), 119 deletions(-) diff --git a/integration/integration.cabal b/integration/integration.cabal index eac2272713..c95eb9ecd7 100644 --- a/integration/integration.cabal +++ b/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 diff --git a/libs/ssl-util/default.nix b/libs/ssl-util/default.nix index 7c3753ef17..1ec717b7f7 100644 --- a/libs/ssl-util/default.nix +++ b/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; diff --git a/libs/ssl-util/src/Ssl/Util.hs b/libs/ssl-util/src/Ssl/Util.hs index a7375a4084..9f9d8ece4e 100644 --- a/libs/ssl-util/src/Ssl/Util.hs +++ b/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 @@ -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,28 +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 :: [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) +-- 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 diff --git a/libs/ssl-util/ssl-util.cabal b/libs/ssl-util/ssl-util.cabal index 34deab65ed..9c306e564e 100644 --- a/libs/ssl-util/ssl-util.cabal +++ b/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 diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 809b40095e..dc4101bc75 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -116,6 +116,20 @@ let }; }; + http-client = { + src = fetchgit { + url = "https://github.com/wireapp/http-client"; + rev = "e6beaccdcc8fac892d2437ebbff029fef3551a13"; + 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 { @@ -228,20 +242,6 @@ let "warp" = "warp"; }; }; - - http-client = { - src = fetchgit { - url = "https://github.com/wireapp/http-client"; - rev = "e6beaccdcc8fac892d2437ebbff029fef3551a13"; - 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"; - }; - }; }; hackagePins = { # Major re-write upstream, we should get rid of this dependency rather than diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 2af5345890..0d0487355e 100644 --- a/services/brig/brig.cabal +++ b/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 diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index d178e9867d..8ead8601f9 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -113,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 @@ -174,7 +175,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, @@ -212,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 @@ -272,7 +274,7 @@ newEnv o = do _templateBranding = branding, _httpManager = mgr, _http2Manager = h2Mgr, - _extGetManager = initExtGetManager, + _extGetManager = ext, _settings = sett, _nexmoCreds = nxm, _twilioCreds = twl, @@ -365,28 +367,29 @@ 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 = diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index 7244148216..fd91cac91b 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/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 diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index b82b8218b5..7723b5814f 100644 --- a/services/cargohold/cargohold.cabal +++ b/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 diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 1c40172da3..e646ea232c 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -25,7 +25,6 @@ common common-all default-extensions: AllowAmbiguousTypes BangPatterns - BlockArguments ConstraintKinds DataKinds DefaultSignatures diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 1680941a3e..14873001de 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -30,7 +30,9 @@ module Galley.App cstate, deleteQueue, createEnv, + extEnv, aEnv, + ExtEnv (..), extGetManager, -- * Running Galley effects @@ -160,7 +162,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) diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index ff09339630..db37db2657 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/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 diff --git a/services/galley/src/Galley/Effects/LegalHoldStore.hs b/services/galley/src/Galley/Effects/LegalHoldStore.hs index 56d71864c5..e91dea42f4 100644 --- a/services/galley/src/Galley/Effects/LegalHoldStore.hs +++ b/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 -> diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 4a9687c3e3..2bdb38c27f 100644 --- a/services/galley/src/Galley/Env.hs +++ b/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,6 +36,7 @@ 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 Ssl.Util import System.Logger @@ -58,38 +60,45 @@ data Env = Env _brig :: Endpoint, -- FUTUREWORK: see _federator _cstate :: ClientState, _deleteQueue :: Q.Queue DeleteItem, - _extGetManager :: [Fingerprint Rsa] -> IO Manager, + _extEnv :: ExtEnv, _aEnv :: Maybe Aws.Env, _mlsKeys :: SignaturePurpose -> MLSKeys, _rabbitmqChannel :: Maybe (MVar Q.Channel), _convCodeURI :: Either HttpsUrl (Map Text HttpsUrl) } +-- | Environment specific to the communication with external +-- service providers. +data ExtEnv = ExtEnv + { _extGetManager :: (Manager, [Fingerprint Rsa] -> Ssl.SSL -> IO ()) + } + makeLenses ''Env +makeLenses ''ExtEnv + -- TODO: somewhat duplicates Brig.App.initExtGetManager -initExtEnv :: [Fingerprint Rsa] -> IO Manager -initExtEnv fingerprints = do +initExtEnv :: IO ExtEnv +initExtEnv = do ctx <- Ssl.context + Ssl.contextSetVerificationMode ctx Ssl.VerifyNone 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 - } - 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 $ ExtEnv (mgr, mkVerify sha) + where + mkVerify sha fprs = + let pinset = map toByteString' fprs + in verifyRsaFingerprint sha pinset reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index fd775f44e3..605ac731d0 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -34,12 +34,12 @@ import Galley.Intra.User import Galley.Monad import Galley.Types.Bot.Service (Service, serviceEnabled, serviceFingerprints, serviceToken, serviceUrl) import Imports -import Network.HTTP.Client (defaultRequest, withConnection) import Network.HTTP.Client qualified as Http import Network.HTTP.Types.Method import Network.HTTP.Types.Status (status410) import Polysemy import Polysemy.Input +import Ssl.Util (withVerifiedSslConnection) import System.Logger.Class qualified as Log import System.Logger.Message (field, msg, val, (~~)) import URI.ByteString @@ -151,10 +151,8 @@ urlPort (HttpsUrl u) = do sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do - mkMgr <- view extGetManager - man <- liftIO $ mkMgr fprs - let req = reqBuilder defaultRequest - liftIO $ withConnection req man $ \_conn -> + (man, verifyFingerprints) <- view (extEnv . extGetManager) + liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> Http.withResponse req man (const $ pure ()) x3 :: RetryPolicy diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index c5555bccc1..cca80ae880 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/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 diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index 2106138763..6923ebf02d 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -17,6 +17,7 @@ module Galley.External.LegalHoldService.Internal ( makeVerifiedRequest, + makeVerifiedRequestFreshManager, ) where @@ -33,20 +34,23 @@ import Galley.Env import Galley.Monad import Imports import Network.HTTP.Client qualified as Http +import OpenSSL.Session qualified as SSL +import Ssl.Util import System.Logger.Class qualified as Log import URI.ByteString (uriPath) -- | Check that the given fingerprint is valid and make the request over ssl. -- If the team has a device registered use 'makeLegalHoldServiceRequest' instead. -makeVerifiedRequestWithManager :: Http.Manager -> HttpsUrl -> (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) -makeVerifiedRequestWithManager mgr (HttpsUrl url) reqBuilder = do - let req = reqBuilderMods . reqBuilder $ Http.defaultRequest +makeVerifiedRequestWithManager :: Http.Manager -> ([Fingerprint Rsa] -> SSL.SSL -> IO ()) -> Fingerprint Rsa -> HttpsUrl -> (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) +makeVerifiedRequestWithManager mgr verifyFingerprints fpr (HttpsUrl url) reqBuilder = do + let verified = verifyFingerprints [fpr] extHandleAll errHandler $ do recovering x3 httpHandlers $ const $ liftIO $ - Http.withConnection req mgr $ \_conn -> - Http.httpLbs req mgr + withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ + \req -> + Http.httpLbs req mgr where reqBuilderMods = maybe id Bilge.host (Bilge.extHost url) @@ -77,6 +81,18 @@ makeVerifiedRequest :: (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) makeVerifiedRequest fpr url reqBuilder = do - mkMgr <- view extGetManager - mgr <- liftIO $ mkMgr [fpr] - makeVerifiedRequestWithManager mgr url reqBuilder + (mgr, verifyFingerprints) <- view (extEnv . extGetManager) + makeVerifiedRequestWithManager mgr verifyFingerprints fpr 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 + ExtEnv (mgr, verifyFingerprints) <- liftIO initExtEnv + makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index af1d57c662..ce1b2c82ac 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -131,7 +131,7 @@ library , gundeck-types >=1.0 , hedis >=0.14.0 , http-client >=0.7 - , http-client-tls >=0.3.6.3 + , http-client-tls >=0.3 , http-types >=0.8 , imports , lens >=4.4 diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 4e7f7e5302..79da68ca4e 100644 --- a/services/proxy/proxy.cabal +++ b/services/proxy/proxy.cabal @@ -83,7 +83,7 @@ library , exceptions >=0.8 , extended , http-client >=0.7 - , http-client-tls >=0.3.6.3 + , http-client-tls >=0.3 , http-reverse-proxy >=0.4 , http-types >=0.9 , imports From f61d0cd5a19f68f95671b2697dc16983e2465b7d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 31 Jan 2024 14:03:28 +0100 Subject: [PATCH 4/4] Use merged commit for http-client fork --- nix/haskell-pins.nix | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index dc4101bc75..88be5c9094 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -116,10 +116,11 @@ let }; }; + # Our fork because we need to a few special things http-client = { src = fetchgit { url = "https://github.com/wireapp/http-client"; - rev = "e6beaccdcc8fac892d2437ebbff029fef3551a13"; + rev = "37494bb9a89dd52f97a8dc582746c6ff52943934"; sha256 = "sha256-z47GlT+tHsSlRX4ApSGQIpOpaZiBeqr72/tWuvzw8tc="; }; packages = {