diff --git a/changelog.d/5-internal/WPB-3797-do-not-cache-federation-remote-domain-config b/changelog.d/5-internal/WPB-3797-do-not-cache-federation-remote-domain-config new file mode 100644 index 0000000000..dfd7ed0f27 --- /dev/null +++ b/changelog.d/5-internal/WPB-3797-do-not-cache-federation-remote-domain-config @@ -0,0 +1 @@ +Do not cache federation remote configs on non-brig services diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index b76f3159a9..e63734ae29 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -46,7 +46,6 @@ , hspec , hspec-wai , http-api-data -, http-client , http-media , http-types , imports @@ -72,7 +71,6 @@ , quickcheck-instances , random , resourcet -, retry , saml2-web-sso , schema-profunctor , scientific @@ -95,7 +93,6 @@ , tasty-quickcheck , text , time -, tinylog , transitive-anns , types-common , unliftio @@ -119,7 +116,6 @@ mkDerivation { src = gitignoreSource ./.; libraryHaskellDepends = [ aeson - async attoparsec base base64-bytestring @@ -153,7 +149,6 @@ mkDerivation { hscim HsOpenSSL http-api-data - http-client http-media http-types imports @@ -176,7 +171,6 @@ mkDerivation { quickcheck-instances random resourcet - retry saml2-web-sso schema-profunctor scientific @@ -195,7 +189,6 @@ mkDerivation { tagged text time - tinylog transitive-anns types-common unordered-containers diff --git a/libs/wire-api/src/Wire/API/FederationUpdate.hs b/libs/wire-api/src/Wire/API/FederationUpdate.hs index aeb700fa52..d1930d7740 100644 --- a/libs/wire-api/src/Wire/API/FederationUpdate.hs +++ b/libs/wire-api/src/Wire/API/FederationUpdate.hs @@ -1,99 +1,13 @@ module Wire.API.FederationUpdate - ( syncFedDomainConfigs, - SyncFedDomainConfigsCallback (..), - emptySyncFedDomainConfigsCallback, + ( getFederationDomainConfigs, ) where -import Control.Concurrent.Async -import Control.Exception -import Control.Retry qualified as R -import Data.Set qualified as Set -import Data.Text -import Data.Typeable (cast) import Imports -import Network.HTTP.Client (defaultManagerSettings, newManager) -import Servant.Client (BaseUrl (BaseUrl), ClientEnv (ClientEnv), ClientError, Scheme (Http), runClientM) -import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) -import System.Logger qualified as L -import Util.Options +import Servant.Client (ClientEnv, ClientError, runClientM) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Named (namedClient) --- | 'FedUpdateCallback' is not called if a new settings cannot be fetched, or if they are --- equal to the old settings. -syncFedDomainConfigs :: Endpoint -> L.Logger -> SyncFedDomainConfigsCallback -> IO (IORef FederationDomainConfigs, Async ()) -syncFedDomainConfigs (Endpoint h p) log' cb = do - let baseUrl = BaseUrl Http (unpack h) (fromIntegral p) "" - clientEnv <- newManager defaultManagerSettings <&> \mgr -> ClientEnv mgr baseUrl Nothing defaultMakeClientRequest - ioref <- newIORef =<< initialize log' clientEnv - updateDomainsThread <- async $ loop log' clientEnv cb ioref - pure (ioref, updateDomainsThread) - --- | Initial function for getting the set of domains from brig, and an update interval -initialize :: L.Logger -> ClientEnv -> IO FederationDomainConfigs -initialize logger clientEnv = - let policy :: R.RetryPolicy - policy = R.capDelay 30_000_000 $ R.exponentialBackoff 3_000 - - go :: IO (Maybe FederationDomainConfigs) - go = do - fetch clientEnv >>= \case - Right s -> pure $ Just s - Left e -> do - L.log logger L.Info $ - L.msg (L.val "Failed to reach brig for federation setup, retrying...") - L.~~ "error" L..= show e - pure Nothing - in R.retrying policy (const (pure . isNothing)) (const go) >>= \case - Just c -> pure c - Nothing -> throwIO $ ErrorCall "*** Failed to reach brig for federation setup, giving up!" - -loop :: L.Logger -> ClientEnv -> SyncFedDomainConfigsCallback -> IORef FederationDomainConfigs -> IO () -loop logger clientEnv (SyncFedDomainConfigsCallback callback) env = forever $ - catch go $ \(e :: SomeException) -> do - -- log synchronous exceptions - case fromException e of - -- Rethrow async exceptions so that we can kill this thread with the `async` tools - -- The use of cast here comes from https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.IO.Exception.html#asyncExceptionFromException - -- But I only want to check for AsyncCancelled while leaving non-async exception - -- logging in place. - Just (SomeAsyncException e') -> case cast e' of - Just AsyncCancelled -> throwIO e - Nothing -> pure () - Nothing -> - L.log logger L.Error $ - L.msg (L.val "Federation domain sync thread died, restarting domain synchronization.") - L.~~ "error" L..= displayException e - where - go = do - fetch clientEnv >>= \case - Left e -> - L.log logger L.Info $ - L.msg (L.val "Could not retrieve an updated list of federation domains from Brig; I'll keep trying!") - L.~~ "error" L..= displayException e - Right new -> do - old <- readIORef env - unless (domainListsEqual old new) $ callback old new - atomicWriteIORef env new - delay <- updateInterval <$> readIORef env - threadDelay (delay * 1_000_000) - - domainListsEqual o n = - Set.fromList (domain <$> remotes o) - == Set.fromList (domain <$> remotes n) - -fetch :: ClientEnv -> IO (Either ClientError FederationDomainConfigs) -fetch = runClientM (namedClient @IAPI.API @"get-federation-remotes") - --- | The callback takes the previous and the new settings and runs a given action. -newtype SyncFedDomainConfigsCallback = SyncFedDomainConfigsCallback - { fromFedUpdateCallback :: - FederationDomainConfigs -> -- old value - FederationDomainConfigs -> -- new value - IO () - } - -emptySyncFedDomainConfigsCallback :: SyncFedDomainConfigsCallback -emptySyncFedDomainConfigsCallback = SyncFedDomainConfigsCallback $ \_ _ -> pure () +getFederationDomainConfigs :: ClientEnv -> IO (Either ClientError FederationDomainConfigs) +getFederationDomainConfigs = runClientM $ namedClient @IAPI.API @"get-federation-remotes" diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index cb5ea5c163..ef2917257e 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -225,7 +225,6 @@ library build-depends: aeson >=2.0.1.0 - , async , attoparsec >=0.10 , base >=4 && <5 , base64-bytestring >=1.0 @@ -259,7 +258,6 @@ library , hscim , HsOpenSSL , http-api-data - , http-client , http-media , http-types , imports @@ -282,7 +280,6 @@ library , quickcheck-instances >=0.3.16 , random >=1.2.0 , resourcet - , retry , saml2-web-sso , schema-profunctor , scientific @@ -301,7 +298,6 @@ library , tagged , text >=0.11 , time >=1.4 - , tinylog , transitive-anns , types-common >=0.16 , unordered-containers >=0.2 diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 44eaec6d2d..377e7487ae 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -29,7 +29,6 @@ library build-depends: aeson , amqp - , base , containers , exceptions , extended @@ -50,7 +49,6 @@ library , types-common , unliftio , wai-utilities - , wire-api , wire-api-federation default-extensions: diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index 02a2a69851..32ff94e37e 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -17,4 +17,4 @@ rabbitmq: backendNotificationPusher: pushBackoffMinWait: 1000 # 1ms pushBackoffMaxWait: 1000000 # 1s - remotesRefreshInterval: 10000 # 10ms + remotesRefreshInterval: 10000 # 10ms \ No newline at end of file diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 4a6288d509..910b9a396d 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -50,7 +50,6 @@ mkDerivation { libraryHaskellDepends = [ aeson amqp - base containers exceptions extended @@ -71,7 +70,6 @@ mkDerivation { types-common unliftio wai-utilities - wire-api wire-api-federation ]; executableHaskellDepends = [ HsOpenSSL imports types-common ]; diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 793bafd418..3bcceafac4 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -118,7 +118,6 @@ startPusher consumersRef chan = do consumers <- liftIO $ readIORef consumersRef traverse_ (liftIO . Q.cancelConsumer chan . fst) $ Map.elems consumers throwM e - timeBeforeNextRefresh <- asks (.backendNotificationsConfig.remotesRefreshInterval) -- If this thread is cancelled, catch the exception, kill the consumers, and carry on. -- FUTUREWORK?: diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index ef99676c49..0d3080595f 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -3,7 +3,6 @@ module Wire.BackgroundWorker.Env where -import Control.Concurrent.Chan import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control @@ -22,7 +21,6 @@ import System.Logger qualified as Log import System.Logger.Class (Logger, MonadLogger (..)) import System.Logger.Extended qualified as Log import Util.Options -import Wire.API.Routes.FederationDomainConfig import Wire.BackgroundWorker.Options type IsWorking = Bool @@ -41,7 +39,6 @@ data Env = Env federatorInternal :: Endpoint, httpManager :: Manager, defederationTimeout :: ResponseTimeout, - remoteDomainsChan :: Chan FederationDomainConfigs, backendNotificationMetrics :: BackendNotificationMetrics, backendNotificationsConfig :: BackendNotificationsConfig, statuses :: IORef (Map Worker IsWorking) @@ -65,7 +62,6 @@ mkEnv opts = do http2Manager <- initHttp2Manager logger <- Log.mkLogger opts.logLevel Nothing opts.logFormat httpManager <- newManager defaultManagerSettings - remoteDomainsChan <- newChan let federatorInternal = opts.federatorInternal defederationTimeout = maybe diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 0aa74d531f..243eb3d864 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -4,7 +4,6 @@ module Test.Wire.BackendNotificationPusherSpec where -import Control.Concurrent.Chan import Control.Exception import Control.Monad.Trans.Except import Data.Aeson qualified as Aeson @@ -181,7 +180,6 @@ spec = do ] logger <- Logger.new Logger.defSettings httpManager <- newManager defaultManagerSettings - remoteDomainsChan <- newChan let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined statuses = undefined @@ -200,7 +198,6 @@ spec = do mockAdmin <- newMockRabbitMqAdmin True ["backend-notifications.foo.example"] logger <- Logger.new Logger.defSettings httpManager <- newManager defaultManagerSettings - remoteDomainsChan <- newChan let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined statuses = undefined diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 22a7c38dce..ba698cccc2 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -2,12 +2,12 @@ module Test.Wire.Util where -import Control.Concurrent.Chan import Imports import Network.HTTP.Client import System.Logger.Class qualified as Logger import Util.Options (Endpoint (..)) -import Wire.BackgroundWorker.Env +import Wire.BackgroundWorker.Env hiding (federatorInternal) +import Wire.BackgroundWorker.Env qualified as E import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util @@ -18,7 +18,6 @@ testEnv = do statuses <- newIORef mempty backendNotificationMetrics <- mkBackendNotificationMetrics httpManager <- newManager defaultManagerSettings - remoteDomainsChan <- newChan let federatorInternal = Endpoint "localhost" 0 rabbitmqAdminClient = undefined rabbitmqVHost = undefined diff --git a/services/federator/default.nix b/services/federator/default.nix index 7aafe2dc58..44acd863cc 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -110,6 +110,7 @@ mkDerivation { polysemy-wire-zoo prometheus-client servant + servant-client servant-client-core servant-server text diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index 4a5228e30c..0d52c23175 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -137,6 +137,7 @@ library , polysemy-wire-zoo , prometheus-client , servant + , servant-client , servant-client-core , servant-server , text diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index 07d75c19ad..12f3670ef1 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -34,7 +34,6 @@ import Prometheus import System.Logger.Class qualified as LC import Util.Options import Wire.API.Federation.Component -import Wire.API.Routes.FederationDomainConfig (FederationDomainConfigs) data FederatorMetrics = FederatorMetrics { outgoingRequests :: Vector Text Counter, @@ -47,7 +46,6 @@ data Env = Env _requestId :: RequestId, _dnsResolver :: Resolver, _runSettings :: RunSettings, - _domainConfigs :: IORef FederationDomainConfigs, _service :: Component -> Endpoint, _externalPort :: Word16, _internalPort :: Word16, diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index e7089d9a6d..ae248f01e1 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -54,10 +54,14 @@ import Polysemy.Input import Polysemy.Internal import Polysemy.TinyLog import Servant hiding (ServerError, respond, serve) +import Servant.Client (mkClientEnv) import Servant.Client.Core import Servant.Server.Generic import Servant.Types.SourceT -import Wire.API.Routes.FederationDomainConfig +import Util.Options (Endpoint (..)) +import Wire.API.FederationUpdate qualified as FedUp (getFederationDomainConfigs) +import Wire.API.MakesFederatedCall (Component (Brig)) +import Wire.API.Routes.FederationDomainConfig qualified as FedUp (FederationDomainConfigs) import Wire.Network.DNS.Effect import Wire.Sem.Logger.TinyLog @@ -145,7 +149,7 @@ type AllEffects = ServiceStreaming, Input RunSettings, Input Http2Manager, -- needed by Remote - Input FederationDomainConfigs, -- needed for the domain list. + Input FedUp.FederationDomainConfigs, -- needed for the domain list and federation policy. Input Env, -- needed by Service Error ValidationError, Error RemoteError, @@ -170,7 +174,7 @@ runFederator env = DiscoveryFailure ] . runInputConst env - . runInputSem (embed @IO (readIORef (view domainConfigs env))) + . runInputSem (embed @IO (getFederationDomainConfigs env)) . runInputSem (embed @IO (readIORef (view http2Manager env))) . runInputConst (view runSettings env) . interpretServiceHTTP @@ -179,6 +183,16 @@ runFederator env = . interpretRemote . interpretMetrics +getFederationDomainConfigs :: Env -> IO FedUp.FederationDomainConfigs +getFederationDomainConfigs env = do + let mgr = env ^. httpManager + Endpoint h p = env ^. service $ Brig + baseurl = BaseUrl Http (cs h) (fromIntegral p) "" + clientEnv = mkClientEnv mgr baseurl + FedUp.getFederationDomainConfigs clientEnv >>= \case + Right v -> pure v + Left e -> error $ show e + streamingResponseToWai :: StreamingResponse -> Wai.Response streamingResponseToWai resp = let headers = toList (responseHeaders resp) diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index 3b73ab7051..ebdf4cb295 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -52,8 +52,6 @@ import System.Logger qualified as Log import System.Logger.Extended qualified as LogExt import Util.Options import Wire.API.Federation.Component -import Wire.API.FederationUpdate -import Wire.API.Routes.FederationDomainConfig import Wire.Network.DNS.Helper qualified as DNS ------------------------------------------------------------------------------ @@ -65,14 +63,13 @@ run opts = do let resolvConf = mkResolvConf (optSettings opts) DNS.defaultResolvConf DNS.withCachingResolver resolvConf $ \res -> do logger <- LogExt.mkLogger (Opt.logLevel opts) (Opt.logNetStrings opts) (Opt.logFormat opts) - (ioref, updateFedDomainsThread) <- syncFedDomainConfigs (brig opts) logger emptySyncFedDomainConfigsCallback - bracket (newEnv opts res logger ioref) closeEnv $ \env -> do + bracket (newEnv opts res logger) closeEnv $ \env -> do let externalServer = serveInward env portExternal internalServer = serveOutward env portInternal withMonitor logger (onNewSSLContext env) (optSettings opts) $ do internalServerThread <- async internalServer externalServerThread <- async externalServer - void $ waitAnyCancel [updateFedDomainsThread, internalServerThread, externalServerThread] + void $ waitAnyCancel [internalServerThread, externalServerThread] where endpointInternal = federatorInternal opts portInternal = fromIntegral $ endpointInternal ^. port @@ -92,8 +89,8 @@ run opts = do ------------------------------------------------------------------------------- -- Environment -newEnv :: Opts -> DNS.Resolver -> Log.Logger -> IORef FederationDomainConfigs -> IO Env -newEnv o _dnsResolver _applog _domainConfigs = do +newEnv :: Opts -> DNS.Resolver -> Log.Logger -> IO Env +newEnv o _dnsResolver _applog = do _metrics <- Metrics.metrics let _requestId = def _runSettings = Opt.optSettings o