From 929a3115d030873a0820eb47942dfc94d782dd3c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Elland <54423+elland@users.noreply.github.com> Date: Thu, 11 Jan 2024 12:32:37 +0100 Subject: [PATCH 1/3] Revert "Revert "Migrate away from our http-client fork, use upstream."" --- integration/integration.cabal | 1 + libs/bilge/src/Bilge/IO.hs | 2 +- libs/ssl-util/default.nix | 4 +- libs/ssl-util/src/Ssl/Util.hs | 70 +++++++++---------- libs/ssl-util/ssl-util.cabal | 12 ++-- libs/types-common-aws/default.nix | 2 - libs/types-common-aws/src/AWS/Util.hs | 1 - libs/types-common-aws/src/Util/Test/SQS.hs | 10 ++- libs/types-common-aws/types-common-aws.cabal | 1 - nix/haskell-pins.nix | 32 --------- nix/manual-overrides.nix | 15 +--- services/brig/brig.cabal | 2 +- services/brig/src/Brig/AWS.hs | 21 ++++-- services/brig/src/Brig/App.hs | 43 ++++++------ services/brig/src/Brig/Data/Client.hs | 15 ++-- services/brig/src/Brig/Provider/RPC.hs | 10 +-- services/cargohold/cargohold.cabal | 2 +- services/cargohold/src/CargoHold/AWS.hs | 35 ++++++++-- services/cargohold/src/CargoHold/S3.hs | 15 +++- services/galley/galley.cabal | 1 + services/galley/src/Galley/App.hs | 4 +- services/galley/src/Galley/Aws.hs | 9 ++- services/galley/src/Galley/Env.hs | 45 +++++------- services/galley/src/Galley/External.hs | 8 ++- .../External/LegalHoldService/Internal.hs | 22 +++--- services/gundeck/gundeck.cabal | 2 +- services/gundeck/src/Gundeck/Aws.hs | 12 +++- services/proxy/proxy.cabal | 2 +- 28 files changed, 205 insertions(+), 193 deletions(-) diff --git a/integration/integration.cabal b/integration/integration.cabal index 9e66ec69699..26428be73ce 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -24,6 +24,7 @@ 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/bilge/src/Bilge/IO.hs b/libs/bilge/src/Bilge/IO.hs index 655cc04f85b..f9ec36060ef 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 -> Client.Request -> Response BodyReader + toBilgeResponse :: BodyReader -> WaiTest.SResponse -> Request -> Response BodyReader toBilgeResponse bodyReader WaiTest.SResponse {WaiTest.simpleStatus, WaiTest.simpleHeaders} originalReq = Client.Response { responseStatus = simpleStatus, diff --git a/libs/ssl-util/default.nix b/libs/ssl-util/default.nix index 1ec717b7f74..7c3753ef172 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 9f9d8ece4e4..a7375a4084a 100644 --- a/libs/ssl-util/src/Ssl/Util.hs +++ b/libs/ssl-util/src/Ssl/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeApplications #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -28,25 +26,27 @@ module Ssl.Util -- * Cipher suites rsaCiphers, - -- * Network - withVerifiedSslConnection, + -- * to be used when initializing SSL Contexts to obtain SSL enabled + + -- 'Network.HTTP.Client.ManagerSettings' + extEnvCallback, ) where import Control.Exception import Data.ByteString.Builder import Data.Byteable (constEqBytes) -import Data.Dynamic (fromDynamic) +import Data.Misc (Fingerprint (fingerprintBytes), Rsa) import Data.Time.Clock (getCurrentTime) import Imports -import Network.HTTP.Client.Internal import OpenSSL.BN (integerToMPI) -import OpenSSL.EVP.Digest (Digest, digestLBS) +import OpenSSL.EVP.Digest (Digest, digestLBS, getDigestByName) 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,34 +180,28 @@ verifyRsaFingerprint d = verifyFingerprint $ \pk -> -- [1] https://wiki.openssl.org/index.php/Hostname_validation -- [2] https://www.cs.utexas.edu/~shmat/shmat_ccs12.pdf --- 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 +-- | 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) diff --git a/libs/ssl-util/ssl-util.cabal b/libs/ssl-util/ssl-util.cabal index 9c306e564e9..34deab65ed1 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 - , http-client >=0.7 + base >=4.7 && <5 + , byteable >=0.1 + , bytestring >=0.10 + , HsOpenSSL >=0.11 , imports - , time >=1.5 + , time >=1.5 + , types-common default-language: GHC2021 diff --git a/libs/types-common-aws/default.nix b/libs/types-common-aws/default.nix index d5c1882029d..740a128a003 100644 --- a/libs/types-common-aws/default.nix +++ b/libs/types-common-aws/default.nix @@ -4,7 +4,6 @@ # dependencies are added or removed. { mkDerivation , amazonka -, amazonka-core , amazonka-sqs , base , base64-bytestring @@ -24,7 +23,6 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ amazonka - amazonka-core amazonka-sqs base base64-bytestring diff --git a/libs/types-common-aws/src/AWS/Util.hs b/libs/types-common-aws/src/AWS/Util.hs index a8f0fac2a08..56277fa825a 100644 --- a/libs/types-common-aws/src/AWS/Util.hs +++ b/libs/types-common-aws/src/AWS/Util.hs @@ -18,7 +18,6 @@ module AWS.Util where import Amazonka qualified as AWS -import Amazonka.Data.Time qualified as AWS import Data.Time import Imports diff --git a/libs/types-common-aws/src/Util/Test/SQS.hs b/libs/types-common-aws/src/Util/Test/SQS.hs index 107f73c8fe7..6a527482150 100644 --- a/libs/types-common-aws/src/Util/Test/SQS.hs +++ b/libs/types-common-aws/src/Util/Test/SQS.hs @@ -164,5 +164,13 @@ parseDeleteMessage url m = do liftIO $ putStrLn $ "Failed to delete message, this error will be ignored. Message: " <> show m <> ", Exception: " <> displayException e pure evt -sendEnv :: (MonadReader AWS.Env m, MonadResource m, AWS.AWSRequest a) => a -> m (AWS.AWSResponse a) +sendEnv :: + ( MonadReader AWS.Env m, + MonadResource m, + Typeable a, + Typeable (AWS.AWSResponse a), + AWS.AWSRequest a + ) => + a -> + m (AWS.AWSResponse a) sendEnv x = flip AWS.send x =<< ask diff --git a/libs/types-common-aws/types-common-aws.cabal b/libs/types-common-aws/types-common-aws.cabal index 925d9ee217e..e934b2e8f19 100644 --- a/libs/types-common-aws/types-common-aws.cabal +++ b/libs/types-common-aws/types-common-aws.cabal @@ -78,7 +78,6 @@ library ghc-prof-options: -fprof-auto-exported build-depends: amazonka - , amazonka-core , amazonka-sqs , base >=4 && <5 , base64-bytestring >=1.0 diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index c4290b5253e..a9819538951 100644 --- a/nix/haskell-pins.nix +++ b/nix/haskell-pins.nix @@ -73,25 +73,6 @@ let sha256 = "sha256-ov85XFztGM0mEoj01lRZN9xYJttKa/crPnp0lh4A5DA="; }; }; - amazonka = { - src = fetchgit { - url = "https://github.com/brendanhay/amazonka"; - rev = "cfe2584aef0b03c86650372d362c74f237925d8c"; - sha256 = "sha256-ss8IuIN0BbS6LMjlaFmUdxUqQu+IHsA8ucsjxXJwbyg="; - }; - packages = { - amazonka = "lib/amazonka"; - amazonka-core = "lib/amazonka-core"; - amazonka-cloudfront = "lib/services/amazonka-cloudfront"; - amazonka-dynamodb = "lib/services/amazonka-dynamodb"; - amazonka-s3 = "lib/services/amazonka-s3"; - amazonka-ses = "lib/services/amazonka-ses"; - amazonka-sns = "lib/services/amazonka-sns"; - amazonka-sqs = "lib/services/amazonka-sqs"; - amazonka-sso = "lib/services/amazonka-sso"; - amazonka-sts = "lib/services/amazonka-sts"; - }; - }; bloodhound = { src = fetchgit { url = "https://github.com/wireapp/bloodhound"; @@ -122,19 +103,6 @@ let sha256 = "sha256-jYJBhXBQ1MTLPI8JsiF2XUtgDxK+eniavNB2B1zaSQg="; }; }; - http-client = { - src = fetchgit { - url = "https://github.com/wireapp/http-client"; - rev = "eabf64b4a8ff4c0fe6a3b39cb0f396ba8c2fb236"; - sha256 = "sha256-8NPRVDlul9Xnj6IyUOUe6w7fDt/5WWZNjR07CaAp/Kk="; - }; - packages = { - http-client = "http-client"; - http-client-openssl = "http-client-openssl"; - http-client-tls = "http-client-tls"; - http-conduit = "http-conduit"; - }; - }; hspec-wai = { src = fetchgit { url = "https://github.com/wireapp/hspec-wai"; diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix index f4e91ba2cb0..e14e391983b 100644 --- a/nix/manual-overrides.nix +++ b/nix/manual-overrides.nix @@ -63,6 +63,8 @@ hself: hsuper: { hsaml2 = hlib.dontCheck hsuper.hsaml2; saml2-web-sso = hlib.dontCheck hsuper.saml2-web-sso; http2 = hlib.dontCheck hsuper.http2; + http-client-tls = hsuper.http-client-tls_0_3_6_3; + http-client = hsuper.http-client; # Disable tests because they need network access to a running cassandra @@ -77,19 +79,6 @@ hself: hsuper: { # due to related broken quickcheck-arbitrary-template bloodhound = hlib.dontCheck hsuper.bloodhound; - # These tests require newer version on hspec-wai, which doesn't work with some of the wire-server packages. - amazonka = hlib.doJailbreak (hlib.dontCheck hsuper.amazonka); - amazonka-cloudfront = hlib.dontCheck hsuper.amazonka-cloudfront; - amazonka-core = hlib.doJailbreak (hlib.dontCheck hsuper.amazonka-core); - amazonka-dynamodb = hlib.dontCheck hsuper.amazonka-dynamodb; - amazonka-s3 = hlib.dontCheck hsuper.amazonka-s3; - amazonka-ses = hlib.dontCheck hsuper.amazonka-ses; - amazonka-sns = hlib.dontCheck hsuper.amazonka-sns; - amazonka-sqs = hlib.dontCheck hsuper.amazonka-sqs; - amazonka-sso = hlib.dontCheck hsuper.amazonka-sso; - amazonka-sts = hlib.dontCheck hsuper.amazonka-sts; - servant-server = hlib.dontCheck hsuper.servant-server; - # Build toool dependencies of local packages types-common-journal = hlib.addBuildTool hsuper.types-common-journal protobuf; wire-api = hlib.addBuildTool hsuper.wire-api mls-test-cli; diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 186d119f6af..a1822e3cec0 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -465,7 +465,7 @@ executable brig-integration , HsOpenSSL , http-api-data , http-client - , http-client-tls >=0.3 + , http-client-tls >=0.3.6.3 , http-media , http-reverse-proxy , http-types diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index cb687c41bea..54a93e85c5b 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -235,19 +235,27 @@ sendMail m = do -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWSRequest r => r -> Amazon (Either AWS.Error (AWSResponse r)) +sendCatch :: (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => r -> Amazon (Either AWS.Error (AWSResponse r)) sendCatch req = do env <- view amazonkaEnv AWS.trying AWS._Error . AWS.send env $ req -send :: AWSRequest r => r -> Amazon (AWSResponse r) +send :: + (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => + r -> + Amazon (AWSResponse r) send r = throwA =<< sendCatch r throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) pure execCatch :: - (AWSRequest a, MonadUnliftIO m, MonadCatch m) => + ( AWSRequest a, + Typeable a, + MonadUnliftIO m, + Typeable (AWSResponse a), + MonadCatch m + ) => AWS.Env -> a -> m (Either AWS.Error (AWSResponse a)) @@ -257,7 +265,12 @@ execCatch e cmd = AWS.send e cmd exec :: - (AWSRequest a, MonadCatch m, MonadIO m) => + ( AWSRequest a, + Typeable a, + Typeable (AWSResponse a), + MonadCatch m, + MonadIO m + ) => AWS.Env -> a -> m (AWSResponse a) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 0b685c53e87..439aae35de3 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -112,8 +112,7 @@ import Control.Error import Control.Lens hiding (index, (.=)) import Control.Monad.Catch import Control.Monad.Trans.Resource -import Data.ByteString.Conversion -import Data.Domain +import Data.Domain (Domain) import Data.Metrics (Metrics) import Data.Metrics.Middleware qualified as Metrics import Data.Misc @@ -173,7 +172,7 @@ data Env = Env _templateBranding :: TemplateBranding, _httpManager :: Manager, _http2Manager :: Http2Manager, - _extGetManager :: (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()), + _extGetManager :: [Fingerprint Rsa] -> IO Manager, _settings :: Settings, _nexmoCreds :: Nexmo.Credentials, _twilioCreds :: Twilio.Credentials, @@ -210,7 +209,6 @@ newEnv o = do cas <- initCassandra o lgr mgr <- initHttpManager h2Mgr <- initHttp2Manager - ext <- initExtGetManager utp <- loadUserTemplates o ptp <- loadProviderTemplates o ttp <- loadTeamTemplates o @@ -269,7 +267,7 @@ newEnv o = do _templateBranding = branding, _httpManager = mgr, _http2Manager = h2Mgr, - _extGetManager = ext, + _extGetManager = initExtGetManager, _settings = sett, _nexmoCreds = nxm, _twilioCreds = twl, @@ -361,29 +359,28 @@ initHttp2Manager = do -- faster. So, we reuse the context. -- TODO: somewhat duplicates Galley.App.initExtEnv -initExtGetManager :: IO (Manager, [Fingerprint Rsa] -> SSL.SSL -> IO ()) -initExtGetManager = 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 SSL.contextSetCiphers ctx rsaCiphers - -- 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.contextSetVerificationMode + ctx + SSL.VerifyPeer + { vpFailIfNoPeerCert = True, + vpClientOnce = False, + vpCallback = Just \_b -> extEnvCallback fingerprints + } + SSL.contextSetDefaultVerifyPaths ctx - 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 + + newManager + (opensslManagerSettings (pure ctx)) -- see Note [SSL context] + { managerConnCount = 100, + managerIdleConnectionCount = 512, + managerResponseTimeout = responseTimeoutMicro 10000000 + } initCassandra :: Opts -> Logger -> IO Cas.ClientState initCassandra o g = diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 2a3909023b8..df50eb6465a 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -516,11 +516,11 @@ withOptLock u c ma = go (10 :: Int) Nothing -> reportFailureAndLogError >> pure a Just _ -> pure a version :: AWS.GetItemResponse -> Maybe Word32 - version v = conv =<< HashMap.lookup ddbVersion (view AWS.getItemResponse_item v) + version v = conv . HashMap.lookup ddbVersion =<< (view AWS.getItemResponse_item v) where - conv :: AWS.AttributeValue -> Maybe Word32 + conv :: Maybe AWS.AttributeValue -> Maybe Word32 conv = \case - AWS.N t -> readMaybe $ Text.unpack t + Just (AWS.N t) -> readMaybe $ Text.unpack t _ -> Nothing get :: Text -> AWS.GetItem get t = @@ -555,7 +555,12 @@ withOptLock u c ma = go (10 :: Int) . Log.field "client" (toByteString' c) . msg (val "PreKeys: Optimistic lock failed") Metrics.counterIncr (Metrics.path "client.opt_lock.optimistic_lock_failed") =<< view metrics - execDyn :: forall r x. (AWS.AWSRequest r) => (AWS.AWSResponse r -> Maybe x) -> (Text -> r) -> m (Maybe x) + execDyn :: + forall r x. + (AWS.AWSRequest r, Typeable r, Typeable (AWS.AWSResponse r)) => + (AWS.AWSResponse r -> Maybe x) -> + (Text -> r) -> + m (Maybe x) execDyn cnv mkCmd = do cmd <- mkCmd <$> view (awsEnv . prekeyTable) e <- view (awsEnv . amazonkaEnv) @@ -564,7 +569,7 @@ withOptLock u c ma = go (10 :: Int) where execDyn' :: forall y p. - AWS.AWSRequest p => + (AWS.AWSRequest p, Typeable (AWS.AWSResponse p), Typeable p) => AWS.Env -> Metrics.Metrics -> (AWS.AWSResponse p -> Maybe y) -> diff --git a/services/brig/src/Brig/Provider/RPC.hs b/services/brig/src/Brig/Provider/RPC.hs index fd91cac91bb..72441482166 100644 --- a/services/brig/src/Brig/Provider/RPC.hs +++ b/services/brig/src/Brig/Provider/RPC.hs @@ -49,7 +49,6 @@ 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 @@ -72,16 +71,17 @@ data ServiceError createBot :: ServiceConn -> NewBotRequest -> ExceptT ServiceError (AppT r) NewBotResponse createBot scon new = do let fprs = toList (sconFingerprints scon) - (man, verifyFingerprints) <- view extGetManager + manF <- view extGetManager + man <- liftIO $ manF fprs extHandleAll onExc $ do + let req = reqBuilder Http.defaultRequest rs <- lift $ wrapHttp $ recovering x3 httpHandlers $ const $ liftIO $ - withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ - \req -> - Http.httpLbs req man + Http.withConnection req man $ + \_conn -> 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 7723b5814f9..b82b8218b5f 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 + , http-client-tls >=0.3.6.3 , http-media , http-types >=0.8 , imports diff --git a/services/cargohold/src/CargoHold/AWS.hs b/services/cargohold/src/CargoHold/AWS.hs index 4593fa6d7d3..38b8ecc260f 100644 --- a/services/cargohold/src/CargoHold/AWS.hs +++ b/services/cargohold/src/CargoHold/AWS.hs @@ -157,17 +157,32 @@ instance Exception Error -------------------------------------------------------------------------------- -- Utilities -sendCatch :: (MonadCatch m, AWSRequest r, MonadResource m) => AWS.Env -> r -> m (Either AWS.Error (AWSResponse r)) +sendCatch :: + (MonadCatch m, AWSRequest r, MonadResource m, Typeable r, Typeable (AWSResponse r)) => + AWS.Env -> + r -> + m (Either AWS.Error (AWSResponse r)) sendCatch env = AWS.trying AWS._Error . AWS.send env -send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) +send :: + (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => + AWS.Env -> + r -> + Amazon (AWSResponse r) send env r = throwA =<< sendCatch env r throwA :: Either AWS.Error a -> Amazon a throwA = either (throwM . GeneralError) pure exec :: - (AWSRequest r, Show r, MonadLogger m, MonadIO m, MonadThrow m) => + ( AWSRequest r, + Typeable r, + Typeable (AWSResponse r), + Show r, + MonadLogger m, + MonadIO m, + MonadThrow m + ) => Env -> (Text -> r) -> m (AWSResponse r) @@ -186,7 +201,11 @@ exec env request = do Right r -> pure r execStream :: - (AWSRequest r, Show r) => + ( AWSRequest r, + Typeable r, + Typeable (AWSResponse r), + Show r + ) => Env -> (Text -> r) -> ResourceT IO (AWSResponse r) @@ -205,7 +224,13 @@ execStream env request = do Right r -> pure r execCatch :: - (AWSRequest r, Show r, MonadLogger m, MonadIO m) => + ( AWSRequest r, + Typeable r, + Typeable (AWSResponse r), + Show r, + MonadLogger m, + MonadIO m + ) => Env -> (Text -> r) -> m (Maybe (AWSResponse r)) diff --git a/services/cargohold/src/CargoHold/S3.hs b/services/cargohold/src/CargoHold/S3.hs index 72695f0f477..181b2f9255c 100644 --- a/services/cargohold/src/CargoHold/S3.hs +++ b/services/cargohold/src/CargoHold/S3.hs @@ -350,13 +350,24 @@ parseAmzMeta k h = lookupCI k h >>= fromByteString . encodeUtf8 octets :: MIME.Type octets = MIME.Type (MIME.Application "octet-stream") [] -exec :: (AWSRequest r, Show r) => (Text -> r) -> ExceptT Error App (AWSResponse r) +exec :: + ( AWSRequest r, + Typeable r, + Typeable (AWSResponse r), + Show r + ) => + (Text -> r) -> + ExceptT Error App (AWSResponse r) exec req = do env <- view aws AWS.exec env req execCatch :: - (AWSRequest r, Show r) => + ( AWSRequest r, + Typeable r, + Typeable (AWSResponse r), + Show r + ) => (Text -> r) -> ExceptT Error App (Maybe (AWSResponse r)) execCatch req = do diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 8561169ce01..941488970c8 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -25,6 +25,7 @@ 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 14873001deb..1680941a3e0 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -30,9 +30,7 @@ module Galley.App cstate, deleteQueue, createEnv, - extEnv, aEnv, - ExtEnv (..), extGetManager, -- * Running Galley effects @@ -162,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 - <*> initExtEnv + <*> 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/Aws.hs b/services/galley/src/Galley/Aws.hs index 07a84b42fca..2a7050784f6 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -176,7 +176,14 @@ enqueue e = do -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWS.AWSRequest r => AWS.Env -> r -> Amazon (Either AWS.Error (AWS.AWSResponse r)) +sendCatch :: + ( AWS.AWSRequest r, + Typeable r, + Typeable (AWS.AWSResponse r) + ) => + AWS.Env -> + r -> + Amazon (Either AWS.Error (AWS.AWSResponse r)) sendCatch e = AWS.trying AWS._Error . AWS.send e canRetry :: MonadIO m => Either AWS.Error a -> m Bool diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 2bdb38c27ff..4a9687c3e3d 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -22,10 +22,9 @@ 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 @@ -36,7 +35,6 @@ 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 @@ -60,45 +58,38 @@ data Env = Env _brig :: Endpoint, -- FUTUREWORK: see _federator _cstate :: ClientState, _deleteQueue :: Q.Queue DeleteItem, - _extEnv :: ExtEnv, + _extGetManager :: [Fingerprint Rsa] -> IO Manager, _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 :: IO ExtEnv -initExtEnv = do +initExtEnv :: [Fingerprint Rsa] -> IO Manager +initExtEnv fingerprints = 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 - 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 + + newManager + (opensslManagerSettings (pure ctx)) + { managerResponseTimeout = responseTimeoutMicro 10000000, + managerConnCount = 100 + } reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 605ac731d0e..fd775f44e34 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,8 +151,10 @@ urlPort (HttpsUrl u) = do sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do - (man, verifyFingerprints) <- view (extEnv . extGetManager) - liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> + mkMgr <- view extGetManager + man <- liftIO $ mkMgr fprs + let req = reqBuilder defaultRequest + liftIO $ withConnection req man $ \_conn -> Http.withResponse req man (const $ pure ()) x3 :: RetryPolicy diff --git a/services/galley/src/Galley/External/LegalHoldService/Internal.hs b/services/galley/src/Galley/External/LegalHoldService/Internal.hs index 5c23e1ca84a..713daf9edf1 100644 --- a/services/galley/src/Galley/External/LegalHoldService/Internal.hs +++ b/services/galley/src/Galley/External/LegalHoldService/Internal.hs @@ -34,23 +34,20 @@ 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 -> ([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] +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 extHandleAll errHandler $ do recovering x3 httpHandlers $ const $ liftIO $ - withVerifiedSslConnection verified mgr (reqBuilderMods . reqBuilder) $ - \req -> - Http.httpLbs req mgr + Http.withConnection req mgr $ \_conn -> + Http.httpLbs req mgr where reqBuilderMods = maybe id Bilge.host (Bilge.extHost url) @@ -81,8 +78,9 @@ makeVerifiedRequest :: (Http.Request -> Http.Request) -> App (Http.Response LC8.ByteString) makeVerifiedRequest fpr url reqBuilder = do - (mgr, verifyFingerprints) <- view (extEnv . extGetManager) - makeVerifiedRequestWithManager mgr verifyFingerprints fpr url reqBuilder + mkMgr <- view extGetManager + mgr <- liftIO $ mkMgr [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 @@ -94,5 +92,5 @@ makeVerifiedRequestFreshManager :: (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 + mgr <- liftIO $ initExtEnv [fpr] + makeVerifiedRequestWithManager mgr url reqBuilder diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index ce1b2c82ac4..af1d57c6626 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 + , http-client-tls >=0.3.6.3 , http-types >=0.8 , imports , lens >=4.4 diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index a2afe84128e..b1636f33b7c 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -482,10 +482,18 @@ listen throttleMillis callback = do -------------------------------------------------------------------------------- -- Utilities -sendCatch :: AWSRequest r => AWS.Env -> r -> Amazon (Either AWS.Error (AWSResponse r)) +sendCatch :: + (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => + AWS.Env -> + r -> + Amazon (Either AWS.Error (AWSResponse r)) sendCatch env = AWS.trying AWS._Error . AWS.send env -send :: AWSRequest r => AWS.Env -> r -> Amazon (AWSResponse r) +send :: + (AWSRequest r, Typeable r, Typeable (AWSResponse r)) => + AWS.Env -> + r -> + Amazon (AWSResponse r) send env r = either (throwM . GeneralError) pure =<< sendCatch env r is :: AWS.Abbrev -> Int -> AWS.Error -> Bool diff --git a/services/proxy/proxy.cabal b/services/proxy/proxy.cabal index 79da68ca4e9..4e7f7e5302f 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 + , http-client-tls >=0.3.6.3 , http-reverse-proxy >=0.4 , http-types >=0.9 , imports From bfba3245e135b87fa6ebd343189701fc69236ec9 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 11 Jan 2024 12:11:25 +0100 Subject: [PATCH 2/3] Remove workaround fresh http manager for LH --- services/galley/src/Galley/Cassandra/LegalHold.hs | 3 --- .../galley/src/Galley/Effects/LegalHoldStore.hs | 8 +------- .../galley/src/Galley/External/LegalHoldService.hs | 2 +- .../Galley/External/LegalHoldService/Internal.hs | 14 -------------- 4 files changed, 2 insertions(+), 25 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index db37db2657f..ff093396307 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 e91dea42f4c..56d71864c52 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/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index cca80ae8800..c5555bccc16 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 713daf9edf1..a26e5212bd2 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 @@ -81,16 +80,3 @@ makeVerifiedRequest fpr url reqBuilder = do mkMgr <- view extGetManager mgr <- liftIO $ mkMgr [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 [fpr] - makeVerifiedRequestWithManager mgr url reqBuilder From 41266c91ee8b75f1a52668a01b29b724d0e49f4c Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 11 Jan 2024 13:35:15 +0100 Subject: [PATCH 3/3] hi ci