From e7c1fc31fa5af2aae67bcfa517be362c935bacb9 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 26 Sep 2024 10:16:53 +0000 Subject: [PATCH 01/93] create rabbitmq exchange --- deploy/dockerephemeral/docker-compose.yaml | 1 + services/gundeck/gundeck.cabal | 1 + services/gundeck/gundeck.integration.yaml | 8 ++++++++ services/gundeck/src/Gundeck/Env.hs | 8 ++++++-- services/gundeck/src/Gundeck/Options.hs | 2 ++ services/gundeck/src/Gundeck/Run.hs | 16 +++++++++++++++- services/gundeck/test/resources/rabbitmq-ca.pem | 1 + 7 files changed, 34 insertions(+), 3 deletions(-) create mode 120000 services/gundeck/test/resources/rabbitmq-ca.pem diff --git a/deploy/dockerephemeral/docker-compose.yaml b/deploy/dockerephemeral/docker-compose.yaml index 13061660d8c..73c7324ae99 100644 --- a/deploy/dockerephemeral/docker-compose.yaml +++ b/deploy/dockerephemeral/docker-compose.yaml @@ -271,6 +271,7 @@ services: ports: - '127.0.0.1:5671:5671' - '127.0.0.1:15671:15671' + - '127.0.0.1:15672:15672' volumes: - ./rabbitmq-config/rabbitmq.conf:/etc/rabbitmq/conf.d/20-wire.conf - ./rabbitmq-config/certificates:/etc/rabbitmq/certificates diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 19ce66fb3e2..ab7d6a7965f 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -116,6 +116,7 @@ library , amazonka-core >=2 , amazonka-sns >=2 , amazonka-sqs >=2 + , amqp , async >=2.0 , attoparsec >=0.10 , auto-update >=0.1 diff --git a/services/gundeck/gundeck.integration.yaml b/services/gundeck/gundeck.integration.yaml index adf2914f6aa..573aef32637 100644 --- a/services/gundeck/gundeck.integration.yaml +++ b/services/gundeck/gundeck.integration.yaml @@ -34,6 +34,14 @@ aws: sqsEndpoint: http://localhost:4568 # https://sqs.eu-west-1.amazonaws.com snsEndpoint: http://localhost:4575 # https://sns.eu-west-1.amazonaws.com +rabbitMq: + host: 127.0.0.1 + port: 5671 + vHost: / + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false + settings: httpPoolSize: 1024 notificationTTL: 24192200 diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 2397005c68a..a80f5c65be0 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -41,6 +41,8 @@ import Gundeck.Redis qualified as Redis import Gundeck.Redis.HedisExtensions qualified as Redis import Gundeck.ThreadBudget import Imports +import Network.AMQP (Channel) +import Network.AMQP.Extended qualified as Q import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.TLS as TLS @@ -58,7 +60,8 @@ data Env = Env _rstateAdditionalWrite :: !(Maybe Redis.RobustConnection), _awsEnv :: !Aws.Env, _time :: !(IO Milliseconds), - _threadBudgetState :: !(Maybe ThreadBudgetState) + _threadBudgetState :: !(Maybe ThreadBudgetState), + _rabbitMqChannel :: MVar Channel } makeLenses ''Env @@ -101,7 +104,8 @@ createEnv o = do { updateAction = Ms . round . (* 1000) <$> getPOSIXTime } mtbs <- mkThreadBudgetState `mapM` (o ^. settings . maxConcurrentNativePushes) - pure $! (rThread : rAdditionalThreads,) $! Env (RequestId defRequestId) o l n p r rAdditional a io mtbs + rabbitMqChannelMVar <- Q.mkRabbitMqChannelMVar l (o ^. rabbitMq) + pure $! (rThread : rAdditionalThreads,) $! Env (RequestId defRequestId) o l n p r rAdditional a io mtbs rabbitMqChannelMVar reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg reqIdMsg = ("request" Logger..=) . unRequestId diff --git a/services/gundeck/src/Gundeck/Options.hs b/services/gundeck/src/Gundeck/Options.hs index 5f67081e178..f8690dbea57 100644 --- a/services/gundeck/src/Gundeck/Options.hs +++ b/services/gundeck/src/Gundeck/Options.hs @@ -25,6 +25,7 @@ import Data.Aeson.TH import Data.Yaml (FromJSON) import Gundeck.Aws.Arn import Imports +import Network.AMQP.Extended import System.Logger.Extended (Level, LogFormat) import Util.Options import Util.Options.Common @@ -133,6 +134,7 @@ data Opts = Opts _redis :: !RedisEndpoint, _redisAdditionalWrite :: !(Maybe RedisEndpoint), _aws :: !AWSOpts, + _rabbitMq :: !AmqpEndpoint, _discoUrl :: !(Maybe Text), _settings :: !Settings, -- Logging diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index b978b9d6b13..c779dfd20b5 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -42,6 +42,8 @@ import Gundeck.React import Gundeck.Schema.Run (lastSchemaVersion) import Gundeck.ThreadBudget import Imports +import Network.AMQP (ExchangeOpts (exchangeName, exchangeType), declareExchange, newExchange) +import Network.AMQP qualified as Q import Network.Wai as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip @@ -53,6 +55,7 @@ import OpenTelemetry.Trace qualified as Otel import Servant (Handler (Handler), (:<|>) (..)) import Servant qualified import System.Logger qualified as Log +import System.Timeout (timeout) import UnliftIO.Async qualified as Async import Util.Options import Wire.API.Routes.Public.Gundeck (GundeckAPI) @@ -63,9 +66,10 @@ import Wire.OpenTelemetry run :: Opts -> IO () run o = withTracer \tracer -> do (rThreads, e) <- createEnv o + let l = e ^. applog + createUserNotificationExchange l (e ^. rabbitMqChannel) runClient (e ^. cstate) $ versionCheck lastSchemaVersion - let l = e ^. applog s <- newSettings $ defaultServer (unpack . host $ o ^. gundeck) (port $ o ^. gundeck) l let throttleMillis = fromMaybe defSqsThrottleMillis $ o ^. (settings . sqsThrottleMillis) @@ -85,6 +89,16 @@ run o = withTracer \tracer -> do whenJust (e ^. rstateAdditionalWrite) $ (=<<) Redis.disconnect . takeMVar Log.close (e ^. applog) where + createUserNotificationExchange :: Log.Logger -> MVar Q.Channel -> IO () + createUserNotificationExchange l chanMVar = do + mChan <- timeout 1_000_000 $ readMVar chanMVar + case mChan of + -- TODO(leif): we should probably fail here + Nothing -> Log.err l $ Log.msg (Log.val "RabbitMQ could not get channel") + Just chan -> do + Log.info l $ Log.msg (Log.val "RabbitMQ declaring exchange") + declareExchange chan newExchange {exchangeName = "user-notifications", exchangeType = "direct"} + middleware :: Env -> IO Middleware middleware e = do otelMiddleWare <- newOpenTelemetryWaiMiddleware diff --git a/services/gundeck/test/resources/rabbitmq-ca.pem b/services/gundeck/test/resources/rabbitmq-ca.pem new file mode 120000 index 00000000000..ca91c2c31bd --- /dev/null +++ b/services/gundeck/test/resources/rabbitmq-ca.pem @@ -0,0 +1 @@ +../../../../deploy/dockerephemeral/rabbitmq-config/certificates/ca.pem \ No newline at end of file From 3d70eadf2b0fb827f34c4b77458549487a1a0465 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 26 Sep 2024 12:05:01 +0000 Subject: [PATCH 02/93] set up DLX --- services/gundeck/src/Gundeck/Run.hs | 80 ++++++++++++++++++----------- 1 file changed, 51 insertions(+), 29 deletions(-) diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index c779dfd20b5..733965e5e39 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -26,10 +26,12 @@ import Control.Error (ExceptT (ExceptT)) import Control.Exception (finally) import Control.Lens ((.~), (^.)) import Control.Monad.Extra +import Data.Map qualified as Map import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Text (unpack) +import Data.Text.Encoding (encodeUtf8) import Database.Redis qualified as Redis import Gundeck.API.Internal as Internal (InternalAPI, servantSitemap) import Gundeck.API.Public as Public (servantSitemap) @@ -42,8 +44,8 @@ import Gundeck.React import Gundeck.Schema.Run (lastSchemaVersion) import Gundeck.ThreadBudget import Imports -import Network.AMQP (ExchangeOpts (exchangeName, exchangeType), declareExchange, newExchange) -import Network.AMQP qualified as Q +import Network.AMQP +import Network.AMQP.Types (FieldTable (FieldTable), FieldValue (FVString)) import Network.Wai as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip @@ -64,52 +66,72 @@ import Wire.API.Routes.Version.Wai import Wire.OpenTelemetry run :: Opts -> IO () -run o = withTracer \tracer -> do - (rThreads, e) <- createEnv o - let l = e ^. applog - createUserNotificationExchange l (e ^. rabbitMqChannel) - runClient (e ^. cstate) $ +run opts = withTracer \tracer -> do + (rThreads, env) <- createEnv opts + let logger = env ^. applog + + setUpRabbitMqExchangesAndQueues logger (env ^. rabbitMqChannel) + + runClient (env ^. cstate) $ versionCheck lastSchemaVersion - s <- newSettings $ defaultServer (unpack . host $ o ^. gundeck) (port $ o ^. gundeck) l - let throttleMillis = fromMaybe defSqsThrottleMillis $ o ^. (settings . sqsThrottleMillis) + s <- newSettings $ defaultServer (unpack . host $ opts ^. gundeck) (port $ opts ^. gundeck) logger + let throttleMillis = fromMaybe defSqsThrottleMillis $ opts ^. (settings . sqsThrottleMillis) - lst <- Async.async $ Aws.execute (e ^. awsEnv) (Aws.listen throttleMillis (runDirect e . onEvent)) - wtbs <- forM (e ^. threadBudgetState) $ \tbs -> Async.async $ runDirect e $ watchThreadBudgetState tbs 10 - wCollectAuth <- Async.async (collectAuthMetrics (Aws._awsEnv (Env._awsEnv e))) + lst <- Async.async $ Aws.execute (env ^. awsEnv) (Aws.listen throttleMillis (runDirect env . onEvent)) + wtbs <- forM (env ^. threadBudgetState) $ \tbs -> Async.async $ runDirect env $ watchThreadBudgetState tbs 10 + wCollectAuth <- Async.async (collectAuthMetrics (Aws._awsEnv (Env._awsEnv env))) - app <- middleware e <*> pure (mkApp e) + app <- middleware env <*> pure (mkApp env) inSpan tracer "gundeck" defaultSpanArguments {kind = Otel.Server} (runSettingsWithShutdown s app Nothing) `finally` do - Log.info l $ Log.msg (Log.val "Shutting down ...") - shutdown (e ^. cstate) + Log.info logger $ Log.msg (Log.val "Shutting down ...") + shutdown (env ^. cstate) Async.cancel lst Async.cancel wCollectAuth forM_ wtbs Async.cancel forM_ rThreads Async.cancel - Redis.disconnect =<< takeMVar (e ^. rstate) - whenJust (e ^. rstateAdditionalWrite) $ (=<<) Redis.disconnect . takeMVar - Log.close (e ^. applog) + Redis.disconnect =<< takeMVar (env ^. rstate) + whenJust (env ^. rstateAdditionalWrite) $ (=<<) Redis.disconnect . takeMVar + Log.close (env ^. applog) where - createUserNotificationExchange :: Log.Logger -> MVar Q.Channel -> IO () - createUserNotificationExchange l chanMVar = do + setUpRabbitMqExchangesAndQueues :: Log.Logger -> MVar Channel -> IO () + setUpRabbitMqExchangesAndQueues logger chanMVar = do mChan <- timeout 1_000_000 $ readMVar chanMVar case mChan of - -- TODO(leif): we should probably fail here - Nothing -> Log.err l $ Log.msg (Log.val "RabbitMQ could not get channel") + Nothing -> do + -- TODO(leif): we should probably fail here + Log.err logger $ Log.msg (Log.val "RabbitMQ could not connect") Just chan -> do - Log.info l $ Log.msg (Log.val "RabbitMQ declaring exchange") - declareExchange chan newExchange {exchangeName = "user-notifications", exchangeType = "direct"} + Log.info logger $ Log.msg (Log.val "setting up RabbitMQ exchanges and queues") + declareUserNotificationsExchange chan + declareDeadUserNotificationsExchange chan + + declareUserNotificationsExchange :: Channel -> IO () + declareUserNotificationsExchange chan = do + let eName = "user-notifications" + declareExchange chan newExchange {exchangeName = eName, exchangeType = "topic"} + + declareDeadUserNotificationsExchange :: Channel -> IO () + declareDeadUserNotificationsExchange chan = do + let eName = "dead-user-notifications" + declareExchange chan newExchange {exchangeName = eName, exchangeType = "direct"} + + let qName = "dead-user-notifications" + let routingKey = qName + let headers = FieldTable $ Map.fromList [("x-dead-letter-exchange", FVString $ encodeUtf8 eName)] + void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} + bindQueue chan qName eName routingKey middleware :: Env -> IO Middleware - middleware e = do + middleware env = do otelMiddleWare <- newOpenTelemetryWaiMiddleware pure $ - versionMiddleware (foldMap expandVersionExp (o ^. settings . disabledAPIVersions)) + versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) . otelMiddleWare - . requestIdMiddleware (e ^. applog) defaultRequestIdHeaderName - . Metrics.servantPrometheusMiddleware (Proxy @(GundeckAPI :<|> InternalAPI)) + . requestIdMiddleware (env ^. applog) defaultRequestIdHeaderName + . Metrics.servantPrometheusMiddleware (Proxy @(GundeckAPI :<|> GundeckInternalAPI)) . GZip.gunzip . GZip.gzip GZip.def - . catchErrors (e ^. applog) defaultRequestIdHeaderName + . catchErrors (env ^. applog) defaultRequestIdHeaderName mkApp :: Env -> Wai.Application mkApp env0 req cont = do From 70d96a95e25f89ede030ad0afe40cc061670bc6a Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 26 Sep 2024 12:53:15 +0000 Subject: [PATCH 03/93] wip --- libs/wire-api/src/Wire/API/Notification.hs | 18 ++++++++++++ .../Wire/NotificationSubsystem/Interpreter.hs | 13 +++++++++ libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/API/Client.hs | 4 ++- services/gundeck/src/Gundeck/Run.hs | 28 +++++++++---------- 5 files changed, 48 insertions(+), 16 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index 83317eb5259..5e679899dba 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -35,6 +35,9 @@ module Wire.API.Notification queuedHasMore, queuedTime, GetNotificationsResponse (..), + userNotificationExchangeName, + userNotificationDlxName, + userNotificationDlqName, ) where @@ -166,3 +169,18 @@ instance AsUnion '[Respond 404 "Notification list" QueuedNotificationList, Respo fromUnion (S (Z (I xs))) = GetNotificationsSuccess xs fromUnion (Z (I xs)) = GetNotificationsWithStatusNotFound xs fromUnion (S (S x)) = case x of {} + +-------------------------------------------------------------------------------- +-- RabbitMQ exchanges and queues + +-- | The name of the RabbitMQ exchange to which user notifications are published. +userNotificationExchangeName :: Text +userNotificationExchangeName = "user-notifications" + +-- | The name of the RabbitMQ dead letter exchange for user notifications. +userNotificationDlxName :: Text +userNotificationDlxName = "dead-user-notifications" + +-- | The name of the RabbitMQ queue for dead-lettered user notifications. +userNotificationDlqName :: Text +userNotificationDlqName = "dead-user-notifications" diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 5b2859d1ff1..ed0b131fd0a 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -4,6 +4,7 @@ import Bilge (RequestId) import Control.Concurrent.Async (Async) import Control.Lens (set, (.~)) import Data.Aeson +import Data.Id (ClientId, UserId, idToText) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 @@ -12,6 +13,7 @@ import Data.Range import Data.Set qualified as Set import Data.Time.Clock.DiffTime import Imports +import Network.AMQP import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (async, sequenceConcurrently) @@ -20,6 +22,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class as Log +import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 import Wire.API.Team.Member @@ -168,3 +171,13 @@ pushSlowlyImpl ps = for_ ps \p -> do delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) pushImpl [p] + +_setUpUserNotificationQueues :: (Member (Embed IO) r) => Channel -> UserId -> ClientId -> Sem r () +_setUpUserNotificationQueues chan uid cid = do + let routingKeys = [idToText uid, idToText uid <> "." <> idToText cid] + liftIO $ createQueue (idToText uid) userNotificationExchangeName routingKeys + where + createQueue :: Text -> Text -> [Text] -> IO () + createQueue qName eName routingKeys = do + void $ declareQueue chan newQueue {queueName = qName} + for_ routingKeys $ bindQueue chan qName eName diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 54ff613f5e4..9cde3c8a985 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -148,6 +148,7 @@ library , amazonka , amazonka-core , amazonka-ses + , amqp , async , attoparsec , base diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index d5282714d12..960ac73e3ab 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -222,6 +222,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do for_ (userEmail usr) $ \email -> liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) + -- TODO(leif): check if client is capable of consuming notifications and set up RabbitMQ pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) @@ -244,7 +245,8 @@ updateClient u c r = do for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just for_ (updateClientCapabilities r) $ \caps' -> do if client.clientCapabilities.fromClientCapabilityList `Set.isSubsetOf` caps'.fromClientCapabilityList - then lift . Data.updateClientCapabilities u c . Just $ caps' + then -- TODO(leif): check if consumable notifications is added and set up RabbitMQ + lift . Data.updateClientCapabilities u c . Just $ caps' else throwE ClientCapabilitiesCannotBeRemoved let lk = maybeToList (unpackLastPrekey <$> updateClientLastKey r) Data.updatePrekeys u c (lk ++ updateClientPrekeys r) !>> ClientDataError diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 733965e5e39..9d09fe00c23 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -60,6 +60,7 @@ import System.Logger qualified as Log import System.Timeout (timeout) import UnliftIO.Async qualified as Async import Util.Options +import Wire.API.Notification import Wire.API.Routes.Public.Gundeck (GundeckAPI) import Wire.API.Routes.Version import Wire.API.Routes.Version.Wai @@ -102,24 +103,21 @@ run opts = withTracer \tracer -> do Log.err logger $ Log.msg (Log.val "RabbitMQ could not connect") Just chan -> do Log.info logger $ Log.msg (Log.val "setting up RabbitMQ exchanges and queues") - declareUserNotificationsExchange chan - declareDeadUserNotificationsExchange chan + createUserNotificationsExchange chan + createDeadUserNotificationsExchange chan - declareUserNotificationsExchange :: Channel -> IO () - declareUserNotificationsExchange chan = do - let eName = "user-notifications" - declareExchange chan newExchange {exchangeName = eName, exchangeType = "topic"} + createUserNotificationsExchange :: Channel -> IO () + createUserNotificationsExchange chan = do + declareExchange chan newExchange {exchangeName = userNotificationExchangeName, exchangeType = "topic"} - declareDeadUserNotificationsExchange :: Channel -> IO () - declareDeadUserNotificationsExchange chan = do - let eName = "dead-user-notifications" - declareExchange chan newExchange {exchangeName = eName, exchangeType = "direct"} + createDeadUserNotificationsExchange :: Channel -> IO () + createDeadUserNotificationsExchange chan = do + declareExchange chan newExchange {exchangeName = userNotificationDlxName, exchangeType = "direct"} - let qName = "dead-user-notifications" - let routingKey = qName - let headers = FieldTable $ Map.fromList [("x-dead-letter-exchange", FVString $ encodeUtf8 eName)] - void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} - bindQueue chan qName eName routingKey + let routingKey = userNotificationDlqName + let headers = FieldTable $ Map.fromList [("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName)] + void $ declareQueue chan newQueue {queueName = userNotificationDlqName, queueHeaders = headers} + bindQueue chan userNotificationDlqName userNotificationDlxName routingKey middleware :: Env -> IO Middleware middleware env = do From adf32b7108cf338aba26bff0bffabaf540d47bdf Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Thu, 26 Sep 2024 14:50:02 +0000 Subject: [PATCH 04/93] create user queues on client add/update --- libs/wire-api/src/Wire/API/Error/Brig.hs | 3 + .../src/Wire/NotificationSubsystem.hs | 2 + .../src/Wire/NotificationSubsystem/Error.hs | 33 +++++++++ .../Wire/NotificationSubsystem/Interpreter.hs | 40 ++++++++--- libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/API/Client.hs | 68 +++++++++++++------ services/brig/src/Brig/API/Internal.hs | 11 ++- services/brig/src/Brig/API/Public.hs | 13 ++-- .../brig/src/Brig/CanonicalInterpreter.hs | 10 ++- 9 files changed, 140 insertions(+), 41 deletions(-) create mode 100644 libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index e5e2290b576..ca0d26ee727 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -102,6 +102,7 @@ data BrigError | PropertyValueTooLarge | UserAlreadyInATeam | MLSServicesNotAllowed + | NotificationQueueConnectionError instance (Typeable (MapError e), KnownError (MapError e)) => IsSwaggerError (e :: BrigError) where addToOpenApi = addStaticErrorToSwagger @(MapError e) @@ -304,3 +305,5 @@ type instance MapError 'PropertyValueTooLarge = 'StaticError 403 "property-value type instance MapError 'UserAlreadyInATeam = 'StaticError 403 "user-already-in-a-team" "Switching teams is not allowed" type instance MapError 'MLSServicesNotAllowed = 'StaticError 409 "mls-services-not-allowed" "Services not allowed in MLS" + +type instance MapError 'NotificationQueueConnectionError = 'StaticError 500 "notification-queue-connection-error" "Error connecting to the notification queue" diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index d854c0acb1b..e2f265ddeb0 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -8,6 +8,7 @@ import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty ((:|))) import Imports +import Network.AMQP import Polysemy import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.Arbitrary @@ -49,6 +50,7 @@ data NotificationSubsystem m a where CleanupUser :: UserId -> NotificationSubsystem m () UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] + SetUpUserNotificationQueues :: MVar Channel -> UserId -> ClientId -> NotificationSubsystem m () makeSem ''NotificationSubsystem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs new file mode 100644 index 00000000000..25721a2be2b --- /dev/null +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . +module Wire.NotificationSubsystem.Error where + +import Imports +import Wire.API.Error +import Wire.API.Error.Brig qualified as E +import Wire.Error + +data NotificationSubsystemError + = NotificationSubsystemConnectionError + deriving (Eq, Show) + +instance Exception NotificationSubsystemError + +notificationSubsystemErrorToHttpError :: NotificationSubsystemError -> HttpError +notificationSubsystemErrorToHttpError = + StdError . \case + NotificationSubsystemConnectionError -> errorToWai @E.NotificationQueueConnectionError diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index ed0b131fd0a..913da1ef83a 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -4,6 +4,7 @@ import Bilge (RequestId) import Control.Concurrent.Async (Async) import Control.Lens (set, (.~)) import Data.Aeson +import Data.ByteString.Conversion import Data.Id (ClientId, UserId, idToText) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) @@ -11,6 +12,7 @@ import Data.List1 qualified as List1 import Data.Proxy import Data.Range import Data.Set qualified as Set +import Data.Text.Encoding import Data.Time.Clock.DiffTime import Imports import Network.AMQP @@ -22,6 +24,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class as Log +import System.Timeout (timeout) import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 @@ -29,6 +32,7 @@ import Wire.API.Team.Member import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Error import Wire.Sem.Delay -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. @@ -37,7 +41,9 @@ runNotificationSubsystemGundeck :: Member P.Async r, Member Delay r, Member (Final IO) r, - Member P.TinyLog r + Member P.TinyLog r, + Member (Embed IO) r, + Member (Error NotificationSubsystemError) r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> @@ -49,6 +55,7 @@ runNotificationSubsystemGundeck cfg = interpret $ \case CleanupUser uid -> GundeckAPIAccess.userDeleted uid UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid + SetUpUserNotificationQueues chan uid cid -> setUpUserNotificationQueuesImpl chan uid cid data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -172,12 +179,27 @@ pushSlowlyImpl ps = delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) pushImpl [p] -_setUpUserNotificationQueues :: (Member (Embed IO) r) => Channel -> UserId -> ClientId -> Sem r () -_setUpUserNotificationQueues chan uid cid = do - let routingKeys = [idToText uid, idToText uid <> "." <> idToText cid] - liftIO $ createQueue (idToText uid) userNotificationExchangeName routingKeys - where - createQueue :: Text -> Text -> [Text] -> IO () - createQueue qName eName routingKeys = do +setUpUserNotificationQueuesImpl :: + ( Member (Embed IO) r, + Member P.TinyLog r, + Member (Error NotificationSubsystemError) r + ) => + MVar Channel -> + UserId -> + ClientId -> + Sem r () +setUpUserNotificationQueuesImpl chanMVar uid cid = do + let qName = idToText uid + let cidText = decodeUtf8 $ toByteString' cid + let routingKeys = + [ qName, + qName <> "." <> cidText + ] + mChan <- liftIO $ timeout 1_000_000 $ readMVar chanMVar + case mChan of + Just chan -> liftIO $ do void $ declareQueue chan newQueue {queueName = qName} - for_ routingKeys $ bindQueue chan qName eName + for_ routingKeys $ bindQueue chan qName userNotificationExchangeName + Nothing -> do + P.err $ Log.msg (Log.val "RabbitMQ connection error") + throw NotificationSubsystemConnectionError diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 9cde3c8a985..bbb73673c4b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -105,6 +105,7 @@ library Wire.InvitationStore Wire.InvitationStore.Cassandra Wire.NotificationSubsystem + Wire.NotificationSubsystem.Error Wire.NotificationSubsystem.Interpreter Wire.ParseException Wire.PasswordResetCodeStore diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 960ac73e3ab..b4e0d217375 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -47,6 +47,8 @@ module Brig.API.Client ) where +import Brig.API.Error (clientError) +import Brig.API.Handler (Handler) import Brig.API.Types import Brig.API.Util import Brig.App @@ -76,16 +78,19 @@ import Data.Domain import Data.HavePendingInvitations import Data.Id (ClientId, ConnId, UserId) import Data.List.Split (chunksOf) -import Data.Map.Strict qualified as Map +import Data.Map.Strict qualified as Map hiding ((\\)) import Data.Misc (PlainTextPassword6) import Data.Qualified +import Data.Set ((\\)) import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error -import Imports +import Imports hiding ((\\)) +import Network.AMQP (Channel) import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities import Polysemy +import Polysemy.Input (Input, input) import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -168,7 +173,8 @@ addClient :: Member EmailSubsystem r, Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, - Member Events r + Member Events r, + Member (Input (MVar Channel)) r ) => Local UserId -> Maybe ConnId -> @@ -187,7 +193,8 @@ addClientWithReAuthPolicy :: Member Events r, Member UserSubsystem r, Member AuthenticationSubsystem r, - Member VerificationCodeSubsystem r + Member VerificationCodeSubsystem r, + Member (Input (MVar Channel)) r ) => Data.ReAuthPolicy -> Local UserId -> @@ -200,8 +207,8 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do >>= maybe (throwE (ClientUserNotFound u)) pure verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients <$> asks (.settings.userMaxPermClients) - let caps :: Maybe ClientCapabilityList - caps = updlhdev $ newClientCapabilities new + let mCaps :: Maybe ClientCapabilityList + mCaps = updlhdev $ newClientCapabilities new where updlhdev :: Maybe ClientCapabilityList -> Maybe ClientCapabilityList updlhdev = @@ -210,19 +217,21 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do else id lhcaps = ClientSupportsLegalholdImplicitConsent (clt0, old, count) <- - Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients caps + (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients mCaps) !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} + when (ClientSupportsConsumableNotifications `Set.member` (foldMap fromClientCapabilityList mCaps)) $ lift $ liftSem $ do + chanMVar <- input + setUpUserNotificationQueues chanMVar u clt.clientId lift $ do for_ old $ execDelete u con - liftSem $ GalleyAPIAccess.newClient u (clientId clt) + liftSem $ GalleyAPIAccess.newClient u clt.clientId liftSem $ Intra.onClientEvent u con (ClientAdded clt) when (clientType clt == LegalHoldClientType) $ liftSem $ Events.generateUserEvent u con (UserLegalHoldEnabled u) when (count > 1) $ for_ (userEmail usr) $ \email -> liftSem $ sendNewClientEmail email (userDisplayName usr) clt (userLocale usr) - -- TODO(leif): check if client is capable of consuming notifications and set up RabbitMQ pure clt where clientId' = clientIdFromPrekey (unpackLastPrekey $ newClientLastKey new) @@ -239,18 +248,35 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do VerificationCodeNoPendingCode -> throwE ClientCodeAuthenticationFailed VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed -updateClient :: (MonadClient m) => UserId -> ClientId -> UpdateClient -> ExceptT ClientError m () -updateClient u c r = do - client <- lift (Data.lookupClient u c) >>= maybe (throwE ClientNotFound) pure - for_ (updateClientLabel r) $ lift . Data.updateClientLabel u c . Just - for_ (updateClientCapabilities r) $ \caps' -> do - if client.clientCapabilities.fromClientCapabilityList `Set.isSubsetOf` caps'.fromClientCapabilityList - then -- TODO(leif): check if consumable notifications is added and set up RabbitMQ - lift . Data.updateClientCapabilities u c . Just $ caps' - else throwE ClientCapabilitiesCannotBeRemoved - let lk = maybeToList (unpackLastPrekey <$> updateClientLastKey r) - Data.updatePrekeys u c (lk ++ updateClientPrekeys r) !>> ClientDataError - Data.addMLSPublicKeys u c (Map.assocs (updateClientMLSPublicKeys r)) !>> ClientDataError +updateClient :: + ( Member NotificationSubsystem r, + Member (Input (MVar Channel)) r + ) => + UserId -> + ClientId -> + UpdateClient -> + (Handler r) () +updateClient uid cid req = do + client <- wrapClientE (lift (Data.lookupClient uid cid) >>= maybe (throwE ClientNotFound) pure) !>> clientError + wrapClientE $ for_ req.updateClientLabel $ lift . Data.updateClientLabel uid cid . Just + for_ req.updateClientCapabilities $ \caps -> do + if client.clientCapabilities.fromClientCapabilityList `Set.isSubsetOf` caps.fromClientCapabilityList + then do + -- first set up the notification queues then save the data is more robust than the other way around + let addedCapabilities = caps.fromClientCapabilityList \\ client.clientCapabilities.fromClientCapabilityList + when (ClientSupportsConsumableNotifications `Set.member` addedCapabilities) $ lift $ liftSem $ do + chanMVar <- input + setUpUserNotificationQueues chanMVar uid cid + wrapClientE $ lift . Data.updateClientCapabilities uid cid . Just $ caps + else throwE $ clientError ClientCapabilitiesCannotBeRemoved + let lk = maybeToList (unpackLastPrekey <$> req.updateClientLastKey) + wrapClientE + ( do + Data.updatePrekeys uid cid (lk ++ req.updateClientPrekeys) + Data.addMLSPublicKeys uid cid (Map.assocs req.updateClientMLSPublicKeys) + ) + !>> ClientDataError + !>> clientError -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 052c5cdb59f..778a6b4a60b 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -63,6 +63,7 @@ import Data.Set qualified as Set import Data.Text qualified as T import Data.Time.Clock.System import Imports hiding (head) +import Network.AMQP (Channel) import Network.Wai.Utilities as Utilities import Polysemy import Polysemy.Error qualified @@ -144,7 +145,9 @@ servantSitemap :: Member PropertySubsystem r, Member (Input (Local ())) r, Member IndexedUserStore r, - Member (Polysemy.Error.Error UserSubsystemError) r + Member (Polysemy.Error.Error UserSubsystemError) r, + Member (Input TeamTemplates) r, + Member (Input (MVar Channel)) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -196,7 +199,8 @@ accountAPI :: Member PropertySubsystem r, Member Events r, Member PasswordResetCodeStore r, - Member InvitationStore r + Member InvitationCodeStore r, + Member (Input (MVar Channel)) r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -427,7 +431,8 @@ addClientInternalH :: Member Events r, Member UserSubsystem r, Member VerificationCodeSubsystem r, - Member AuthenticationSubsystem r + Member AuthenticationSubsystem r, + Member (Input (MVar Channel)) r ) => UserId -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 017f225a190..757defd2cce 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -86,6 +86,7 @@ import Data.Time.Clock import Data.ZAuth.Token qualified as ZAuth import FileEmbedLzma import Imports hiding (head) +import Network.AMQP import Network.Socket (PortNumber) import Network.Wai.Utilities (CacheControl (..), (!>>)) import Network.Wai.Utilities qualified as Utilities @@ -303,7 +304,9 @@ servantSitemap :: Member (Concurrency 'Unsafe) r, Member BlockListStore r, Member (ConnectionStore InternalPaging) r, - Member IndexedUserStore r + Member IndexedUserStore r, + Member (ConnectionStore InternalPaging) r, + Member (Input (MVar Channel)) r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -392,7 +395,7 @@ servantSitemap = userClientAPI = Named @"add-client-v6" (callsFed (exposeAnnotations addClient)) :<|> Named @"add-client" (callsFed (exposeAnnotations addClient)) - :<|> Named @"update-client" updateClient + :<|> Named @"update-client" API.updateClient :<|> Named @"delete-client" deleteClient :<|> Named @"list-clients-v6" listClients :<|> Named @"list-clients" listClients @@ -591,7 +594,8 @@ addClient :: Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, Member Events r, - Member UserSubsystem r + Member UserSubsystem r, + Member (Input (MVar Channel)) r ) => Local UserId -> ConnId -> @@ -616,9 +620,6 @@ deleteClient :: deleteClient usr con clt body = API.rmClient usr con clt (Public.rmPassword body) !>> clientError -updateClient :: UserId -> ClientId -> Public.UpdateClient -> (Handler r) () -updateClient usr clt upd = wrapClientE (API.updateClient usr clt upd) !>> clientError - listClients :: UserId -> (Handler r) [Public.Client] listClients zusr = lift $ API.lookupLocalClients zusr diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index b2967854fd6..172be47c8d8 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -22,6 +22,7 @@ import Control.Monad.Catch (throwM) import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports +import Network.AMQP import Polysemy import Polysemy.Async import Polysemy.Conc @@ -60,6 +61,7 @@ import Wire.IndexedUserStore.ElasticSearch import Wire.InvitationStore (InvitationStore) import Wire.InvitationStore.Cassandra (interpretInvitationStoreToCassandra) import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Error import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException import Wire.PasswordResetCodeStore (PasswordResetCodeStore) @@ -114,12 +116,14 @@ type BrigLowerLevelEffects = PropertySubsystem, DeleteQueue, Wire.Events.Events, + NotificationSubsystem, Error UserSubsystemError, Error TeamInvitationSubsystemError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, Error VerificationCodeSubsystemError, Error PropertySubsystemError, + Error NotificationSubsystemError, Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, HashPassword, @@ -139,7 +143,7 @@ type BrigLowerLevelEffects = Input (Local ()), Input (Maybe AllowlistEmailDomains), Input TeamTemplates, - NotificationSubsystem, + Input (MVar Channel), GundeckAPIAccess, FederationConfigStore, Jwk, @@ -245,7 +249,7 @@ runBrigToIO e (AppT ma) = do . interpretJwk . interpretFederationDomainConfig e.casClient e.settings.federationStrategy (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) e.settings.federationDomainConfigs) . runGundeckAPIAccess e.gundeckEndpoint - . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) + . runInputConst (fromMaybe (error "TODO(leif): make config required") e.rabbitmqChannel) . runInputConst (teamTemplatesNoLocale e) . runInputConst e.settings.allowlistEmailDomains . runInputConst (toLocalUnsafe e.settings.federationDomain ()) @@ -265,12 +269,14 @@ runBrigToIO e (AppT ma) = do . runHashPassword . interpretFederationAPIAccess federationApiAccessConfig . rethrowHttpErrorIO + . mapError notificationSubsystemErrorToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError . mapError teamInvitationErrorToHttpError . mapError userSubsystemErrorToHttpError + . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) . runEvents . runDeleteQueue e.internalEvents . interpretPropertySubsystem propertySubsystemConfig From 253e1071d0eb34fe0e8a9e725d055067c28220e1 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 27 Sep 2024 08:41:21 +0000 Subject: [PATCH 05/93] make it internal server error --- libs/wire-api/src/Wire/API/Error/Brig.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Error/Brig.hs b/libs/wire-api/src/Wire/API/Error/Brig.hs index ca0d26ee727..ddf096a852c 100644 --- a/libs/wire-api/src/Wire/API/Error/Brig.hs +++ b/libs/wire-api/src/Wire/API/Error/Brig.hs @@ -306,4 +306,4 @@ type instance MapError 'UserAlreadyInATeam = 'StaticError 403 "user-already-in-a type instance MapError 'MLSServicesNotAllowed = 'StaticError 409 "mls-services-not-allowed" "Services not allowed in MLS" -type instance MapError 'NotificationQueueConnectionError = 'StaticError 500 "notification-queue-connection-error" "Error connecting to the notification queue" +type instance MapError 'NotificationQueueConnectionError = 'StaticError 500 "internal-server-error" "Internal server error" From 44b506ce476d4894c5bbd457fe9dc0606607be89 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 27 Sep 2024 08:41:41 +0000 Subject: [PATCH 06/93] make galley compile --- .../src/Wire/NotificationSubsystem/Error.hs | 8 ++++++-- services/galley/src/Galley/App.hs | 4 +++- services/galley/src/Galley/Effects.hs | 2 ++ services/galley/src/Galley/Env.hs | 4 ++-- 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs index 25721a2be2b..262c56ec074 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs @@ -17,6 +17,7 @@ module Wire.NotificationSubsystem.Error where import Imports +import Network.Wai.Utilities.Error qualified as Wai import Wire.API.Error import Wire.API.Error.Brig qualified as E import Wire.Error @@ -28,6 +29,9 @@ data NotificationSubsystemError instance Exception NotificationSubsystemError notificationSubsystemErrorToHttpError :: NotificationSubsystemError -> HttpError -notificationSubsystemErrorToHttpError = - StdError . \case +notificationSubsystemErrorToHttpError = StdError . notificationSubsystemErrorToWaiError + +notificationSubsystemErrorToWaiError :: NotificationSubsystemError -> Wai.Error +notificationSubsystemErrorToWaiError = + \case NotificationSubsystemConnectionError -> errorToWai @E.NotificationQueueConnectionError diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index a9a02e660ea..101c5678ab6 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -108,6 +108,7 @@ import Wire.API.Error import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.GundeckAPIAccess (runGundeckAPIAccess) +import Wire.NotificationSubsystem.Error import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) import Wire.Rpc import Wire.Sem.Delay @@ -289,7 +290,8 @@ evalGalley e = . interpretExternalAccess . runRpcWithHttp (e ^. manager) (e ^. reqId) . runGundeckAPIAccess (e ^. options . gundeck) - . runNotificationSubsystemGundeck (notificationSubssystemConfig e) + . mapError (toResponse . notificationSubsystemErrorToWaiError) + . runNotificationSubsystemGundeck (notificationSubsystemConfig e) . interpretSparAccess . interpretBrigAccess where diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 1a9be889d25..7af6443bfcf 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -101,6 +101,7 @@ import Wire.API.Error import Wire.API.Team.Feature import Wire.GundeckAPIAccess import Wire.NotificationSubsystem +import Wire.NotificationSubsystem.Error import Wire.Rpc import Wire.Sem.Paging.Cassandra import Wire.Sem.Random @@ -110,6 +111,7 @@ type GalleyEffects1 = '[ BrigAccess, SparAccess, NotificationSubsystem, + Error NotificationSubsystemError, GundeckAPIAccess, Rpc, ExternalAccess, diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 9d88c703b86..d5c8bc23c67 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -109,8 +109,8 @@ currentFanoutLimit o = do let maxSize = fromIntegral (o ^. (O.settings . maxTeamSize)) unsafeRange (min maxSize optFanoutLimit) -notificationSubssystemConfig :: Env -> NotificationSubsystemConfig -notificationSubssystemConfig env = +notificationSubsystemConfig :: Env -> NotificationSubsystemConfig +notificationSubsystemConfig env = NotificationSubsystemConfig { chunkSize = defaultChunkSize, fanoutLimit = currentFanoutLimit env._options, From b8fac8e57514962de3e2ca07980a6ea9843283b3 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 27 Sep 2024 09:43:45 +0000 Subject: [PATCH 07/93] make rabbitmq mandatory --- changelog.d/0-release-notes/WBP-10308 | 1 + .../src/Wire/NotificationSubsystem.hs | 2 +- .../src/Wire/NotificationSubsystem/Error.hs | 37 ------------------- .../Wire/NotificationSubsystem/Interpreter.hs | 24 ++++-------- libs/wire-subsystems/wire-subsystems.cabal | 1 - services/brig/src/Brig/API/Client.hs | 6 +-- services/brig/src/Brig/API/Internal.hs | 6 +-- services/brig/src/Brig/API/Public.hs | 4 +- services/brig/src/Brig/App.hs | 24 +++++++----- .../brig/src/Brig/CanonicalInterpreter.hs | 7 +--- services/brig/src/Brig/Federation/Client.hs | 13 ++----- services/brig/src/Brig/Options.hs | 2 +- .../brig/test/integration/API/User/Handles.hs | 2 +- services/galley/src/Galley/App.hs | 2 - services/galley/src/Galley/Effects.hs | 2 - 15 files changed, 38 insertions(+), 95 deletions(-) create mode 100644 changelog.d/0-release-notes/WBP-10308 delete mode 100644 libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs diff --git a/changelog.d/0-release-notes/WBP-10308 b/changelog.d/0-release-notes/WBP-10308 new file mode 100644 index 00000000000..af442898d14 --- /dev/null +++ b/changelog.d/0-release-notes/WBP-10308 @@ -0,0 +1 @@ +Notifications are now also send via RabbitMQ therefore RabbitMQ is now a required configuration in brig. diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index e2f265ddeb0..47cc92d7193 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -50,7 +50,7 @@ data NotificationSubsystem m a where CleanupUser :: UserId -> NotificationSubsystem m () UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] - SetUpUserNotificationQueues :: MVar Channel -> UserId -> ClientId -> NotificationSubsystem m () + SetUpUserNotificationQueues :: Channel -> UserId -> ClientId -> NotificationSubsystem m () makeSem ''NotificationSubsystem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs deleted file mode 100644 index 262c56ec074..00000000000 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Error.hs +++ /dev/null @@ -1,37 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2024 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . -module Wire.NotificationSubsystem.Error where - -import Imports -import Network.Wai.Utilities.Error qualified as Wai -import Wire.API.Error -import Wire.API.Error.Brig qualified as E -import Wire.Error - -data NotificationSubsystemError - = NotificationSubsystemConnectionError - deriving (Eq, Show) - -instance Exception NotificationSubsystemError - -notificationSubsystemErrorToHttpError :: NotificationSubsystemError -> HttpError -notificationSubsystemErrorToHttpError = StdError . notificationSubsystemErrorToWaiError - -notificationSubsystemErrorToWaiError :: NotificationSubsystemError -> Wai.Error -notificationSubsystemErrorToWaiError = - \case - NotificationSubsystemConnectionError -> errorToWai @E.NotificationQueueConnectionError diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 913da1ef83a..69e765f02c4 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -24,7 +24,6 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class as Log -import System.Timeout (timeout) import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 @@ -32,7 +31,6 @@ import Wire.API.Team.Member import Wire.GundeckAPIAccess (GundeckAPIAccess) import Wire.GundeckAPIAccess qualified as GundeckAPIAccess import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Error import Wire.Sem.Delay -- | We interpret this using 'GundeckAPIAccess' so we can mock it out for testing. @@ -42,8 +40,7 @@ runNotificationSubsystemGundeck :: Member Delay r, Member (Final IO) r, Member P.TinyLog r, - Member (Embed IO) r, - Member (Error NotificationSubsystemError) r + Member (Embed IO) r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> @@ -180,26 +177,19 @@ pushSlowlyImpl ps = pushImpl [p] setUpUserNotificationQueuesImpl :: - ( Member (Embed IO) r, - Member P.TinyLog r, - Member (Error NotificationSubsystemError) r + ( Member (Embed IO) r ) => - MVar Channel -> + Channel -> UserId -> ClientId -> Sem r () -setUpUserNotificationQueuesImpl chanMVar uid cid = do +setUpUserNotificationQueuesImpl chan uid cid = do let qName = idToText uid let cidText = decodeUtf8 $ toByteString' cid let routingKeys = [ qName, qName <> "." <> cidText ] - mChan <- liftIO $ timeout 1_000_000 $ readMVar chanMVar - case mChan of - Just chan -> liftIO $ do - void $ declareQueue chan newQueue {queueName = qName} - for_ routingKeys $ bindQueue chan qName userNotificationExchangeName - Nothing -> do - P.err $ Log.msg (Log.val "RabbitMQ connection error") - throw NotificationSubsystemConnectionError + liftIO $ do + void $ declareQueue chan newQueue {queueName = qName} + for_ routingKeys $ bindQueue chan qName userNotificationExchangeName diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index bbb73673c4b..9cde3c8a985 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -105,7 +105,6 @@ library Wire.InvitationStore Wire.InvitationStore.Cassandra Wire.NotificationSubsystem - Wire.NotificationSubsystem.Error Wire.NotificationSubsystem.Interpreter Wire.ParseException Wire.PasswordResetCodeStore diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index b4e0d217375..439ba80e68c 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -174,7 +174,7 @@ addClient :: Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, Member Events r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => Local UserId -> Maybe ConnId -> @@ -194,7 +194,7 @@ addClientWithReAuthPolicy :: Member UserSubsystem r, Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => Data.ReAuthPolicy -> Local UserId -> @@ -250,7 +250,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do updateClient :: ( Member NotificationSubsystem r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => UserId -> ClientId -> diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 778a6b4a60b..d38c1fee7f5 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -147,7 +147,7 @@ servantSitemap :: Member IndexedUserStore r, Member (Polysemy.Error.Error UserSubsystemError) r, Member (Input TeamTemplates) r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = @@ -200,7 +200,7 @@ accountAPI :: Member Events r, Member PasswordResetCodeStore r, Member InvitationCodeStore r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -432,7 +432,7 @@ addClientInternalH :: Member UserSubsystem r, Member VerificationCodeSubsystem r, Member AuthenticationSubsystem r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => UserId -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 757defd2cce..eb58661e379 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -306,7 +306,7 @@ servantSitemap :: Member (ConnectionStore InternalPaging) r, Member IndexedUserStore r, Member (ConnectionStore InternalPaging) r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -595,7 +595,7 @@ addClient :: Member VerificationCodeSubsystem r, Member Events r, Member UserSubsystem r, - Member (Input (MVar Channel)) r + Member (Input Channel) r ) => Local UserId -> ConnId -> diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index eb7b06457e2..4e57d917c36 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -67,6 +67,7 @@ module Brig.App rabbitmqChannelLens, disabledVersionsLens, enableSFTFederationLens, + readChannel, -- * App Monad AppT (..), @@ -140,6 +141,8 @@ import OpenSSL.EVP.Digest (Digest, getDigestByName) import OpenSSL.Session (SSLOption (..)) import OpenSSL.Session qualified as SSL import Polysemy +import Polysemy.Error (throw) +import Polysemy.Error qualified as Polysemy import Polysemy.Fail import Polysemy.Final import Polysemy.Input (Input, input) @@ -149,14 +152,18 @@ import System.FSNotify qualified as FS import System.Logger.Class hiding (Settings, settings) import System.Logger.Class qualified as LC import System.Logger.Extended qualified as Log +import System.Timeout (timeout) import Util.Options import Util.SuffixNamer +import Wire.API.Error (errorToWai) +import Wire.API.Error.Brig qualified as E import Wire.API.Federation.Error (federationNotImplemented) import Wire.API.Locale (Locale) import Wire.API.Routes.Version import Wire.API.User.Identity import Wire.EmailSending.SMTP qualified as SMTP import Wire.EmailSubsystem.Template (TemplateBranding, forLocale) +import Wire.Error (HttpError (StdError)) import Wire.SessionStore import Wire.SessionStore.Cassandra import Wire.UserKeyStore @@ -202,23 +209,15 @@ data Env = Env indexEnv :: IndexEnv, randomPrekeyLocalLock :: Maybe (MVar ()), keyPackageLocalLock :: MVar (), - rabbitmqChannel :: Maybe (MVar Q.Channel), + rabbitmqChannel :: MVar Q.Channel, disabledVersions :: Set Version, enableSFTFederation :: Maybe Bool } makeLensesWith (lensRules & lensField .~ suffixNamer) ''Env -validateOptions :: Opts -> IO () -validateOptions o = - case (o.federatorInternal, o.rabbitmq) of - (Nothing, Just _) -> error "RabbitMQ config is specified and federator is not, please specify both or none" - (Just _, Nothing) -> error "Federator is specified and RabbitMQ config is not, please specify both or none" - _ -> pure () - newEnv :: Opts -> IO Env newEnv opts = do - validateOptions opts Just md5 <- getDigestByName "MD5" Just sha256 <- getDigestByName "SHA256" Just sha512 <- getDigestByName "SHA512" @@ -261,7 +260,7 @@ newEnv opts = do Log.info lgr $ Log.msg (Log.val "randomPrekeys: not active; using dynamoDB instead.") pure Nothing kpLock <- newMVar () - rabbitChan <- traverse (Q.mkRabbitMqChannelMVar lgr) opts.rabbitmq + rabbitChan <- Q.mkRabbitMqChannelMVar lgr opts.rabbitmq let allDisabledVersions = foldMap expandVersionExp opts.settings.disabledAPIVersions idxEnv <- mkIndexEnv opts.elasticsearch lgr (Opt.galley opts) mgr pure $! @@ -628,6 +627,11 @@ instance (MonadIndexIO (AppT r)) => MonadIndexIO (ExceptT err (AppT r)) where instance HasRequestId (AppT r) where getRequestId = asks (.requestId) +readChannel :: (Member (Embed IO) r, Member (Polysemy.Error HttpError) r) => MVar Q.Channel -> Sem r Q.Channel +readChannel chanMVar = do + mChan <- liftIO $ timeout 1_000_000 $ readMVar chanMVar + maybe (throw (StdError $ errorToWai @'E.NotificationQueueConnectionError)) pure mChan + ------------------------------------------------------------------------------- -- Ad hoc interpreters diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 172be47c8d8..e383d0c1624 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -61,7 +61,6 @@ import Wire.IndexedUserStore.ElasticSearch import Wire.InvitationStore (InvitationStore) import Wire.InvitationStore.Cassandra (interpretInvitationStoreToCassandra) import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Error import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException import Wire.PasswordResetCodeStore (PasswordResetCodeStore) @@ -117,13 +116,13 @@ type BrigLowerLevelEffects = DeleteQueue, Wire.Events.Events, NotificationSubsystem, + Input Channel, Error UserSubsystemError, Error TeamInvitationSubsystemError, Error AuthenticationSubsystemError, Error Wire.API.Federation.Error.FederationError, Error VerificationCodeSubsystemError, Error PropertySubsystemError, - Error NotificationSubsystemError, Error HttpError, Wire.FederationAPIAccess.FederationAPIAccess Wire.API.Federation.Client.FederatorClient, HashPassword, @@ -143,7 +142,6 @@ type BrigLowerLevelEffects = Input (Local ()), Input (Maybe AllowlistEmailDomains), Input TeamTemplates, - Input (MVar Channel), GundeckAPIAccess, FederationConfigStore, Jwk, @@ -249,7 +247,6 @@ runBrigToIO e (AppT ma) = do . interpretJwk . interpretFederationDomainConfig e.casClient e.settings.federationStrategy (foldMap (remotesMapFromCfgFile . fmap (.federationDomainConfig)) e.settings.federationDomainConfigs) . runGundeckAPIAccess e.gundeckEndpoint - . runInputConst (fromMaybe (error "TODO(leif): make config required") e.rabbitmqChannel) . runInputConst (teamTemplatesNoLocale e) . runInputConst e.settings.allowlistEmailDomains . runInputConst (toLocalUnsafe e.settings.federationDomain ()) @@ -269,13 +266,13 @@ runBrigToIO e (AppT ma) = do . runHashPassword . interpretFederationAPIAccess federationApiAccessConfig . rethrowHttpErrorIO - . mapError notificationSubsystemErrorToHttpError . mapError propertySubsystemErrorToHttpError . mapError verificationCodeSubsystemErrorToHttpError . mapError (StdError . federationErrorToWai) . mapError authenticationSubsystemErrorToHttpError . mapError teamInvitationErrorToHttpError . mapError userSubsystemErrorToHttpError + . runInputSem (readChannel e.rabbitmqChannel) -- (fromMaybe (error "TODO(leif): make config required") e.rabbitmqChannel) . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) . runEvents . runDeleteQueue e.internalEvents diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 19e0193e1ce..735626789e4 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -153,16 +153,9 @@ notifyUserDeleted self remotes = do let remoteConnections = tUnqualified remotes let notif = UserDeletedConnectionsNotification (tUnqualified self) remoteConnections remoteDomain = tDomain remotes - asks (.rabbitmqChannel) >>= \case - Just chanVar -> do - enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ - fedQueueClient @'OnUserDeletedConnectionsTag notif - Nothing -> - Log.err $ - Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) - . Log.field "user_id" (show self) - . Log.field "domain" (domainText remoteDomain) - . Log.field "error" (show FederationNotConfigured) + chanVar <- asks (.rabbitmqChannel) + enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ + fedQueueClient @'OnUserDeletedConnectionsTag notif -- | Enqueues notifications in RabbitMQ. Retries 3 times with a delay of 1s. enqueueNotification :: (MonadIO m, MonadMask m, Log.MonadLogger m, MonadReader Env m) => Domain -> Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c () -> m () diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 7aeacd70efa..4b4d43198c6 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -389,7 +389,7 @@ data Opts = Opts -- | SFT Federation multiSFT :: !(Maybe Bool), -- | RabbitMQ settings, required when federation is enabled. - rabbitmq :: !(Maybe AmqpEndpoint), + rabbitmq :: !AmqpEndpoint, -- | AWS settings aws :: !AWSOpts, -- | Enable Random Prekey Strategy diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 5776fc082b9..68404f0c9d2 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -316,7 +316,7 @@ testGetUserByQualifiedHandleFailure brig = do testGetUserByQualifiedHandleNoFederation :: Opt.Opts -> Brig -> Http () testGetUserByQualifiedHandleNoFederation opt brig = do - let newOpts = opt {Opt.federatorInternal = Nothing, Opt.rabbitmq = Nothing} + let newOpts = opt {Opt.federatorInternal = Nothing} someUser <- randomUser brig withSettingsOverrides newOpts $ get diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 101c5678ab6..cfc7b399285 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -108,7 +108,6 @@ import Wire.API.Error import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.GundeckAPIAccess (runGundeckAPIAccess) -import Wire.NotificationSubsystem.Error import Wire.NotificationSubsystem.Interpreter (runNotificationSubsystemGundeck) import Wire.Rpc import Wire.Sem.Delay @@ -290,7 +289,6 @@ evalGalley e = . interpretExternalAccess . runRpcWithHttp (e ^. manager) (e ^. reqId) . runGundeckAPIAccess (e ^. options . gundeck) - . mapError (toResponse . notificationSubsystemErrorToWaiError) . runNotificationSubsystemGundeck (notificationSubsystemConfig e) . interpretSparAccess . interpretBrigAccess diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index 7af6443bfcf..1a9be889d25 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -101,7 +101,6 @@ import Wire.API.Error import Wire.API.Team.Feature import Wire.GundeckAPIAccess import Wire.NotificationSubsystem -import Wire.NotificationSubsystem.Error import Wire.Rpc import Wire.Sem.Paging.Cassandra import Wire.Sem.Random @@ -111,7 +110,6 @@ type GalleyEffects1 = '[ BrigAccess, SparAccess, NotificationSubsystem, - Error NotificationSubsystemError, GundeckAPIAccess, Rpc, ExternalAccess, From 8ce0eb33dcc51f948d75983aa4ed28c3e1ac0ba8 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 27 Sep 2024 10:40:46 +0000 Subject: [PATCH 08/93] fix integration tests --- integration/test/Testlib/ModService.hs | 4 +++- services/brig/src/Brig/App.hs | 16 ++++++++++++++-- services/brig/src/Brig/CanonicalInterpreter.hs | 2 +- services/gundeck/gundeck.integration.yaml | 2 +- services/gundeck/src/Gundeck/Env.hs | 2 +- services/gundeck/src/Gundeck/Options.hs | 2 +- 6 files changed, 21 insertions(+), 7 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 379547c4d2b..3dabfdcd1e7 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -179,7 +179,9 @@ startDynamicBackend resource beOverrides = do >=> setField "federator.host" ("127.0.0.1" :: String) >=> setField "federator.port" resource.berFederatorInternal >=> setField "rabbitmq.vHost" resource.berVHost, - gundeckCfg = setField "settings.federationDomain" resource.berDomain, + gundeckCfg = + setField "settings.federationDomain" resource.berDomain + >=> setField "rabbitmq.vHost" resource.berVHost, backgroundWorkerCfg = setField "federatorInternal.port" resource.berFederatorInternal >=> setField "federatorInternal.host" ("127.0.0.1" :: String) diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 4e57d917c36..9785f028432 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -146,6 +146,8 @@ import Polysemy.Error qualified as Polysemy import Polysemy.Fail import Polysemy.Final import Polysemy.Input (Input, input) +import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as P import Prometheus import Ssl.Util import System.FSNotify qualified as FS @@ -627,10 +629,20 @@ instance (MonadIndexIO (AppT r)) => MonadIndexIO (ExceptT err (AppT r)) where instance HasRequestId (AppT r) where getRequestId = asks (.requestId) -readChannel :: (Member (Embed IO) r, Member (Polysemy.Error HttpError) r) => MVar Q.Channel -> Sem r Q.Channel +readChannel :: + ( Member (Embed IO) r, + Member (Polysemy.Error HttpError) r, + Member TinyLog r + ) => + MVar Q.Channel -> + Sem r Q.Channel readChannel chanMVar = do mChan <- liftIO $ timeout 1_000_000 $ readMVar chanMVar - maybe (throw (StdError $ errorToWai @'E.NotificationQueueConnectionError)) pure mChan + maybe onNothing pure mChan + where + onNothing = do + P.err $ Log.msg @Text "failed to connect to RabbitMQ" + throw $ StdError $ errorToWai @'E.NotificationQueueConnectionError ------------------------------------------------------------------------------- -- Ad hoc interpreters diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index e383d0c1624..d9d44c3bcdc 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -272,7 +272,7 @@ runBrigToIO e (AppT ma) = do . mapError authenticationSubsystemErrorToHttpError . mapError teamInvitationErrorToHttpError . mapError userSubsystemErrorToHttpError - . runInputSem (readChannel e.rabbitmqChannel) -- (fromMaybe (error "TODO(leif): make config required") e.rabbitmqChannel) + . runInputSem (readChannel e.rabbitmqChannel) . runNotificationSubsystemGundeck (defaultNotificationSubsystemConfig e.requestId) . runEvents . runDeleteQueue e.internalEvents diff --git a/services/gundeck/gundeck.integration.yaml b/services/gundeck/gundeck.integration.yaml index 573aef32637..075ddccfc5c 100644 --- a/services/gundeck/gundeck.integration.yaml +++ b/services/gundeck/gundeck.integration.yaml @@ -34,7 +34,7 @@ aws: sqsEndpoint: http://localhost:4568 # https://sqs.eu-west-1.amazonaws.com snsEndpoint: http://localhost:4575 # https://sns.eu-west-1.amazonaws.com -rabbitMq: +rabbitmq: host: 127.0.0.1 port: 5671 vHost: / diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index a80f5c65be0..ed91feeaafc 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -104,7 +104,7 @@ createEnv o = do { updateAction = Ms . round . (* 1000) <$> getPOSIXTime } mtbs <- mkThreadBudgetState `mapM` (o ^. settings . maxConcurrentNativePushes) - rabbitMqChannelMVar <- Q.mkRabbitMqChannelMVar l (o ^. rabbitMq) + rabbitMqChannelMVar <- Q.mkRabbitMqChannelMVar l (o ^. rabbitmq) pure $! (rThread : rAdditionalThreads,) $! Env (RequestId defRequestId) o l n p r rAdditional a io mtbs rabbitMqChannelMVar reqIdMsg :: RequestId -> Logger.Msg -> Logger.Msg diff --git a/services/gundeck/src/Gundeck/Options.hs b/services/gundeck/src/Gundeck/Options.hs index f8690dbea57..f09b6177d19 100644 --- a/services/gundeck/src/Gundeck/Options.hs +++ b/services/gundeck/src/Gundeck/Options.hs @@ -134,7 +134,7 @@ data Opts = Opts _redis :: !RedisEndpoint, _redisAdditionalWrite :: !(Maybe RedisEndpoint), _aws :: !AWSOpts, - _rabbitMq :: !AmqpEndpoint, + _rabbitmq :: !AmqpEndpoint, _discoUrl :: !(Maybe Text), _settings :: !Settings, -- Logging From 031f063da1037f7be95df0d51f41ffdd1f9edbe9 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 27 Sep 2024 11:04:22 +0000 Subject: [PATCH 09/93] set correct DLX headers --- .../src/Wire/NotificationSubsystem/Interpreter.hs | 12 ++++++++++-- services/gundeck/src/Gundeck/Run.hs | 6 +----- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 69e765f02c4..87c6ec761a5 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -9,6 +9,7 @@ import Data.Id (ClientId, UserId, idToText) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 +import Data.Map qualified as Map import Data.Proxy import Data.Range import Data.Set qualified as Set @@ -16,6 +17,7 @@ import Data.Text.Encoding import Data.Time.Clock.DiffTime import Imports import Network.AMQP +import Network.AMQP.Types (FieldTable (FieldTable), FieldValue (FVString)) import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (async, sequenceConcurrently) @@ -24,7 +26,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class as Log -import Wire.API.Notification (userNotificationExchangeName) +import Wire.API.Notification (userNotificationDlqName, userNotificationDlxName, userNotificationExchangeName) import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 import Wire.API.Team.Member @@ -191,5 +193,11 @@ setUpUserNotificationQueuesImpl chan uid cid = do qName <> "." <> cidText ] liftIO $ do - void $ declareQueue chan newQueue {queueName = qName} + let headers = + FieldTable $ + Map.fromList + [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), + ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) + ] + void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} for_ routingKeys $ bindQueue chan qName userNotificationExchangeName diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 9d09fe00c23..b91a030b6e4 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -26,12 +26,10 @@ import Control.Error (ExceptT (ExceptT)) import Control.Exception (finally) import Control.Lens ((.~), (^.)) import Control.Monad.Extra -import Data.Map qualified as Map import Data.Metrics.AWS (gaugeTokenRemaing) import Data.Metrics.Servant qualified as Metrics import Data.Proxy (Proxy (Proxy)) import Data.Text (unpack) -import Data.Text.Encoding (encodeUtf8) import Database.Redis qualified as Redis import Gundeck.API.Internal as Internal (InternalAPI, servantSitemap) import Gundeck.API.Public as Public (servantSitemap) @@ -45,7 +43,6 @@ import Gundeck.Schema.Run (lastSchemaVersion) import Gundeck.ThreadBudget import Imports import Network.AMQP -import Network.AMQP.Types (FieldTable (FieldTable), FieldValue (FVString)) import Network.Wai as Wai import Network.Wai.Middleware.Gunzip qualified as GZip import Network.Wai.Middleware.Gzip qualified as GZip @@ -115,8 +112,7 @@ run opts = withTracer \tracer -> do declareExchange chan newExchange {exchangeName = userNotificationDlxName, exchangeType = "direct"} let routingKey = userNotificationDlqName - let headers = FieldTable $ Map.fromList [("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName)] - void $ declareQueue chan newQueue {queueName = userNotificationDlqName, queueHeaders = headers} + void $ declareQueue chan newQueue {queueName = userNotificationDlqName} bindQueue chan userNotificationDlqName userNotificationDlxName routingKey middleware :: Env -> IO Middleware From 98ed71aabcb8aa6332a7aaa0eeafc6c2a082808b Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 30 Sep 2024 12:25:38 +0000 Subject: [PATCH 10/93] wip --- libs/extended/src/Network/AMQP/Extended.hs | 6 +++--- .../src/Wire/API/Routes/Public/Cannon.hs | 17 ++++++++++++++++- services/cannon/src/Cannon/API/Public.hs | 4 ++++ services/cannon/src/Cannon/App.hs | 6 ++++++ services/cannon/src/Cannon/Options.hs | 2 ++ services/cannon/src/Cannon/WS.hs | 3 ++- services/gundeck/src/Gundeck/Push.hs | 14 ++++++++++++++ 7 files changed, 47 insertions(+), 5 deletions(-) diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 955e54c0a33..39cc20de1a2 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -55,7 +55,7 @@ data RabbitMqTlsOpts = RabbitMqTlsOpts { caCert :: !(Maybe FilePath), insecureSkipVerifyTls :: Bool } - deriving (Show) + deriving (Eq, Show) parseTlsJson :: Object -> Parser (Maybe RabbitMqTlsOpts) parseTlsJson v = do @@ -76,7 +76,7 @@ data RabbitMqAdminOpts = RabbitMqAdminOpts tls :: Maybe RabbitMqTlsOpts, adminPort :: !Int } - deriving (Show) + deriving (Eq, Show) instance FromJSON RabbitMqAdminOpts where parseJSON = withObject "RabbitMqAdminOpts" $ \v -> @@ -111,7 +111,7 @@ data AmqpEndpoint = AmqpEndpoint vHost :: !Text, tls :: !(Maybe RabbitMqTlsOpts) } - deriving (Show) + deriving (Eq, Show) instance FromJSON AmqpEndpoint where parseJSON = withObject "AmqpEndpoint" $ \v -> diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs index eda1f01a8e3..4608e229600 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs @@ -41,7 +41,22 @@ type CannonAPI = -- FUTUREWORK: Consider higher-level web socket combinator :> WebSocketPending ) - + :<|> Named + "consume-events" + ( Summary "Consume events over a websocket connection" + :> "events" + :> ZUser + :> QueryParam' + [ -- Make this optional in https://wearezeta.atlassian.net/browse/WPB-11173 + Required, + Strict, + Description "Client ID" + ] + "client" + ClientId + -- FUTUREWORK: Consider higher-level web socket combinator + :> WebSocketPending + ) data CannonAPITag instance ServiceAPI CannonAPITag v where diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index 4a559f9f17c..8eb96de8b3e 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -33,8 +33,12 @@ import Wire.API.Routes.Public.Cannon publicAPIServer :: ServerT CannonAPI Cannon publicAPIServer = Named @"await-notifications" streamData + :<|> Named @"consume-events" consumeEvents streamData :: UserId -> ConnId -> Maybe ClientId -> PendingConnection -> Cannon () streamData userId connId clientId con = do e <- wsenv liftIO $ wsapp (mkKey userId connId) clientId e con + +consumeEvents :: UserId -> ClientId -> PendingConnection -> Cannon () +consumeEvents = undefined diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 770bf0ff499..b51949e490c 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -39,6 +39,7 @@ import Network.Wai.Utilities.Error import Network.WebSockets hiding (Request, Response, requestHeaders) import System.Logger.Class hiding (Error, close) import System.Logger.Class qualified as Logger +import Data.Id -- | Connection state, updated by {read, write}Loop. data State = State !Int !Timeout @@ -65,6 +66,11 @@ maxPingInterval = 3600 maxLifetime :: Word64 maxLifetime = 3 * 24 * 3600 +rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp +rabbitMQWebSocketApp uid cid env = do + env.rabbitmq + undefined + wsapp :: Key -> Maybe ClientId -> Env -> ServerApp wsapp k c e pc = runWS e (go `catches` ioErrors k) where diff --git a/services/cannon/src/Cannon/Options.hs b/services/cannon/src/Cannon/Options.hs index ae301862e1b..feff15bd93f 100644 --- a/services/cannon/src/Cannon/Options.hs +++ b/services/cannon/src/Cannon/Options.hs @@ -44,6 +44,7 @@ import Data.Aeson.APIFieldJsonTH import Imports import System.Logger.Extended (Level, LogFormat) import Wire.API.Routes.Version +import Network.AMQP.Extended (AmqpEndpoint) data Cannon = Cannon { _cannonHost :: !String, @@ -87,6 +88,7 @@ deriveApiFieldJSON ''DrainOpts data Opts = Opts { _optsCannon :: !Cannon, _optsGundeck :: !Gundeck, + _optsRabbitmq :: !AmqpEndpoint, _optsLogLevel :: !Level, _optsLogNetStrings :: !(Maybe (Last Bool)), _optsLogFormat :: !(Maybe (Last LogFormat)), diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index ea106f4cf03..f2a976307d3 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -145,7 +145,8 @@ data Env = Env dict :: !(Dict Key Websocket), rand :: !GenIO, clock :: !Clock, - drainOpts :: DrainOpts + drainOpts :: DrainOpts, + rabbitmq :: !AmqpEndpoint } setRequestId :: RequestId -> Env -> Env diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 098223a5547..0899b81360e 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -123,11 +123,25 @@ instance MonadMapAsync Gundeck where Nothing -> mapAsync f l Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) +-- splitPushes :: [Push] -> m ([Push], [Push]) +-- splitPushes = undefined + +-- Old way: +-- Client -> Cannon: establish WS (/await) +-- Galley -> Gundeck -> Cannon -> Client : only if client is present on cannon +-- -> Cassandra : always write +-- +-- New way: +-- Galley -> Gundeck -> RabbitMQ: Always Publish to queue +-- Client -> Cannon -> RabbitMQ: establish WS and subscribe to the queue (/events) + -- | Construct and send a single bulk push request to the client. Write the 'Notification's from -- the request to C*. Trigger native pushes for all delivery failures notifications. pushAll :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m) => [Push] -> m () pushAll pushes = do newNotifications <- mapM mkNewNotification pushes + -- let rs = concatMap (toList . (.nnRecipients)) newNotifications + -- (capableClients, incapableClients) :: ([Recipient], [Recipient]) <- splitClients rs -- persist push request let cassandraTargets :: [CassandraTargets] cassandraTargets = map mkCassandraTargets newNotifications From a36e176ad767df897c04dcfc25a9502d7a63b928 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 30 Sep 2024 16:34:33 +0200 Subject: [PATCH 11/93] Add a WIP test to consume notifs via `GET /events` --- integration/integration.cabal | 1 + integration/test/Test/Events.hs | 54 +++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+) create mode 100644 integration/test/Test/Events.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index a3989f28e76..0a9b2058ba7 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -121,6 +121,7 @@ library Test.Demo Test.EJPD Test.Errors + Test.Events Test.ExternalPartner Test.FeatureFlags Test.FeatureFlags.AppLock diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs new file mode 100644 index 00000000000..8b5ab01a6a2 --- /dev/null +++ b/integration/test/Test/Events.hs @@ -0,0 +1,54 @@ +module Test.Events where + +import API.Brig +import API.BrigCommon +import API.Common +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import Data.ByteString.Conversion (toByteString') +import qualified Network.WebSockets.Client as WS +import qualified Network.WebSockets.Connection as WS +import SetupHelpers +import Testlib.Prelude +import UnliftIO (Async, async, cancel, race) +import UnliftIO.Concurrent (threadDelay) + +testConsumeEvents :: (HasCallStack) => App () +testConsumeEvents = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + eventsChan <- liftIO newTChanIO + wsThread <- eventsWebSocket alice clientId eventsChan + randomHandle >>= putHandle alice >>= assertSuccess + mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) + mEvent `shouldMatch` (Right (object ["payload" .= ["event1"]]) :: Either () Value) + cancel wsThread + +eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> App (Async ()) +eventsWebSocket user clientId eventsChan = do + serviceMap <- getServiceMap =<< objDomain user + uid <- objId =<< objQidObject user + let HostPort caHost caPort = serviceHostPort serviceMap Cannon + path = "/events?client=" <> clientId + caHdrs = [(fromString "Z-User", toByteString' uid)] + app = wsRead + -- r <- async wsRead + -- w <- async wsWrite + wsRead conn = forever $ do + bs <- WS.receiveData conn + case decodeStrict' bs of + Just n -> atomically $ writeTChan eventsChan n + Nothing -> putStrLn $ "Failed to decode events: " ++ show bs + -- wsWrite = forever $ do + -- takeMVar latch + -- WS.sendClose conn ("close" :: ByteString) + liftIO + $ async + $ WS.runClientWith + caHost + (fromIntegral caPort) + path + WS.defaultConnectionOptions + caHdrs + app From c02ac0a4597d5a02ae1e5d70aa9156398ad483ae Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 30 Sep 2024 16:37:13 +0200 Subject: [PATCH 12/93] cannon: Roughly implement subscribing notifs from RabbitMQ --- .../Wire/NotificationSubsystem/Interpreter.hs | 26 +++++++-------- services/cannon/cannon.cabal | 3 ++ services/cannon/cannon.integration.yaml | 8 +++++ services/cannon/cannon2.integration.yaml | 8 +++++ services/cannon/src/Cannon/App.hs | 13 +------- services/cannon/src/Cannon/Options.hs | 16 ++++++++-- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 32 +++++++++++++++++++ services/cannon/src/Cannon/Run.hs | 3 +- services/cannon/src/Cannon/Types.hs | 6 ++-- services/cannon/src/Cannon/WS.hs | 6 ++-- .../cannon/test/resources/rabbitmq-ca.pem | 19 +++++++++++ 11 files changed, 107 insertions(+), 33 deletions(-) create mode 100644 services/cannon/src/Cannon/RabbitMqConsumerApp.hs create mode 100644 services/cannon/test/resources/rabbitmq-ca.pem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 87c6ec761a5..b4135df8f32 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -54,7 +54,7 @@ runNotificationSubsystemGundeck cfg = interpret $ \case CleanupUser uid -> GundeckAPIAccess.userDeleted uid UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid - SetUpUserNotificationQueues chan uid cid -> setUpUserNotificationQueuesImpl chan uid cid + SetUpUserNotificationQueues chan uid cid -> void $ liftIO $ setUpUserNotificationQueuesImpl chan uid cid data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -179,25 +179,23 @@ pushSlowlyImpl ps = pushImpl [p] setUpUserNotificationQueuesImpl :: - ( Member (Embed IO) r - ) => Channel -> UserId -> ClientId -> - Sem r () + IO Text setUpUserNotificationQueuesImpl chan uid cid = do - let qName = idToText uid let cidText = decodeUtf8 $ toByteString' cid + let qName = idToText uid <> cidText let routingKeys = [ qName, qName <> "." <> cidText ] - liftIO $ do - let headers = - FieldTable $ - Map.fromList - [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), - ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) - ] - void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} - for_ routingKeys $ bindQueue chan qName userNotificationExchangeName + let headers = + FieldTable $ + Map.fromList + [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), + ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) + ] + void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} + for_ routingKeys $ bindQueue chan qName userNotificationExchangeName + pure qName diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 1eb1b4cdd26..f8f9ea0cb87 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -23,6 +23,7 @@ library Cannon.App Cannon.Dict Cannon.Options + Cannon.RabbitMqConsumerApp Cannon.Run Cannon.Types Cannon.WS @@ -79,6 +80,7 @@ library build-depends: aeson >=2.0.1.0 + , amqp , api-field-json-th >=0.1.0.2 , async >=2.0 , base >=4.6 && <5 @@ -118,6 +120,7 @@ library , websockets >=0.11.2 , wire-api , wire-otel + , wire-subsystems default-language: GHC2021 diff --git a/services/cannon/cannon.integration.yaml b/services/cannon/cannon.integration.yaml index e7e7985fea8..7af22a70b8b 100644 --- a/services/cannon/cannon.integration.yaml +++ b/services/cannon/cannon.integration.yaml @@ -16,6 +16,14 @@ gundeck: host: 127.0.0.1 port: 8086 +rabbitmq: + host: 127.0.0.1 + port: 5671 + vHost: / + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false + drainOpts: gracePeriodSeconds: 1 millisecondsBetweenBatches: 500 diff --git a/services/cannon/cannon2.integration.yaml b/services/cannon/cannon2.integration.yaml index cb5fb6c371e..1fc81233c38 100644 --- a/services/cannon/cannon2.integration.yaml +++ b/services/cannon/cannon2.integration.yaml @@ -16,6 +16,14 @@ gundeck: host: 127.0.0.1 port: 8086 +rabbitmq: + host: 127.0.0.1 + port: 5671 + vHost: / + enableTls: true + caCert: test/resources/rabbitmq-ca.pem + insecureSkipVerifyTls: false + drainOpts: gracePeriodSeconds: 1 millisecondsBetweenBatches: 5 diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index b51949e490c..2ad956a087c 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -15,12 +15,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Cannon.App - ( wsapp, - terminate, - maxPingInterval, - ) -where +module Cannon.App where import Cannon.WS import Control.Concurrent.Async @@ -39,7 +34,6 @@ import Network.Wai.Utilities.Error import Network.WebSockets hiding (Request, Response, requestHeaders) import System.Logger.Class hiding (Error, close) import System.Logger.Class qualified as Logger -import Data.Id -- | Connection state, updated by {read, write}Loop. data State = State !Int !Timeout @@ -66,11 +60,6 @@ maxPingInterval = 3600 maxLifetime :: Word64 maxLifetime = 3 * 24 * 3600 -rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp -rabbitMQWebSocketApp uid cid env = do - env.rabbitmq - undefined - wsapp :: Key -> Maybe ClientId -> Env -> ServerApp wsapp k c e pc = runWS e (go `catches` ioErrors k) where diff --git a/services/cannon/src/Cannon/Options.hs b/services/cannon/src/Cannon/Options.hs index feff15bd93f..b03b6f68e98 100644 --- a/services/cannon/src/Cannon/Options.hs +++ b/services/cannon/src/Cannon/Options.hs @@ -30,6 +30,7 @@ module Cannon.Options logNetStrings, logFormat, drainOpts, + rabbitmq, Opts, gracePeriodSeconds, millisecondsBetweenBatches, @@ -40,11 +41,12 @@ module Cannon.Options where import Control.Lens (makeFields) +import Data.Aeson import Data.Aeson.APIFieldJsonTH import Imports +import Network.AMQP.Extended (AmqpEndpoint) import System.Logger.Extended (Level, LogFormat) import Wire.API.Routes.Version -import Network.AMQP.Extended (AmqpEndpoint) data Cannon = Cannon { _cannonHost :: !String, @@ -99,4 +101,14 @@ data Opts = Opts makeFields ''Opts -deriveApiFieldJSON ''Opts +instance FromJSON Opts where + parseJSON = withObject "CannonOpts" $ \o -> + Opts + <$> o .: "cannon" + <*> o .: "gundeck" + <*> o .: "rabbitmq" + <*> o .: "logLevel" + <*> o .:? "logNetStrings" + <*> o .:? "logFormat" + <*> o .: "drainOpts" + <*> o .: "disabledAPIVersions" diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs new file mode 100644 index 00000000000..03f3ce3c235 --- /dev/null +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -0,0 +1,32 @@ +module Cannon.RabbitMqConsumerApp where + +import Cannon.App (rejectOnError) +import Cannon.WS +import Control.Exception (catch) +import Data.Id +import Imports +import Network.AMQP qualified as Amqp +import Network.AMQP.Extended (RabbitMqHooks (..), openConnectionWithRetries) +import Network.AMQP.Lifted qualified as AmqpL +import Network.WebSockets +import Network.WebSockets qualified as WS +import Wire.NotificationSubsystem.Interpreter + +rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp +rabbitMQWebSocketApp uid cid e pendingConn = do + wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) + openConnectionWithRetries e.logg e.rabbitmq $ + RabbitMqHooks + { onNewChannel = \chan -> do + -- declareQueue for the client + -- TODO: Don't use the interpreter + qName <- setUpUserNotificationQueuesImpl chan uid cid + void $ AmqpL.consumeMsgs chan qName Amqp.Ack (pushEventsToWS wsConn), + -- subscribe to the queue + onChannelException = \_ -> WS.sendClose wsConn ("channel-exception" :: ByteString), + onConnectionClose = WS.sendClose wsConn ("rabbitmq-conn-close" :: ByteString) + } + +pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () +pushEventsToWS wsConn (msg, _envelope) = + WS.sendBinaryData wsConn msg.msgBody diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index eefd22f4af5..4f588c209ab 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -28,7 +28,7 @@ import Cannon.App (maxPingInterval) import Cannon.Dict qualified as D import Cannon.Options import Cannon.Types (Cannon, applog, clients, env, mkEnv, runCannon, runCannonToServant) -import Cannon.WS hiding (env) +import Cannon.WS hiding (drainOpts, env) import Control.Concurrent import Control.Concurrent.Async qualified as Async import Control.Exception qualified as E @@ -78,6 +78,7 @@ run o = withTracer \tracer -> do <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock + <*> pure (o ^. Cannon.Options.rabbitmq) refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 6fa37b78a65..e1da89a70af 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -45,6 +45,7 @@ import Control.Monad.Catch import Data.Id import Data.Text.Encoding import Imports +import Network.AMQP.Extended (AmqpEndpoint) import Prometheus import Servant qualified import System.Logger qualified as Logger @@ -99,10 +100,11 @@ mkEnv :: Manager -> GenIO -> Clock -> + AmqpEndpoint -> Env -mkEnv external o l d p g t = +mkEnv external o l d p g t rabbitmqOpts = Env o l d (RequestId defRequestId) $ - WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) + WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) rabbitmqOpts runCannon :: Env -> Cannon a -> IO a runCannon e c = runReaderT (unCannon c) e diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index f2a976307d3..ae3cfd82bd1 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -18,7 +18,7 @@ -- with this program. If not, see . module Cannon.WS - ( Env, + ( Env (..), WS, env, runWS, @@ -67,6 +67,7 @@ import Data.List.Extra (chunksOf) import Data.Text.Encoding (decodeUtf8) import Data.Timeout (TimeoutUnit (..), (#)) import Imports hiding (threadDelay) +import Network.AMQP.Extended import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error @@ -192,8 +193,9 @@ env :: GenIO -> Clock -> DrainOpts -> + AmqpEndpoint -> Env -env leh lp gh gp = Env leh lp (host gh . port gp $ empty) (RequestId defRequestId) +env leh lp gh gp = Env leh lp (Bilge.host gh . Bilge.port gp $ empty) (RequestId defRequestId) runWS :: (MonadIO m) => Env -> WS a -> m a runWS e m = liftIO $ runReaderT (_conn m) e diff --git a/services/cannon/test/resources/rabbitmq-ca.pem b/services/cannon/test/resources/rabbitmq-ca.pem new file mode 100644 index 00000000000..2aa8d89e4ac --- /dev/null +++ b/services/cannon/test/resources/rabbitmq-ca.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDJTCCAg2gAwIBAgIUBbMHNT+GZgCVyopxX3sciD+E5uowDQYJKoZIhvcNAQEL +BQAwIjEgMB4GA1UEAwwXcmFiYml0bXEuY2EuZXhhbXBsZS5jb20wHhcNMjQwOTAz +MTIwMzQwWhcNMzQwOTAxMTIwMzQwWjAiMSAwHgYDVQQDDBdyYWJiaXRtcS5jYS5l +eGFtcGxlLmNvbTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAJP2rB1X +qxpRAE6hSYkYbfd/pdfOrVbSwsZqYj866ijrtZFh0+AWtjYUkiLFYGiXINZdns6S +LVP8afPCXKynjZ/2zzIpuvX51zhHtrulxBcKyN85gckm03KGLz5GNGFNl8CeYJfu +RWJSA+AOxkR28CkBBD5eR0cRc8j0E9buDtY36wmgqEtkDvAc4PvmgAIPL2KovmmM +ohGy2hHJZLKCA+QGzeLUqQx8MTF3RsajV8ttRg+wfUQM6wdMJbub93wmgLVfncaQ +dO9E/jEVr2kU0WeJ1kmxs40d1bd02U3/8omGyayRGX9qqfaF3g+oDzAoiF7LbDuC +7VNVEc8/PP1t6b0CAwEAAaNTMFEwHQYDVR0OBBYEFOv/4GK9l7p7p9nk2hf/59sD +PhEVMB8GA1UdIwQYMBaAFOv/4GK9l7p7p9nk2hf/59sDPhEVMA8GA1UdEwEB/wQF +MAMBAf8wDQYJKoZIhvcNAQELBQADggEBABt+JodEGOjnFA+VCnRWOGl1q4wlcEbl ++5mEuVwwWGzbispmJxIdf+FlOotonvhksGQUDZ3gr7FvLcsGy6OnOK2YBSLOcnRP +amKPaiQwB38VcxQEUOL+1ZqLsLTseGJUCkGk+OmfjInqCURS5jRUbVtYZiqkzD40 +7Rz5iyrXwv1vbuXpW2s/kUgD6dLrRwt1ydaxCbA3C92farZJFvpUwTyhAXUkKyPZ +Hgu5E/nppujH2h6nOJfHGcyaVHai7pDManjO1icWmfx+t2s94rdAEevvBu0k/qL4 +tXWWSh81MtGjLjQ88ozbmr7/LSo3KaAB7M/AnZdL3JjtmFy9eFhqQaY= +-----END CERTIFICATE----- From cf9ed157d85dd1c1b61b3d18da557269e3a2ae30 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 30 Sep 2024 17:24:11 +0200 Subject: [PATCH 13/93] gundeck: Start implementing push to rabbitmq --- services/gundeck/src/Gundeck/Push.hs | 53 ++++++++++++++++++++++++++-- 1 file changed, 50 insertions(+), 3 deletions(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 0899b81360e..d8df55d0f58 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -29,12 +29,15 @@ module Gundeck.Push ) where +import Bilge qualified +import Control.Arrow ((&&&)) import Control.Error import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens (to, view, (.~), (^.)) import Control.Monad.Catch import Control.Monad.Except (throwError) import Data.Aeson as Aeson (Object) +import Data.ByteString.Conversion (toByteString') import Data.Id import Data.List.Extra qualified as List import Data.List1 (List1, list1) @@ -62,11 +65,14 @@ import Network.HTTP.Types import Network.Wai.Utilities import System.Logger.Class (msg, val, (+++), (.=), (~~)) import System.Logger.Class qualified as Log +import Util.Options import Wire.API.Internal.Notification import Wire.API.Presence (Presence (..)) import Wire.API.Presence qualified as Presence import Wire.API.Push.Token qualified as Public import Wire.API.Push.V2 +import Wire.API.User (UserSet (..)) +import Wire.API.User.Client (Client (..), ClientCapability (..), ClientCapabilityList (..), UserClientsFull (..)) push :: [Push] -> Gundeck () push ps = do @@ -123,8 +129,49 @@ instance MonadMapAsync Gundeck where Nothing -> mapAsync f l Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) --- splitPushes :: [Push] -> m ([Push], [Push]) --- splitPushes = undefined +splitPushes :: [Push] -> m ([Push], [Push]) +splitPushes = + undefined + +splitPush :: Push -> m ([Push], [Push]) +splitPush push = do + let allRecipients = fromRange $ push._pushRecipients + undefined + +-- TODO: optimize for possibility of many pushes having the same users +splitRecipient :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => Recipient -> m (Maybe Recipient, Maybe Recipient) +splitRecipient r = do + clientsFull <- getClients r._recipientId + let allClients = Map.findWithDefault mempty r._recipientId $ clientsFull.userClientsFull + let relevantClients = case r._recipientClients of + RecipientClientsSome cs -> + Set.filter (\c -> c.clientId `elem` toList cs) allClients + RecipientClientsAll -> allClients + (capableClients, incapableClients) = Set.partition (\c -> ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList) relevantClients + capableClientIds = (.clientId) <$> Set.toList capableClients + incapableClientIds = (.clientId) <$> Set.toList incapableClients + case (capableClientIds, incapableClientIds) of + ([], _) -> pure (Nothing, Just r) + (_, []) -> pure (Just r, Nothing) + (c : cs, i : is) -> + pure + ( Just $ r {_recipientClients = RecipientClientsSome $ list1 c cs}, + Just $ r {_recipientClients = RecipientClientsSome $ list1 i is} + ) + +getClients :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => UserId -> m UserClientsFull +getClients uid = do + r <- do + Endpoint h p <- view $ options . brig + Bilge.post + ( Bilge.host (toByteString' h) + . Bilge.port p + . Bilge.path "/i/clients/full" + . Bilge.json (UserSet $ Set.singleton uid) + ) + when (Bilge.statusCode r /= 200) $ do + error "something went wrong" + Bilge.responseJsonError r -- Old way: -- Client -> Cannon: establish WS (/await) @@ -265,7 +312,7 @@ shouldActuallyPush psh rcp pres = not isOrigin && okByPushAllowlist && okByRecip okByRecipientAllowlist :: Bool okByRecipientAllowlist = - case (rcp ^. recipientClients, clientId pres) of + case (rcp ^. recipientClients, pres.clientId) of (RecipientClientsSome cs, Just c) -> c `elem` cs _ -> True From 94659ee0bcce90d7f7b2d7443947170595fbc965 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 14:50:42 +0200 Subject: [PATCH 14/93] integration: Fix assertion to assert on a real event --- integration/test/Test/Events.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 8b5ab01a6a2..a0a05c8d6f6 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -2,7 +2,6 @@ module Test.Events where import API.Brig import API.BrigCommon -import API.Common import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Data.ByteString.Conversion (toByteString') @@ -20,9 +19,12 @@ testConsumeEvents = do clientId <- objId client eventsChan <- liftIO newTChanIO wsThread <- eventsWebSocket alice clientId eventsChan - randomHandle >>= putHandle alice >>= assertSuccess mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - mEvent `shouldMatch` (Right (object ["payload" .= ["event1"]]) :: Either () Value) + case mEvent of + Left () -> assertFailure "No event recieved for 1s" + Right e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId cancel wsThread eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> App (Async ()) From d689885d282f4a501a41bc8bc21aa1a1641f9bf0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 14:51:33 +0200 Subject: [PATCH 15/93] integration: Use correct vHost in cannon --- integration/test/Testlib/ModService.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 3dabfdcd1e7..057559d2ed2 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -189,7 +189,9 @@ startDynamicBackend resource beOverrides = do federatorInternalCfg = setField "federatorInternal.port" resource.berFederatorInternal >=> setField "federatorExternal.port" resource.berFederatorExternal - >=> setField "optSettings.setFederationDomain" resource.berDomain + >=> setField "optSettings.setFederationDomain" resource.berDomain, + cannonCfg = + setField "rabbitmq.vHost" resource.berVHost } setKeyspace :: ServiceOverrides From 2ba7f1d373aac174e79ef9ab6faa7bfd605b8923 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 14:52:24 +0200 Subject: [PATCH 16/93] cannon: Ensure exchange exists and publish event correctly on WS --- services/cannon/src/Cannon/API/Public.hs | 10 +++++++--- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 5 ++++- services/cannon/src/Cannon/Run.hs | 9 +++++++++ 3 files changed, 20 insertions(+), 4 deletions(-) diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index 8eb96de8b3e..e895429ae8b 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -21,6 +21,7 @@ module Cannon.API.Public where import Cannon.App (wsapp) +import Cannon.RabbitMqConsumerApp (rabbitMQWebSocketApp) import Cannon.Types import Cannon.WS import Control.Monad.IO.Class @@ -32,8 +33,9 @@ import Wire.API.Routes.Named import Wire.API.Routes.Public.Cannon publicAPIServer :: ServerT CannonAPI Cannon -publicAPIServer = Named @"await-notifications" streamData - :<|> Named @"consume-events" consumeEvents +publicAPIServer = + Named @"await-notifications" streamData + :<|> Named @"consume-events" consumeEvents streamData :: UserId -> ConnId -> Maybe ClientId -> PendingConnection -> Cannon () streamData userId connId clientId con = do @@ -41,4 +43,6 @@ streamData userId connId clientId con = do liftIO $ wsapp (mkKey userId connId) clientId e con consumeEvents :: UserId -> ClientId -> PendingConnection -> Cannon () -consumeEvents = undefined +consumeEvents userId clientId con = do + e <- wsenv + liftIO $ rabbitMQWebSocketApp userId clientId e con diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 03f3ce3c235..5c3fc41c53f 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -3,6 +3,7 @@ module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) import Cannon.WS import Control.Exception (catch) +import Data.Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp @@ -29,4 +30,6 @@ rabbitMQWebSocketApp uid cid e pendingConn = do pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () pushEventsToWS wsConn (msg, _envelope) = - WS.sendBinaryData wsConn msg.msgBody + case eitherDecode @Value msg.msgBody of + Left e -> error e + Right payload -> WS.sendBinaryData wsConn (encode $ object ["payload" .= payload]) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 4f588c209ab..1905f7ae70b 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -41,6 +41,8 @@ import Data.Text (pack, strip) import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Imports hiding (head, threadDelay) +import Network.AMQP +import Network.AMQP.Extended (mkRabbitMqChannelMVar) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Middleware.Gzip qualified as Gzip @@ -56,6 +58,7 @@ import System.Logger.Extended qualified as L import System.Posix.Signals import System.Posix.Signals qualified as Signals import System.Random.MWC (createSystemRandom) +import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Routes.Internal.Cannon qualified as Internal import Wire.API.Routes.Public.Cannon import Wire.API.Routes.Version @@ -79,6 +82,7 @@ run o = withTracer \tracer -> do <*> createSystemRandom <*> mkClock <*> pure (o ^. Cannon.Options.rabbitmq) + createUserNotificationsExchange $ applog e refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) @@ -119,6 +123,11 @@ run o = withTracer \tracer -> do readExternal :: FilePath -> IO ByteString readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f + createUserNotificationsExchange :: L.Logger -> IO () + createUserNotificationsExchange l = do + chan <- Imports.readMVar =<< mkRabbitMqChannelMVar l (o ^. Cannon.Options.rabbitmq) + declareExchange chan newExchange {exchangeName = userNotificationExchangeName, exchangeType = "topic"} + signalHandler :: Env -> ThreadId -> Signals.Handler signalHandler e mainThread = CatchOnce $ do runWS e drain From c6efecd7fdf719028a9b9bec77a8dcb7013030b7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 14:52:59 +0200 Subject: [PATCH 17/93] NotificationSubsystem: Align names for queues and extract them as top level bindings --- .../Wire/NotificationSubsystem/Interpreter.hs | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index b4135df8f32..f134eb2dbc1 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -4,8 +4,7 @@ import Bilge (RequestId) import Control.Concurrent.Async (Async) import Control.Lens (set, (.~)) import Data.Aeson -import Data.ByteString.Conversion -import Data.Id (ClientId, UserId, idToText) +import Data.Id (ClientId, UserId, clientToText, idToText) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 @@ -184,12 +183,8 @@ setUpUserNotificationQueuesImpl :: ClientId -> IO Text setUpUserNotificationQueuesImpl chan uid cid = do - let cidText = decodeUtf8 $ toByteString' cid - let qName = idToText uid <> cidText - let routingKeys = - [ qName, - qName <> "." <> cidText - ] + let qName = "user-notifications." <> idToText uid <> "." <> clientToText cid + -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies let headers = FieldTable $ Map.fromList @@ -197,5 +192,11 @@ setUpUserNotificationQueuesImpl chan uid cid = do ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) ] void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} - for_ routingKeys $ bindQueue chan qName userNotificationExchangeName + for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName pure qName + +userRoutingKey :: UserId -> Text +userRoutingKey = idToText + +clientRoutingKey :: UserId -> ClientId -> Text +clientRoutingKey uid cid = idToText uid <> "." <> clientToText cid From c4e4fe563478eeda228d7a9319300f5299fcc94a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 14:54:05 +0200 Subject: [PATCH 18/93] gundeck: Push events to RabbitMQ for compatible clients --- services/gundeck/gundeck.cabal | 1 + services/gundeck/src/Gundeck/Push.hs | 109 +++++++++++++++++----- services/gundeck/test/unit/MockGundeck.hs | 1 + 3 files changed, 87 insertions(+), 24 deletions(-) diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index ab7d6a7965f..749732f280d 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -168,6 +168,7 @@ library , wai-utilities >=0.16 , wire-api , wire-otel + , wire-subsystems , yaml >=0.8 default-language: GHC2021 diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index d8df55d0f58..3c270aaac8c 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -36,7 +36,7 @@ import Control.Exception (ErrorCall (ErrorCall)) import Control.Lens (to, view, (.~), (^.)) import Control.Monad.Catch import Control.Monad.Except (throwError) -import Data.Aeson as Aeson (Object) +import Data.Aeson qualified as Aeson import Data.ByteString.Conversion (toByteString') import Data.Id import Data.List.Extra qualified as List @@ -61,18 +61,22 @@ import Gundeck.Push.Websocket qualified as Web import Gundeck.ThreadBudget import Gundeck.Util import Imports +import Network.AMQP (Message (..)) +import Network.AMQP qualified as Q import Network.HTTP.Types import Network.Wai.Utilities import System.Logger.Class (msg, val, (+++), (.=), (~~)) import System.Logger.Class qualified as Log import Util.Options import Wire.API.Internal.Notification +import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Presence (Presence (..)) import Wire.API.Presence qualified as Presence import Wire.API.Push.Token qualified as Public import Wire.API.Push.V2 import Wire.API.User (UserSet (..)) import Wire.API.User.Client (Client (..), ClientCapability (..), ClientCapabilityList (..), UserClientsFull (..)) +import Wire.NotificationSubsystem.Interpreter push :: [Push] -> Gundeck () push ps = do @@ -90,6 +94,8 @@ class (MonadThrow m) => MonadPushAll m where mpaPushNative :: Notification -> Priority -> [Address] -> m () mpaForkIO :: m () -> m () mpaRunWithBudget :: Int -> a -> m a -> m a + mpaGetClients :: UserId -> m UserClientsFull + mpaPublishToRabbitMq :: Text -> Q.Message -> m () instance MonadPushAll Gundeck where mpaNotificationTTL = view (options . settings . notificationTTL) @@ -100,6 +106,13 @@ instance MonadPushAll Gundeck where mpaPushNative = pushNative mpaForkIO = void . forkIO mpaRunWithBudget = runWithBudget'' + mpaGetClients = getClients + mpaPublishToRabbitMq = publishToRabbitMq + +publishToRabbitMq :: Text -> Q.Message -> Gundeck () +publishToRabbitMq routingKey qMsg = do + chan <- readMVar =<< view rabbitMqChannel + void $ liftIO $ Q.publishMsg chan userNotificationExchangeName routingKey qMsg -- | Another layer of wrap around 'runWithBudget'. runWithBudget'' :: Int -> a -> Gundeck a -> Gundeck a @@ -129,34 +142,52 @@ instance MonadMapAsync Gundeck where Nothing -> mapAsync f l Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) -splitPushes :: [Push] -> m ([Push], [Push]) -splitPushes = - undefined +splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) +splitPushes = fmap foldMaybeTuple . traverse splitPush + +-- TODO: Make it reutrn These +splitPush :: (MonadPushAll m) => Push -> m (Maybe Push, Maybe Push) +splitPush p = do + let allRecipients = Set.toList $ fromRange $ p._pushRecipients + (rabbitmqRecipients, legacyRecipients) <- foldMaybeTuple <$> traverse splitRecipient allRecipients + case (rabbitmqRecipients, legacyRecipients) of + ([], _) -> pure (Nothing, Just p) + (_, []) -> pure (Just p, Nothing) + (_ : _, _ : _) -> + -- Since we just proved that both the recipient lists are not empty and + -- they cannot be bigger than the limit as none of them can be bigger than + -- the original recipient set, it is safe to use unsafeRange here. + -- + -- TODO: See if there is a better way, so we don't have to use unsafeRange + pure + ( Just $ p {_pushRecipients = unsafeRange $ Set.fromList rabbitmqRecipients}, + Just $ p {_pushRecipients = unsafeRange $ Set.fromList legacyRecipients} + ) -splitPush :: Push -> m ([Push], [Push]) -splitPush push = do - let allRecipients = fromRange $ push._pushRecipients - undefined +foldMaybeTuple :: [(Maybe a, Maybe b)] -> ([a], [b]) +foldMaybeTuple = foldr (\(x, y) (xs, ys) -> ((maybeToList x <> xs), (maybeToList y <> ys))) ([], []) -- TODO: optimize for possibility of many pushes having the same users -splitRecipient :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => Recipient -> m (Maybe Recipient, Maybe Recipient) -splitRecipient r = do - clientsFull <- getClients r._recipientId - let allClients = Map.findWithDefault mempty r._recipientId $ clientsFull.userClientsFull - let relevantClients = case r._recipientClients of +-- TODO: Make this return These +splitRecipient :: (MonadPushAll m) => Recipient -> m (Maybe Recipient, Maybe Recipient) +splitRecipient rcpt = do + clientsFull <- mpaGetClients rcpt._recipientId + let allClients = Map.findWithDefault mempty rcpt._recipientId $ clientsFull.userClientsFull + let relevantClients = case rcpt._recipientClients of RecipientClientsSome cs -> Set.filter (\c -> c.clientId `elem` toList cs) allClients RecipientClientsAll -> allClients - (capableClients, incapableClients) = Set.partition (\c -> ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList) relevantClients - capableClientIds = (.clientId) <$> Set.toList capableClients - incapableClientIds = (.clientId) <$> Set.toList incapableClients - case (capableClientIds, incapableClientIds) of - ([], _) -> pure (Nothing, Just r) - (_, []) -> pure (Just r, Nothing) - (c : cs, i : is) -> + isClientForRabbitMq c = ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList + (rabbitmqClients, legacyClients) = Set.partition isClientForRabbitMq relevantClients + rabbitmqClientIds = (.clientId) <$> Set.toList rabbitmqClients + legacyClientIds = (.clientId) <$> Set.toList legacyClients + case (rabbitmqClientIds, legacyClientIds) of + ([], _) -> pure (Nothing, Just rcpt) + (_, []) -> pure (Just rcpt, Nothing) + (r : rs, l : ls) -> pure - ( Just $ r {_recipientClients = RecipientClientsSome $ list1 c cs}, - Just $ r {_recipientClients = RecipientClientsSome $ list1 i is} + ( Just $ rcpt {_recipientClients = RecipientClientsSome $ list1 r rs}, + Just $ rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} ) getClients :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => UserId -> m UserClientsFull @@ -182,10 +213,17 @@ getClients uid = do -- Galley -> Gundeck -> RabbitMQ: Always Publish to queue -- Client -> Cannon -> RabbitMQ: establish WS and subscribe to the queue (/events) +pushAll :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m, Log.MonadLogger m) => [Push] -> m () +pushAll pushes = do + Log.warn $ msg (val "pushing") . Log.field "pushes" (Aeson.encode pushes) + (rabbitmqPushes, legacyPushes) <- splitPushes pushes + pushAllLegacy legacyPushes + pushAllViaRabbitMq rabbitmqPushes + -- | Construct and send a single bulk push request to the client. Write the 'Notification's from -- the request to C*. Trigger native pushes for all delivery failures notifications. -pushAll :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m) => [Push] -> m () -pushAll pushes = do +pushAllLegacy :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m) => [Push] -> m () +pushAllLegacy pushes = do newNotifications <- mapM mkNewNotification pushes -- let rs = concatMap (toList . (.nnRecipients)) newNotifications -- (capableClients, incapableClients) :: ([Recipient], [Recipient]) <- splitClients rs @@ -214,6 +252,29 @@ pushAll pushes = do mpaRunWithBudget cost () $ mpaPushNative notif (psh ^. pushNativePriority) =<< nativeTargets psh rcps' alreadySent +pushAllViaRabbitMq :: (MonadPushAll m) => [Push] -> m () +pushAllViaRabbitMq pushes = + for_ pushes $ pushViaRabbitMq + +pushViaRabbitMq :: (MonadPushAll m) => Push -> m () +pushViaRabbitMq p = do + let qMsg = + Q.newMsg + { msgBody = Aeson.encode p._pushPayload, + msgContentType = Just "application/json" + } + routingKeys = + Set.unions $ + flip Set.map (fromRange p._pushRecipients) \r -> + case r._recipientClients of + RecipientClientsAll -> + Set.singleton $ userRoutingKey r._recipientId + RecipientClientsSome (toList -> cs) -> + Set.fromList $ map (clientRoutingKey r._recipientId) cs + -- TODO: Figure out if there is a bulk operation in amqp + for_ routingKeys $ \routingKey -> + mpaPublishToRabbitMq routingKey qMsg + -- | A new notification to be stored in C* and pushed over websockets data NewNotification = NewNotification { nnPush :: Push, diff --git a/services/gundeck/test/unit/MockGundeck.hs b/services/gundeck/test/unit/MockGundeck.hs index 10bc5806bb6..fede2c00137 100644 --- a/services/gundeck/test/unit/MockGundeck.hs +++ b/services/gundeck/test/unit/MockGundeck.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Disabling to stop warnings on HasCallStack {-# OPTIONS_GHC -Wno-redundant-constraints #-} From 78cfda935e4ec291e8a86b0e3fe6c58bae73f971 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 16:12:34 +0200 Subject: [PATCH 19/93] integration: Assert that acked events don't come back --- integration/test/Test/Events.hs | 56 ++++++++++++++++++++++----------- 1 file changed, 38 insertions(+), 18 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index a0a05c8d6f6..30929138d28 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -2,6 +2,7 @@ module Test.Events where import API.Brig import API.BrigCommon +import API.Common import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Data.ByteString.Conversion (toByteString') @@ -9,7 +10,7 @@ import qualified Network.WebSockets.Client as WS import qualified Network.WebSockets.Connection as WS import SetupHelpers import Testlib.Prelude -import UnliftIO (Async, async, cancel, race) +import UnliftIO (Async, async, cancel, race, waitAny) import UnliftIO.Concurrent (threadDelay) testConsumeEvents :: (HasCallStack) => App () @@ -17,34 +18,53 @@ testConsumeEvents = do alice <- randomUser OwnDomain def client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - eventsChan <- liftIO newTChanIO - wsThread <- eventsWebSocket alice clientId eventsChan - mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - case mEvent of - Left () -> assertFailure "No event recieved for 1s" - Right e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - cancel wsThread + do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket alice clientId eventsChan ackChan + mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) + case mEvent of + Left () -> assertFailure "No event recieved for 1s" + Right e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + deliveryTag <- e %. "delivery_tag" + liftIO $ atomically $ writeTChan ackChan $ object ["ack" .= deliveryTag] + cancel wsThread -eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> App (Async ()) -eventsWebSocket user clientId eventsChan = do + handle <- randomHandle + putHandle alice handle >>= assertSuccess + do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket alice clientId eventsChan ackChan + mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) + case mEvent of + Left () -> assertFailure "No event recieved for 1s" + Right e -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle + cancel wsThread + +eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> App (Async ()) +eventsWebSocket user clientId eventsChan ackChan = do serviceMap <- getServiceMap =<< objDomain user uid <- objId =<< objQidObject user let HostPort caHost caPort = serviceHostPort serviceMap Cannon path = "/events?client=" <> clientId caHdrs = [(fromString "Z-User", toByteString' uid)] - app = wsRead - -- r <- async wsRead - -- w <- async wsWrite + app conn = do + r <- async $ wsRead conn + w <- async $ wsWrite conn + void $ waitAny [r, w] wsRead conn = forever $ do bs <- WS.receiveData conn case decodeStrict' bs of Just n -> atomically $ writeTChan eventsChan n Nothing -> putStrLn $ "Failed to decode events: " ++ show bs - -- wsWrite = forever $ do - -- takeMVar latch - -- WS.sendClose conn ("close" :: ByteString) + wsWrite conn = forever $ do + ack <- atomically $ readTChan ackChan + WS.sendBinaryData conn (encode ack) liftIO $ async $ WS.runClientWith From f900dc8f3446a23a0ed501d2345abc9e5379f47d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 16:13:39 +0200 Subject: [PATCH 20/93] cannon: Forward client acks to rabbitmq --- libs/extended/src/Network/AMQP/Extended.hs | 40 ++++++++++++++++++ .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 42 ++++++++++++------- 2 files changed, 68 insertions(+), 14 deletions(-) diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 39cc20de1a2..055cdd57154 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -4,6 +4,7 @@ module Network.AMQP.Extended ( RabbitMqHooks (..), RabbitMqAdminOpts (..), AmqpEndpoint (..), + withConnection, openConnectionWithRetries, mkRabbitMqAdminClientEnv, mkRabbitMqChannelMVar, @@ -145,6 +146,45 @@ data RabbitMqConnectionError = RabbitMqConnectionFailed String instance Exception RabbitMqConnectionError +-- | Connects with RabbitMQ and opens a channel. +withConnection :: + forall m a. + (MonadIO m, MonadMask m) => + Logger -> + AmqpEndpoint -> + (Q.Connection -> m a) -> + m a +withConnection l AmqpEndpoint {..} k = do + (username, password) <- liftIO $ readCredsFromEnv + -- Jittered exponential backoff with 1ms as starting delay and 1s as total + -- wait time. + let policy = limitRetriesByCumulativeDelay 1_000_000 $ fullJitterBackoff 1000 + logError willRetry e retryStatus = do + Log.err l $ + Log.msg (Log.val "Failed to connect to RabbitMQ") + . Log.field "error" (displayException @SomeException e) + . Log.field "willRetry" willRetry + . Log.field "retryCount" retryStatus.rsIterNumber + getConn = + recovering + policy + ( skipAsyncExceptions + <> [logRetries (const $ pure True) logError] + ) + ( const $ do + Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") + mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls + liftIO $ + Q.openConnection'' $ + Q.defaultConnectionOpts + { Q.coServers = [(host, fromIntegral port)], + Q.coVHost = vHost, + Q.coAuth = [Q.plain username password], + Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings + } + ) + bracket getConn (liftIO . Q.closeConnection) k + -- | Connects with RabbitMQ and opens a channel. If the channel is closed for -- some reasons, reopens the channel. If the connection is closed for some -- reasons, keeps retrying to connect until it works. diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 5c3fc41c53f..2149295484a 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -3,33 +3,47 @@ module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) import Cannon.WS import Control.Exception (catch) +import Control.Monad.Catch (Handler (..), MonadThrow, throwM) import Data.Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp -import Network.AMQP.Extended (RabbitMqHooks (..), openConnectionWithRetries) +import Network.AMQP.Extended (withConnection) import Network.AMQP.Lifted qualified as AmqpL import Network.WebSockets import Network.WebSockets qualified as WS +import System.Logger qualified as Log +import UnliftIO (catches) import Wire.NotificationSubsystem.Interpreter rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - openConnectionWithRetries e.logg e.rabbitmq $ - RabbitMqHooks - { onNewChannel = \chan -> do - -- declareQueue for the client - -- TODO: Don't use the interpreter - qName <- setUpUserNotificationQueuesImpl chan uid cid - void $ AmqpL.consumeMsgs chan qName Amqp.Ack (pushEventsToWS wsConn), - -- subscribe to the queue - onChannelException = \_ -> WS.sendClose wsConn ("channel-exception" :: ByteString), - onConnectionClose = WS.sendClose wsConn ("rabbitmq-conn-close" :: ByteString) - } + withConnection e.logg e.rabbitmq $ \conn -> do + chan <- liftIO $ Amqp.openChannel conn + -- TODO: Don't use the interpreter + qName <- setUpUserNotificationQueuesImpl chan uid cid + let cleanup :: (Exception e, MonadThrow m, MonadIO m) => e -> m () + cleanup err = do + Log.err e.logg $ Log.msg (Log.val "Pushing to WS failed") . Log.field "error" (displayException err) + throwM err + handlers = [Handler $ cleanup @SomeException, Handler $ cleanup @SomeAsyncException] + _consumerTag <- + AmqpL.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) + forever $ do + eitherMsg :: Either String ClientMessage <- eitherDecode <$> WS.receiveData wsConn + case eitherMsg of + Left err -> error err + Right msg -> do + void $ Amqp.ackMsg chan msg.ack False + +data ClientMessage = ClientMessage {ack :: Word64} + +instance FromJSON ClientMessage where + parseJSON = withObject "ClientMessage" $ \o -> ClientMessage <$> o .: "ack" pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () -pushEventsToWS wsConn (msg, _envelope) = +pushEventsToWS wsConn (msg, envelope) = case eitherDecode @Value msg.msgBody of Left e -> error e - Right payload -> WS.sendBinaryData wsConn (encode $ object ["payload" .= payload]) + Right payload -> WS.sendBinaryData wsConn (encode $ object ["payload" .= payload, "delivery_tag" .= envelope.envDeliveryTag]) From 7bb78fdcd318ce7d613af42634a7a6da87d4d105 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Oct 2024 16:42:42 +0200 Subject: [PATCH 21/93] WIP: Get rid of channel as an explicit param for NotificationSubsystem actions --- .../src/Wire/NotificationSubsystem.hs | 3 +-- .../Wire/NotificationSubsystem/Interpreter.hs | 11 +++++++---- services/brig/src/Brig/API/Client.hs | 18 +++++------------- services/brig/src/Brig/API/Internal.hs | 7 ++----- services/brig/src/Brig/API/Public.hs | 3 +-- services/brig/src/Brig/CanonicalInterpreter.hs | 1 + .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 2 +- 7 files changed, 18 insertions(+), 27 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs index 47cc92d7193..9274cce698d 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem.hs @@ -8,7 +8,6 @@ import Data.Aeson import Data.Id import Data.List.NonEmpty (NonEmpty ((:|))) import Imports -import Network.AMQP import Polysemy import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.Arbitrary @@ -50,7 +49,7 @@ data NotificationSubsystem m a where CleanupUser :: UserId -> NotificationSubsystem m () UnregisterPushClient :: UserId -> ClientId -> NotificationSubsystem m () GetPushTokens :: UserId -> NotificationSubsystem m [PushToken] - SetUpUserNotificationQueues :: Channel -> UserId -> ClientId -> NotificationSubsystem m () + SetupConsumableNotifications :: UserId -> ClientId -> NotificationSubsystem m () makeSem ''NotificationSubsystem diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index f134eb2dbc1..50ac0c9530b 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -41,7 +41,8 @@ runNotificationSubsystemGundeck :: Member Delay r, Member (Final IO) r, Member P.TinyLog r, - Member (Embed IO) r + Member (Embed IO) r, + Member (Input Channel) r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> @@ -53,7 +54,9 @@ runNotificationSubsystemGundeck cfg = interpret $ \case CleanupUser uid -> GundeckAPIAccess.userDeleted uid UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid - SetUpUserNotificationQueues chan uid cid -> void $ liftIO $ setUpUserNotificationQueuesImpl chan uid cid + SetupConsumableNotifications uid cid -> do + chan <- input + void $ liftIO $ setupConsumableNotificationsImpl chan uid cid data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -177,12 +180,12 @@ pushSlowlyImpl ps = delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) pushImpl [p] -setUpUserNotificationQueuesImpl :: +setupConsumableNotificationsImpl :: Channel -> UserId -> ClientId -> IO Text -setUpUserNotificationQueuesImpl chan uid cid = do +setupConsumableNotificationsImpl chan uid cid = do let qName = "user-notifications." <> idToText uid <> "." <> clientToText cid -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies let headers = diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index 439ba80e68c..9f3c0bd2892 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -86,11 +86,9 @@ import Data.Set qualified as Set import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error import Imports hiding ((\\)) -import Network.AMQP (Channel) import Network.HTTP.Types.Method (StdMethod) import Network.Wai.Utilities import Polysemy -import Polysemy.Input (Input, input) import Servant (Link, ToHttpApiData (toUrlPiece)) import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log @@ -173,8 +171,7 @@ addClient :: Member EmailSubsystem r, Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, - Member Events r, - Member (Input Channel) r + Member Events r ) => Local UserId -> Maybe ConnId -> @@ -193,8 +190,7 @@ addClientWithReAuthPolicy :: Member Events r, Member UserSubsystem r, Member AuthenticationSubsystem r, - Member VerificationCodeSubsystem r, - Member (Input Channel) r + Member VerificationCodeSubsystem r ) => Data.ReAuthPolicy -> Local UserId -> @@ -221,8 +217,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} when (ClientSupportsConsumableNotifications `Set.member` (foldMap fromClientCapabilityList mCaps)) $ lift $ liftSem $ do - chanMVar <- input - setUpUserNotificationQueues chanMVar u clt.clientId + setupConsumableNotifications u clt.clientId lift $ do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u clt.clientId @@ -249,9 +244,7 @@ addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed updateClient :: - ( Member NotificationSubsystem r, - Member (Input Channel) r - ) => + (Member NotificationSubsystem r) => UserId -> ClientId -> UpdateClient -> @@ -265,8 +258,7 @@ updateClient uid cid req = do -- first set up the notification queues then save the data is more robust than the other way around let addedCapabilities = caps.fromClientCapabilityList \\ client.clientCapabilities.fromClientCapabilityList when (ClientSupportsConsumableNotifications `Set.member` addedCapabilities) $ lift $ liftSem $ do - chanMVar <- input - setUpUserNotificationQueues chanMVar uid cid + setupConsumableNotifications uid cid wrapClientE $ lift . Data.updateClientCapabilities uid cid . Just $ caps else throwE $ clientError ClientCapabilitiesCannotBeRemoved let lk = maybeToList (unpackLastPrekey <$> req.updateClientLastKey) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d38c1fee7f5..d4f1d29391a 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -63,7 +63,6 @@ import Data.Set qualified as Set import Data.Text qualified as T import Data.Time.Clock.System import Imports hiding (head) -import Network.AMQP (Channel) import Network.Wai.Utilities as Utilities import Polysemy import Polysemy.Error qualified @@ -199,8 +198,7 @@ accountAPI :: Member PropertySubsystem r, Member Events r, Member PasswordResetCodeStore r, - Member InvitationCodeStore r, - Member (Input Channel) r + Member InvitationCodeStore r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -431,8 +429,7 @@ addClientInternalH :: Member Events r, Member UserSubsystem r, Member VerificationCodeSubsystem r, - Member AuthenticationSubsystem r, - Member (Input Channel) r + Member AuthenticationSubsystem r ) => UserId -> Maybe Bool -> diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index eb58661e379..1ee6814bb99 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -594,8 +594,7 @@ addClient :: Member AuthenticationSubsystem r, Member VerificationCodeSubsystem r, Member Events r, - Member UserSubsystem r, - Member (Input Channel) r + Member UserSubsystem r ) => Local UserId -> ConnId -> diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index d9d44c3bcdc..592938ceccd 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -23,6 +23,7 @@ import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports import Network.AMQP +import Network.AMQP qualified as Q import Polysemy import Polysemy.Async import Polysemy.Conc diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 2149295484a..02ba59d1bbe 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -22,7 +22,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do withConnection e.logg e.rabbitmq $ \conn -> do chan <- liftIO $ Amqp.openChannel conn -- TODO: Don't use the interpreter - qName <- setUpUserNotificationQueuesImpl chan uid cid + qName <- setupConsumableNotificationsImpl chan uid cid let cleanup :: (Exception e, MonadThrow m, MonadIO m) => e -> m () cleanup err = do Log.err e.logg $ Log.msg (Log.val "Pushing to WS failed") . Log.field "error" (displayException err) From a5b1210a38d7be617d62203611ad7db3fd628d57 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 1 Oct 2024 17:18:31 +0200 Subject: [PATCH 22/93] Get galley to compile. --- services/brig/src/Brig/CanonicalInterpreter.hs | 3 +-- services/galley/src/Galley/App.hs | 10 +++++----- services/galley/src/Galley/Env.hs | 2 +- .../src/Galley/Intra/BackendNotificationQueue.hs | 7 ++----- services/galley/src/Galley/Options.hs | 4 ++-- services/galley/test/integration/API.hs | 12 +++--------- 6 files changed, 14 insertions(+), 24 deletions(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 592938ceccd..b547b433666 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -22,8 +22,7 @@ import Control.Monad.Catch (throwM) import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports -import Network.AMQP -import Network.AMQP qualified as Q +import Network.AMQP as Q import Polysemy import Polysemy.Async import Polysemy.Conc diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index cfc7b399285..36c463f854b 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -84,6 +84,7 @@ import Galley.Queue qualified as Q import Galley.Types.Teams import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Imports hiding (forkIO) +import Network.AMQP qualified as AMQP import Network.AMQP.Extended (mkRabbitMqChannelMVar) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL @@ -102,6 +103,7 @@ import Ssl.Util import System.Logger qualified as Log import System.Logger.Class (Logger) import System.Logger.Extended qualified as Logger +import System.Timeout qualified import UnliftIO.Exception qualified as UnliftIO import Wire.API.Conversation.Protocol import Wire.API.Error @@ -118,6 +120,7 @@ import Wire.Sem.Random.IO type GalleyEffects0 = '[ Input ClientState, Input Env, + Input AMQP.Channel, Error InvalidInput, Error InternalError, -- federation errors can be thrown by almost every endpoint, so we avoid @@ -143,10 +146,6 @@ validateOptions o = do error "setMaxConvSize cannot be > setTruncationLimit" when (settings' ^. maxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" - case (o ^. O.federator, o ^. rabbitmq) of - (Nothing, Just _) -> error "RabbitMQ config is specified and federator is not, please specify both or none" - (Just _, Nothing) -> error "Federator is specified and RabbitMQ config is not, please specify both or none" - _ -> pure () let mlsFlag = settings' ^. featureFlags . to (featureDefaults @MLSConfig) mlsConfig = mlsFlag.config migrationStatus = (.status) $ settings' ^. featureFlags . to (featureDefaults @MlsMigrationConfig) @@ -172,7 +171,7 @@ createEnv o l = do <*> initExtEnv <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal) <*> traverse loadAllMLSKeys (o ^. settings . mlsPrivateKeyPaths) - <*> traverse (mkRabbitMqChannelMVar l) (o ^. rabbitmq) + <*> mkRabbitMqChannelMVar l (o ^. rabbitmq) <*> pure codeURIcfg initCassandra :: Opts -> Logger -> IO ClientState @@ -251,6 +250,7 @@ evalGalley e = . mapError toResponse . mapError toResponse . mapError toResponse + . runInputSem (embed $ fromMaybe (error "TODO: no rabbitmq channel in Env") <$> System.Timeout.timeout 1_000_000 (readMVar @IO e._rabbitmqChannel)) . runInputConst e . runInputConst (e ^. cstate) . mapError toResponse -- DynError diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index d5c8bc23c67..8f48cb9f91b 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -62,7 +62,7 @@ data Env = Env _extEnv :: ExtEnv, _aEnv :: Maybe Aws.Env, _mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), - _rabbitmqChannel :: Maybe (MVar Q.Channel), + _rabbitmqChannel :: MVar Q.Channel, _convCodeURI :: Either HttpsUrl (Map Text HttpsUrl) } diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index 756ce2379a6..67ea0073a69 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -41,9 +41,6 @@ interpretBackendNotificationQueueAccess = interpret $ \case logEffect "BackendNotificationQueueAccess.EnqueueNotificationsConcurrentlyBuckets" embedApp . runExceptT $ enqueueNotificationsConcurrentlyBuckets m xs rpc -getChannel :: ExceptT FederationError App (MVar Q.Channel) -getChannel = view rabbitmqChannel >>= maybe (throwE FederationNotConfigured) pure - enqueueSingleNotification :: Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c a -> App a enqueueSingleNotification remoteDomain deliveryMode chanVar action = do ownDomain <- view (options . settings . federationDomain) @@ -71,7 +68,7 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do enqueueNotification :: Q.DeliveryMode -> Domain -> FedQueueClient c a -> ExceptT FederationError App a enqueueNotification deliveryMode remoteDomain action = do - chanVar <- getChannel + chanVar <- view rabbitmqChannel lift $ enqueueSingleNotification remoteDomain deliveryMode chanVar action enqueueNotificationsConcurrently :: @@ -94,7 +91,7 @@ enqueueNotificationsConcurrentlyBuckets m xs f = do -- only attempt to get a channel if there is at least one notification to send [] -> pure [] _ -> do - chanVar <- getChannel + chanVar <- view rabbitmqChannel lift $ pooledForConcurrentlyN 8 (toList xs) $ \r -> qualifyAs r <$> enqueueSingleNotification (tDomain r) m chanVar (f r) diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index a2b233b5e13..d0c3f8f30c6 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -181,8 +181,8 @@ data Opts = Opts _spar :: !Endpoint, -- | Federator endpoint _federator :: !(Maybe Endpoint), - -- | RabbitMQ settings, required when federation is enabled. - _rabbitmq :: !(Maybe AmqpEndpoint), + -- | RabbitMQ settings + _rabbitmq :: !AmqpEndpoint, -- | Disco URL _discoUrl :: !(Maybe Text), -- | Other settings diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 18ce92d9e20..d6ab8d6dcfa 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -67,7 +67,7 @@ import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer import Galley.API.Mapping -import Galley.Options (federator, rabbitmq) +import Galley.Options (federator) import Galley.Types.Conversations.Members import Imports hiding (id) import Imports qualified as I @@ -1902,10 +1902,7 @@ postConvQualifiedFederationNotEnabled = do let domain = Domain "some-remote-backend.example.com" bob <- flip Qualified domain <$> randomId connectWithRemoteUser alice bob - let federatorNotConfigured o = - o - & federator .~ Nothing - & rabbitmq .~ Nothing + let federatorNotConfigured = federator .~ Nothing withSettingsOverrides federatorNotConfigured $ do g <- viewGalley unreachable :: UnreachableBackends <- @@ -2360,10 +2357,7 @@ testAddRemoteMemberFederationDisabled = do -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. - let federatorNotConfigured o = - o - & federator .~ Nothing - & rabbitmq .~ Nothing + let federatorNotConfigured = federator .~ Nothing withSettingsOverrides federatorNotConfigured $ postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 400 === statusCode From 5642a471a943b114436ab64fc2ad94acc03fcd63 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 1 Oct 2024 17:50:29 +0200 Subject: [PATCH 23/93] Fix some easy TODOs. --- services/gundeck/gundeck.cabal | 1 + services/gundeck/src/Gundeck/Push.hs | 40 ++++++++++++++-------------- 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 749732f280d..479b194b76f 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -122,6 +122,7 @@ library , auto-update >=0.1 , base >=4.7 && <5 , bilge >=0.21 + , these , bytestring >=0.9 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 3c270aaac8c..5a64a7aaf42 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -45,6 +45,8 @@ import Data.Map qualified as Map import Data.Range import Data.Set qualified as Set import Data.Text qualified as Text +import Data.These +import Data.These.Combinators import Data.UUID qualified as UUID import Gundeck.Aws (endpointUsers) import Gundeck.Aws qualified as Aws @@ -143,33 +145,31 @@ instance MonadMapAsync Gundeck where Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) -splitPushes = fmap foldMaybeTuple . traverse splitPush +splitPushes = fmap foldThese . traverse splitPush --- TODO: Make it reutrn These -splitPush :: (MonadPushAll m) => Push -> m (Maybe Push, Maybe Push) +splitPush :: (MonadPushAll m) => Push -> m (These Push Push) splitPush p = do let allRecipients = Set.toList $ fromRange $ p._pushRecipients - (rabbitmqRecipients, legacyRecipients) <- foldMaybeTuple <$> traverse splitRecipient allRecipients + (rabbitmqRecipients, legacyRecipients) <- foldThese <$> traverse splitRecipient allRecipients case (rabbitmqRecipients, legacyRecipients) of - ([], _) -> pure (Nothing, Just p) - (_, []) -> pure (Just p, Nothing) + ([], _) -> pure (That p) + (_, []) -> pure (This p) (_ : _, _ : _) -> -- Since we just proved that both the recipient lists are not empty and -- they cannot be bigger than the limit as none of them can be bigger than -- the original recipient set, it is safe to use unsafeRange here. -- -- TODO: See if there is a better way, so we don't have to use unsafeRange - pure - ( Just $ p {_pushRecipients = unsafeRange $ Set.fromList rabbitmqRecipients}, - Just $ p {_pushRecipients = unsafeRange $ Set.fromList legacyRecipients} - ) + pure $ + These + p {_pushRecipients = unsafeRange $ Set.fromList rabbitmqRecipients} + p {_pushRecipients = unsafeRange $ Set.fromList legacyRecipients} -foldMaybeTuple :: [(Maybe a, Maybe b)] -> ([a], [b]) -foldMaybeTuple = foldr (\(x, y) (xs, ys) -> ((maybeToList x <> xs), (maybeToList y <> ys))) ([], []) +foldThese :: [These a b] -> ([a], [b]) +foldThese = foldr (\ab (xs, ys) -> ((maybeToList (justHere ab) <> xs), (maybeToList (justThere ab) <> ys))) ([], []) -- TODO: optimize for possibility of many pushes having the same users --- TODO: Make this return These -splitRecipient :: (MonadPushAll m) => Recipient -> m (Maybe Recipient, Maybe Recipient) +splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) splitRecipient rcpt = do clientsFull <- mpaGetClients rcpt._recipientId let allClients = Map.findWithDefault mempty rcpt._recipientId $ clientsFull.userClientsFull @@ -182,13 +182,13 @@ splitRecipient rcpt = do rabbitmqClientIds = (.clientId) <$> Set.toList rabbitmqClients legacyClientIds = (.clientId) <$> Set.toList legacyClients case (rabbitmqClientIds, legacyClientIds) of - ([], _) -> pure (Nothing, Just rcpt) - (_, []) -> pure (Just rcpt, Nothing) + ([], _) -> pure (That rcpt) + (_, []) -> pure (This rcpt) (r : rs, l : ls) -> - pure - ( Just $ rcpt {_recipientClients = RecipientClientsSome $ list1 r rs}, - Just $ rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} - ) + pure $ + These + rcpt {_recipientClients = RecipientClientsSome $ list1 r rs} + rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} getClients :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => UserId -> m UserClientsFull getClients uid = do From 9d05cf6c4fe98abd55ecc29cd4c502d1a917683d Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 2 Oct 2024 09:33:38 +0200 Subject: [PATCH 24/93] Use these library better. --- services/gundeck/gundeck.cabal | 2 +- services/gundeck/src/Gundeck/Push.hs | 8 ++------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 479b194b76f..17941f54439 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -122,7 +122,6 @@ library , auto-update >=0.1 , base >=4.7 && <5 , bilge >=0.21 - , these , bytestring >=0.9 , bytestring-conversion >=0.2 , cassandra-util >=0.16.2 @@ -155,6 +154,7 @@ library , servant , servant-server , text >=1.1 + , these , time >=1.4 , tinylog >=0.10 , tls >=1.7.0 diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 5a64a7aaf42..4fc97ae0882 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -46,7 +46,6 @@ import Data.Range import Data.Set qualified as Set import Data.Text qualified as Text import Data.These -import Data.These.Combinators import Data.UUID qualified as UUID import Gundeck.Aws (endpointUsers) import Gundeck.Aws qualified as Aws @@ -145,12 +144,12 @@ instance MonadMapAsync Gundeck where Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) -splitPushes = fmap foldThese . traverse splitPush +splitPushes = fmap partitionHereThere . traverse splitPush splitPush :: (MonadPushAll m) => Push -> m (These Push Push) splitPush p = do let allRecipients = Set.toList $ fromRange $ p._pushRecipients - (rabbitmqRecipients, legacyRecipients) <- foldThese <$> traverse splitRecipient allRecipients + (rabbitmqRecipients, legacyRecipients) <- partitionHereThere <$> traverse splitRecipient allRecipients case (rabbitmqRecipients, legacyRecipients) of ([], _) -> pure (That p) (_, []) -> pure (This p) @@ -165,9 +164,6 @@ splitPush p = do p {_pushRecipients = unsafeRange $ Set.fromList rabbitmqRecipients} p {_pushRecipients = unsafeRange $ Set.fromList legacyRecipients} -foldThese :: [These a b] -> ([a], [b]) -foldThese = foldr (\ab (xs, ys) -> ((maybeToList (justHere ab) <> xs), (maybeToList (justThere ab) <> ys))) ([], []) - -- TODO: optimize for possibility of many pushes having the same users splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) splitRecipient rcpt = do From f47dfd89c3bc430bbc9b955891862fb1219f966e Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 2 Oct 2024 09:33:48 +0200 Subject: [PATCH 25/93] resolve rebase conflict better. --- services/gundeck/src/Gundeck/Run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index b91a030b6e4..234fe6c529c 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -122,7 +122,7 @@ run opts = withTracer \tracer -> do versionMiddleware (foldMap expandVersionExp (opts ^. settings . disabledAPIVersions)) . otelMiddleWare . requestIdMiddleware (env ^. applog) defaultRequestIdHeaderName - . Metrics.servantPrometheusMiddleware (Proxy @(GundeckAPI :<|> GundeckInternalAPI)) + . Metrics.servantPrometheusMiddleware (Proxy @(GundeckAPI :<|> InternalAPI)) . GZip.gunzip . GZip.gzip GZip.def . catchErrors (env ^. applog) defaultRequestIdHeaderName From a0239ab1bdc2e8c671f206c579c213e2c3ac5ed4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 2 Oct 2024 09:43:33 +0200 Subject: [PATCH 26/93] fix ghc errors. --- services/brig/src/Brig/API/Internal.hs | 4 +--- services/brig/src/Brig/API/Public.hs | 5 +---- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index d4f1d29391a..3685605c7ce 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -144,9 +144,7 @@ servantSitemap :: Member PropertySubsystem r, Member (Input (Local ())) r, Member IndexedUserStore r, - Member (Polysemy.Error.Error UserSubsystemError) r, - Member (Input TeamTemplates) r, - Member (Input Channel) r + Member (Polysemy.Error.Error UserSubsystemError) r ) => ServerT BrigIRoutes.API (Handler r) servantSitemap = diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 1ee6814bb99..16d872de9e5 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -86,7 +86,6 @@ import Data.Time.Clock import Data.ZAuth.Token qualified as ZAuth import FileEmbedLzma import Imports hiding (head) -import Network.AMQP import Network.Socket (PortNumber) import Network.Wai.Utilities (CacheControl (..), (!>>)) import Network.Wai.Utilities qualified as Utilities @@ -303,10 +302,8 @@ servantSitemap :: Member VerificationCodeSubsystem r, Member (Concurrency 'Unsafe) r, Member BlockListStore r, - Member (ConnectionStore InternalPaging) r, Member IndexedUserStore r, - Member (ConnectionStore InternalPaging) r, - Member (Input Channel) r + Member (ConnectionStore InternalPaging) r ) => ServerT BrigAPI (Handler r) servantSitemap = From c1bf85d8c2ea737e32df3be185e98d8b6161a811 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 2 Oct 2024 10:21:07 +0200 Subject: [PATCH 27/93] Extract rabbitmq channel lookup into helper. --- services/gundeck/src/Gundeck/Monad.hs | 38 +++++++++++++++++---------- services/gundeck/src/Gundeck/Push.hs | 2 +- services/gundeck/src/Gundeck/Run.hs | 21 ++++++--------- 3 files changed, 33 insertions(+), 28 deletions(-) diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 1ccce16a55b..85a973c5764 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -33,6 +33,7 @@ module Gundeck.Monad runGundeck, fromJsonBody, posixTime, + getRabbitMqChan, -- * Select which redis to target runWithDefaultRedis, @@ -56,13 +57,15 @@ import Database.Redis qualified as Redis import Gundeck.Env import Gundeck.Redis qualified as Redis import Imports +import Network.AMQP import Network.HTTP.Types import Network.Wai import Network.Wai.Utilities import Prometheus -import System.Logger qualified as Log +import System.Logger (Logger) import System.Logger qualified as Logger -import System.Logger.Class +import System.Logger.Class qualified as Log +import System.Timeout import UnliftIO (async) -- | TODO: 'Client' already has an 'Env'. Why do we need two? How does this even work? We should @@ -104,7 +107,7 @@ newtype WithDefaultRedis a = WithDefaultRedis {runWithDefaultRedis :: Gundeck a} MonadReader Env, MonadClient, MonadUnliftIO, - MonadLogger + Log.MonadLogger ) instance Redis.MonadRedis WithDefaultRedis where @@ -133,7 +136,7 @@ newtype WithAdditionalRedis a = WithAdditionalRedis {runWithAdditionalRedis :: G MonadReader Env, MonadClient, MonadUnliftIO, - MonadLogger + Log.MonadLogger ) instance Redis.MonadRedis WithAdditionalRedis where @@ -153,7 +156,7 @@ instance Redis.RedisCtx WithAdditionalRedis (Either Redis.Reply) where returnDecode :: (Redis.RedisResult a) => Redis.Reply -> WithAdditionalRedis (Either Redis.Reply a) returnDecode = Redis.liftRedis . Redis.returnDecode -instance MonadLogger Gundeck where +instance Log.MonadLogger Gundeck where log l m = do e <- ask Logger.log (e ^. applog) l (reqIdMsg (e ^. reqId) . m) @@ -178,7 +181,7 @@ runDirect e m = `catch` ( \(exception :: SomeException) -> do case fromException exception of Nothing -> - Log.err (e ^. applog) $ + Logger.err (e ^. applog) $ Log.msg ("IO Exception occurred" :: ByteString) . Log.field "message" (displayException exception) . Log.field "request" (unRequestId (e ^. reqId)) @@ -191,14 +194,11 @@ lookupReqId l r = case lookup requestIdName (requestHeaders r) of Just rid -> pure $ RequestId rid Nothing -> do localRid <- RequestId . UUID.toASCIIBytes <$> UUID.nextRandom - Log.info l $ - "request-id" - .= localRid - ~~ "method" - .= requestMethod r - ~~ "path" - .= rawPathInfo r - ~~ msg (val "generated a new request id for local request") + Logger.info l $ + Log.field "request-id" localRid + . Log.field "method" (requestMethod r) + . Log.field "path" (rawPathInfo r) + . Log.msg (Log.val "generated a new request id for local request") pure localRid fromJsonBody :: (FromJSON a) => JsonRequest a -> Gundeck a @@ -208,3 +208,13 @@ fromJsonBody r = exceptT (throwM . mkError status400 "bad-request") pure (parseB posixTime :: Gundeck Milliseconds posixTime = view time >>= liftIO {-# INLINE posixTime #-} + +getRabbitMqChan :: Gundeck Channel +getRabbitMqChan = do + chanMVar <- view rabbitMqChannel + mChan <- liftIO $ System.Timeout.timeout 1_000_000 $ readMVar chanMVar + case mChan of + Nothing -> do + Log.err $ Log.msg (Log.val "Could not retrieve RabbitMQ channel") + throwM . mkError status500 "internal-server-error" + Just chan -> pure chan diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 4fc97ae0882..01a1d4194ef 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -112,7 +112,7 @@ instance MonadPushAll Gundeck where publishToRabbitMq :: Text -> Q.Message -> Gundeck () publishToRabbitMq routingKey qMsg = do - chan <- readMVar =<< view rabbitMqChannel + chan <- getRabbitMqChan void $ liftIO $ Q.publishMsg chan userNotificationExchangeName routingKey qMsg -- | Another layer of wrap around 'runWithBudget'. diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index 234fe6c529c..a580986722c 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -54,7 +54,7 @@ import OpenTelemetry.Trace qualified as Otel import Servant (Handler (Handler), (:<|>) (..)) import Servant qualified import System.Logger qualified as Log -import System.Timeout (timeout) +import System.Logger.Class qualified as MonadLogger import UnliftIO.Async qualified as Async import Util.Options import Wire.API.Notification @@ -68,7 +68,7 @@ run opts = withTracer \tracer -> do (rThreads, env) <- createEnv opts let logger = env ^. applog - setUpRabbitMqExchangesAndQueues logger (env ^. rabbitMqChannel) + runDirect env setUpRabbitMqExchangesAndQueues runClient (env ^. cstate) $ versionCheck lastSchemaVersion @@ -91,17 +91,12 @@ run opts = withTracer \tracer -> do whenJust (env ^. rstateAdditionalWrite) $ (=<<) Redis.disconnect . takeMVar Log.close (env ^. applog) where - setUpRabbitMqExchangesAndQueues :: Log.Logger -> MVar Channel -> IO () - setUpRabbitMqExchangesAndQueues logger chanMVar = do - mChan <- timeout 1_000_000 $ readMVar chanMVar - case mChan of - Nothing -> do - -- TODO(leif): we should probably fail here - Log.err logger $ Log.msg (Log.val "RabbitMQ could not connect") - Just chan -> do - Log.info logger $ Log.msg (Log.val "setting up RabbitMQ exchanges and queues") - createUserNotificationsExchange chan - createDeadUserNotificationsExchange chan + setUpRabbitMqExchangesAndQueues :: Gundeck () + setUpRabbitMqExchangesAndQueues = do + chan <- getRabbitMqChan + MonadLogger.info $ Log.msg (Log.val "setting up RabbitMQ exchanges and queues") + liftIO $ createUserNotificationsExchange chan + liftIO $ createDeadUserNotificationsExchange chan createUserNotificationsExchange :: Channel -> IO () createUserNotificationsExchange chan = do From 2f78dce74b6d245e899b92fef0af82d97a69ed82 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 2 Oct 2024 10:35:19 +0200 Subject: [PATCH 28/93] Move setupConsumableNotificationsClient from subsystems to gundeck. --- .../src/Wire/API/Routes/Internal/Gundeck.hs | 1 + .../src/Wire/GundeckAPIAccess.hs | 6 +++ .../Wire/NotificationSubsystem/Interpreter.hs | 38 +------------------ services/gundeck/src/Gundeck/API/Internal.hs | 8 ++++ services/gundeck/src/Gundeck/Client.hs | 35 ++++++++++++++--- services/gundeck/src/Gundeck/Monad.hs | 2 +- services/gundeck/src/Gundeck/Push.hs | 2 +- 7 files changed, 49 insertions(+), 43 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Gundeck.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Gundeck.hs index 9287611a5e9..e9f93a5fe63 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Gundeck.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Gundeck.hs @@ -94,6 +94,7 @@ type InternalAPI = :<|> (ZUser :> "clients" :> Capture "cid" ClientId :> Delete '[JSON] NoContent) :<|> (ZUser :> "user" :> Delete '[JSON] NoContent) :<|> ("push-tokens" :> Capture "uid" UserId :> Get '[JSON] PushTokenList) + :<|> ("users" :> Capture "uid" UserId :> "clients" :> Capture "cid" ClientId :> "consumable-notifications" :> PostNoContent) ) swaggerDoc :: S.OpenApi diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs index c153cf22364..807b26ef391 100644 --- a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -17,6 +17,7 @@ data GundeckAPIAccess m a where UserDeleted :: UserId -> GundeckAPIAccess m () UnregisterPushClient :: UserId -> ClientId -> GundeckAPIAccess m () GetPushTokens :: UserId -> GundeckAPIAccess m [V2.PushToken] + RegisterConsumableNotifcationsClient :: UserId -> ClientId -> GundeckAPIAccess m () makeSem ''GundeckAPIAccess @@ -50,3 +51,8 @@ runGundeckAPIAccess ep = interpret $ \case . zUser uid . expect2xx responseJsonMaybe rsp & maybe (pure []) (pure . V2.pushTokens) + RegisterConsumableNotifcationsClient uid cid -> do + void . rpcWithRetries "gundeck" ep $ + method POST + . paths ["i", "users", toByteString' uid, "clients", toByteString' cid, "consumable-notifications"] + . expect2xx diff --git a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs index 50ac0c9530b..89d80fcb70c 100644 --- a/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/NotificationSubsystem/Interpreter.hs @@ -4,19 +4,14 @@ import Bilge (RequestId) import Control.Concurrent.Async (Async) import Control.Lens (set, (.~)) import Data.Aeson -import Data.Id (ClientId, UserId, clientToText, idToText) import Data.List.NonEmpty (nonEmpty) import Data.List1 (List1) import Data.List1 qualified as List1 -import Data.Map qualified as Map import Data.Proxy import Data.Range import Data.Set qualified as Set -import Data.Text.Encoding import Data.Time.Clock.DiffTime import Imports -import Network.AMQP -import Network.AMQP.Types (FieldTable (FieldTable), FieldValue (FVString)) import Numeric.Natural (Natural) import Polysemy import Polysemy.Async (async, sequenceConcurrently) @@ -25,7 +20,6 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P import System.Logger.Class as Log -import Wire.API.Notification (userNotificationDlqName, userNotificationDlxName, userNotificationExchangeName) import Wire.API.Push.V2 hiding (Push (..), Recipient, newPush) import Wire.API.Push.V2 qualified as V2 import Wire.API.Team.Member @@ -40,9 +34,7 @@ runNotificationSubsystemGundeck :: Member P.Async r, Member Delay r, Member (Final IO) r, - Member P.TinyLog r, - Member (Embed IO) r, - Member (Input Channel) r + Member P.TinyLog r ) => NotificationSubsystemConfig -> Sem (NotificationSubsystem : r) a -> @@ -54,9 +46,7 @@ runNotificationSubsystemGundeck cfg = interpret $ \case CleanupUser uid -> GundeckAPIAccess.userDeleted uid UnregisterPushClient uid cid -> GundeckAPIAccess.unregisterPushClient uid cid GetPushTokens uid -> GundeckAPIAccess.getPushTokens uid - SetupConsumableNotifications uid cid -> do - chan <- input - void $ liftIO $ setupConsumableNotificationsImpl chan uid cid + SetupConsumableNotifications uid cid -> GundeckAPIAccess.registerConsumableNotifcationsClient uid cid data NotificationSubsystemConfig = NotificationSubsystemConfig { fanoutLimit :: Range 1 HardTruncationLimit Int32, @@ -179,27 +169,3 @@ pushSlowlyImpl ps = for_ ps \p -> do delay =<< inputs (diffTimeToFullMicroseconds . slowPushDelay) pushImpl [p] - -setupConsumableNotificationsImpl :: - Channel -> - UserId -> - ClientId -> - IO Text -setupConsumableNotificationsImpl chan uid cid = do - let qName = "user-notifications." <> idToText uid <> "." <> clientToText cid - -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies - let headers = - FieldTable $ - Map.fromList - [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), - ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) - ] - void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} - for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName - pure qName - -userRoutingKey :: UserId -> Text -userRoutingKey = idToText - -clientRoutingKey :: UserId -> ClientId -> Text -clientRoutingKey uid cid = idToText uid <> "." <> clientToText cid diff --git a/services/gundeck/src/Gundeck/API/Internal.hs b/services/gundeck/src/Gundeck/API/Internal.hs index 58a1043cd4b..58b8d48a0cf 100644 --- a/services/gundeck/src/Gundeck/API/Internal.hs +++ b/services/gundeck/src/Gundeck/API/Internal.hs @@ -24,6 +24,7 @@ where import Cassandra qualified import Control.Lens (view) import Data.Id +import Gundeck.Client import Gundeck.Client qualified as Client import Gundeck.Monad import Gundeck.Presence qualified as Presence @@ -48,6 +49,7 @@ servantSitemap = :<|> unregisterClientH :<|> removeUserH :<|> getPushTokensH + :<|> registerConsumableNotifcationsClient statusH :: (Applicative m) => m NoContent statusH = pure NoContent @@ -63,3 +65,9 @@ removeUserH uid = NoContent <$ Client.removeUser uid getPushTokensH :: UserId -> Gundeck PushTok.PushTokenList getPushTokensH uid = PushTok.PushTokenList <$> (view PushTok.addrPushToken <$$> PushTok.lookup uid Cassandra.All) + +registerConsumableNotifcationsClient :: UserId -> ClientId -> Gundeck NoContent +registerConsumableNotifcationsClient uid cid = do + chan <- getRabbitMqChan + void . liftIO $ setupConsumableNotifications chan uid cid + pure NoContent diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index 43323ade9cc..d89f8f3759d 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -15,19 +15,20 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Gundeck.Client - ( unregister, - removeUser, - ) -where +module Gundeck.Client where import Control.Lens (view) import Data.Id +import Data.Map qualified as Map +import Data.Text.Encoding (encodeUtf8) import Gundeck.Monad import Gundeck.Notification.Data qualified as Notifications import Gundeck.Push.Data qualified as Push import Gundeck.Push.Native import Imports +import Network.AMQP +import Network.AMQP.Types +import Wire.API.Notification unregister :: UserId -> ClientId -> Gundeck () unregister uid cid = do @@ -42,3 +43,27 @@ removeUser user = do deleteTokens toks Nothing Push.erase user Notifications.deleteAll user + +setupConsumableNotifications :: + Channel -> + UserId -> + ClientId -> + IO Text +setupConsumableNotifications chan uid cid = do + let qName = "user-notifications." <> idToText uid <> "." <> clientToText cid + -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies + let headers = + FieldTable $ + Map.fromList + [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), + ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) + ] + void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} + for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName + pure qName + +userRoutingKey :: UserId -> Text +userRoutingKey = idToText + +clientRoutingKey :: UserId -> ClientId -> Text +clientRoutingKey uid cid = idToText uid <> "." <> clientToText cid diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 85a973c5764..92b93c8c3c4 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -216,5 +216,5 @@ getRabbitMqChan = do case mChan of Nothing -> do Log.err $ Log.msg (Log.val "Could not retrieve RabbitMQ channel") - throwM . mkError status500 "internal-server-error" + throwM $ mkError status500 "internal-server-error" "Could not retrieve RabbitMQ channel" Just chan -> pure chan diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 01a1d4194ef..f32881e9ed0 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -50,6 +50,7 @@ import Data.UUID qualified as UUID import Gundeck.Aws (endpointUsers) import Gundeck.Aws qualified as Aws import Gundeck.Aws.Arn +import Gundeck.Client import Gundeck.Env import Gundeck.Monad import Gundeck.Notification.Data qualified as Data @@ -77,7 +78,6 @@ import Wire.API.Push.Token qualified as Public import Wire.API.Push.V2 import Wire.API.User (UserSet (..)) import Wire.API.User.Client (Client (..), ClientCapability (..), ClientCapabilityList (..), UserClientsFull (..)) -import Wire.NotificationSubsystem.Interpreter push :: [Push] -> Gundeck () push ps = do From 460ecd62e917eac9d2d1b2d34b8e02b25134ceea Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 10:46:09 +0200 Subject: [PATCH 29/93] Revert "Get galley to compile." This reverts commit 8a1840d6092982e7c527ead11f276e3c22fa7030. --- services/brig/src/Brig/CanonicalInterpreter.hs | 3 ++- services/galley/src/Galley/App.hs | 10 +++++----- services/galley/src/Galley/Env.hs | 2 +- .../src/Galley/Intra/BackendNotificationQueue.hs | 7 +++++-- services/galley/src/Galley/Options.hs | 4 ++-- services/galley/test/integration/API.hs | 12 +++++++++--- 6 files changed, 24 insertions(+), 14 deletions(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index b547b433666..592938ceccd 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -22,7 +22,8 @@ import Control.Monad.Catch (throwM) import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports -import Network.AMQP as Q +import Network.AMQP +import Network.AMQP qualified as Q import Polysemy import Polysemy.Async import Polysemy.Conc diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 36c463f854b..cfc7b399285 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -84,7 +84,6 @@ import Galley.Queue qualified as Q import Galley.Types.Teams import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Imports hiding (forkIO) -import Network.AMQP qualified as AMQP import Network.AMQP.Extended (mkRabbitMqChannelMVar) import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL @@ -103,7 +102,6 @@ import Ssl.Util import System.Logger qualified as Log import System.Logger.Class (Logger) import System.Logger.Extended qualified as Logger -import System.Timeout qualified import UnliftIO.Exception qualified as UnliftIO import Wire.API.Conversation.Protocol import Wire.API.Error @@ -120,7 +118,6 @@ import Wire.Sem.Random.IO type GalleyEffects0 = '[ Input ClientState, Input Env, - Input AMQP.Channel, Error InvalidInput, Error InternalError, -- federation errors can be thrown by almost every endpoint, so we avoid @@ -146,6 +143,10 @@ validateOptions o = do error "setMaxConvSize cannot be > setTruncationLimit" when (settings' ^. maxTeamSize < optFanoutLimit) $ error "setMaxTeamSize cannot be < setTruncationLimit" + case (o ^. O.federator, o ^. rabbitmq) of + (Nothing, Just _) -> error "RabbitMQ config is specified and federator is not, please specify both or none" + (Just _, Nothing) -> error "Federator is specified and RabbitMQ config is not, please specify both or none" + _ -> pure () let mlsFlag = settings' ^. featureFlags . to (featureDefaults @MLSConfig) mlsConfig = mlsFlag.config migrationStatus = (.status) $ settings' ^. featureFlags . to (featureDefaults @MlsMigrationConfig) @@ -171,7 +172,7 @@ createEnv o l = do <*> initExtEnv <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. journal) <*> traverse loadAllMLSKeys (o ^. settings . mlsPrivateKeyPaths) - <*> mkRabbitMqChannelMVar l (o ^. rabbitmq) + <*> traverse (mkRabbitMqChannelMVar l) (o ^. rabbitmq) <*> pure codeURIcfg initCassandra :: Opts -> Logger -> IO ClientState @@ -250,7 +251,6 @@ evalGalley e = . mapError toResponse . mapError toResponse . mapError toResponse - . runInputSem (embed $ fromMaybe (error "TODO: no rabbitmq channel in Env") <$> System.Timeout.timeout 1_000_000 (readMVar @IO e._rabbitmqChannel)) . runInputConst e . runInputConst (e ^. cstate) . mapError toResponse -- DynError diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index 8f48cb9f91b..d5c8bc23c67 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -62,7 +62,7 @@ data Env = Env _extEnv :: ExtEnv, _aEnv :: Maybe Aws.Env, _mlsKeys :: Maybe (MLSKeysByPurpose MLSPrivateKeys), - _rabbitmqChannel :: MVar Q.Channel, + _rabbitmqChannel :: Maybe (MVar Q.Channel), _convCodeURI :: Either HttpsUrl (Map Text HttpsUrl) } diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index 67ea0073a69..756ce2379a6 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -41,6 +41,9 @@ interpretBackendNotificationQueueAccess = interpret $ \case logEffect "BackendNotificationQueueAccess.EnqueueNotificationsConcurrentlyBuckets" embedApp . runExceptT $ enqueueNotificationsConcurrentlyBuckets m xs rpc +getChannel :: ExceptT FederationError App (MVar Q.Channel) +getChannel = view rabbitmqChannel >>= maybe (throwE FederationNotConfigured) pure + enqueueSingleNotification :: Domain -> Q.DeliveryMode -> MVar Q.Channel -> FedQueueClient c a -> App a enqueueSingleNotification remoteDomain deliveryMode chanVar action = do ownDomain <- view (options . settings . federationDomain) @@ -68,7 +71,7 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do enqueueNotification :: Q.DeliveryMode -> Domain -> FedQueueClient c a -> ExceptT FederationError App a enqueueNotification deliveryMode remoteDomain action = do - chanVar <- view rabbitmqChannel + chanVar <- getChannel lift $ enqueueSingleNotification remoteDomain deliveryMode chanVar action enqueueNotificationsConcurrently :: @@ -91,7 +94,7 @@ enqueueNotificationsConcurrentlyBuckets m xs f = do -- only attempt to get a channel if there is at least one notification to send [] -> pure [] _ -> do - chanVar <- view rabbitmqChannel + chanVar <- getChannel lift $ pooledForConcurrentlyN 8 (toList xs) $ \r -> qualifyAs r <$> enqueueSingleNotification (tDomain r) m chanVar (f r) diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index d0c3f8f30c6..a2b233b5e13 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -181,8 +181,8 @@ data Opts = Opts _spar :: !Endpoint, -- | Federator endpoint _federator :: !(Maybe Endpoint), - -- | RabbitMQ settings - _rabbitmq :: !AmqpEndpoint, + -- | RabbitMQ settings, required when federation is enabled. + _rabbitmq :: !(Maybe AmqpEndpoint), -- | Disco URL _discoUrl :: !(Maybe Text), -- | Other settings diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index d6ab8d6dcfa..18ce92d9e20 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -67,7 +67,7 @@ import Data.Time.Clock (getCurrentTime) import Federator.Discovery (DiscoveryFailure (..)) import Federator.MockServer import Galley.API.Mapping -import Galley.Options (federator) +import Galley.Options (federator, rabbitmq) import Galley.Types.Conversations.Members import Imports hiding (id) import Imports qualified as I @@ -1902,7 +1902,10 @@ postConvQualifiedFederationNotEnabled = do let domain = Domain "some-remote-backend.example.com" bob <- flip Qualified domain <$> randomId connectWithRemoteUser alice bob - let federatorNotConfigured = federator .~ Nothing + let federatorNotConfigured o = + o + & federator .~ Nothing + & rabbitmq .~ Nothing withSettingsOverrides federatorNotConfigured $ do g <- viewGalley unreachable :: UnreachableBackends <- @@ -2357,7 +2360,10 @@ testAddRemoteMemberFederationDisabled = do -- federator endpoint not configured is equivalent to federation being disabled -- This is the case on staging/production in May 2021. - let federatorNotConfigured = federator .~ Nothing + let federatorNotConfigured o = + o + & federator .~ Nothing + & rabbitmq .~ Nothing withSettingsOverrides federatorNotConfigured $ postQualifiedMembers alice (remoteBob :| []) qconvId !!! do const 400 === statusCode From 818a77c0285c9295672fe41735ce1f2808026df7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 11:07:46 +0200 Subject: [PATCH 30/93] wire-subsystems: Fix compile errors in tests --- .../src/Wire/GundeckAPIAccess.hs | 2 + .../NotificationSubsystem/InterpreterSpec.hs | 39 ++++++++++--------- 2 files changed, 23 insertions(+), 18 deletions(-) diff --git a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs index 807b26ef391..e402416a21b 100644 --- a/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GundeckAPIAccess.hs @@ -19,6 +19,8 @@ data GundeckAPIAccess m a where GetPushTokens :: UserId -> GundeckAPIAccess m [V2.PushToken] RegisterConsumableNotifcationsClient :: UserId -> ClientId -> GundeckAPIAccess m () +deriving instance Show (GundeckAPIAccess m a) + makeSem ''GundeckAPIAccess runGundeckAPIAccess :: (Member Rpc r, Member (Embed IO) r) => Endpoint -> Sem (GundeckAPIAccess : r) a -> Sem r a diff --git a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs index 9fbd3babe89..aae5e6710cc 100644 --- a/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/NotificationSubsystem/InterpreterSpec.hs @@ -307,37 +307,40 @@ runMiniStackWithControlledDelay mockConfig delayControl actualPushesRef = do . runControlledDelay delayControl . runInputConst mockConfig -runGundeckAPIAccessFailure :: (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessFailure :: forall r a. (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a runGundeckAPIAccessFailure pushesRef = interpret $ \action -> do + let unexpectedCall :: forall x. Sem r x + unexpectedCall = do + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: " <> show action + error "impossible" case action of PushV2 pushes -> liftIO $ do modifyIORef pushesRef (<> [pushes]) throwIO TestException - GundeckAPIAccess.UserDeleted uid -> - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UserDeleted " <> show uid - GundeckAPIAccess.UnregisterPushClient uid cid -> - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UnregisterPushClient " <> show uid <> " " <> show cid - GundeckAPIAccess.GetPushTokens uid -> do - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: GetPushTokens " <> show uid - error "impossible" + GundeckAPIAccess.UserDeleted {} -> unexpectedCall + GundeckAPIAccess.UnregisterPushClient {} -> unexpectedCall + GundeckAPIAccess.GetPushTokens {} -> unexpectedCall + GundeckAPIAccess.RegisterConsumableNotifcationsClient {} -> unexpectedCall data TestException = TestException deriving (Show) instance Exception TestException -runGundeckAPIAccessIORef :: (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a +runGundeckAPIAccessIORef :: forall r a. (Member (Embed IO) r) => IORef [[V2.Push]] -> Sem (GundeckAPIAccess : r) a -> Sem r a runGundeckAPIAccessIORef pushesRef = - interpret \case - PushV2 pushes -> modifyIORef pushesRef (<> [pushes]) - GundeckAPIAccess.UserDeleted uid -> - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UserDeleted " <> show uid - GundeckAPIAccess.UnregisterPushClient uid cid -> - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: UnregisterPushClient " <> show uid <> " " <> show cid - GundeckAPIAccess.GetPushTokens uid -> do - liftIO $ expectationFailure $ "Unexpected call to GundeckAPI: GetPushTokens " <> show uid - error "impossible" + interpret \action -> do + let unexpectedCall :: forall x. Sem r x + unexpectedCall = do + liftIO $ expectationFailure $ "Unexpected call to GundeckAPI " <> show action + error "impossible" + case action of + PushV2 pushes -> modifyIORef pushesRef (<> [pushes]) + GundeckAPIAccess.UserDeleted {} -> unexpectedCall + GundeckAPIAccess.UnregisterPushClient {} -> unexpectedCall + GundeckAPIAccess.GetPushTokens {} -> unexpectedCall + GundeckAPIAccess.RegisterConsumableNotifcationsClient {} -> unexpectedCall waitUntilPushes :: IORef [a] -> Int -> IO [a] waitUntilPushes pushesRef n = do From e64cdc25b8f1e7145a81414897a6b2e872dc217b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 11:11:11 +0200 Subject: [PATCH 31/93] gundeck: doesn't depend on wire-subsystems (yet?) --- services/gundeck/gundeck.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 17941f54439..974d8f63845 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -169,7 +169,6 @@ library , wai-utilities >=0.16 , wire-api , wire-otel - , wire-subsystems , yaml >=0.8 default-language: GHC2021 From 670769b9fb6a4bb02747690a66e1585a7a79861d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 11:11:31 +0200 Subject: [PATCH 32/93] brig: Remove unnecessary import --- services/brig/src/Brig/CanonicalInterpreter.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index 592938ceccd..d9d44c3bcdc 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -23,7 +23,6 @@ import Data.Qualified (Local, toLocalUnsafe) import Data.Time.Clock (UTCTime, getCurrentTime) import Imports import Network.AMQP -import Network.AMQP qualified as Q import Polysemy import Polysemy.Async import Polysemy.Conc From 47190ff40ed1041008ea72e5fee4b8337cca3c0a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 11:51:01 +0200 Subject: [PATCH 33/93] cannon: Don't create the queue for clients, expect it to already be there --- libs/wire-api/src/Wire/API/Notification.hs | 5 +++++ services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 6 +++--- services/gundeck/src/Gundeck/Client.hs | 4 ++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index 5e679899dba..d4c0e9fefd0 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -38,6 +38,7 @@ module Wire.API.Notification userNotificationExchangeName, userNotificationDlxName, userNotificationDlqName, + clientNotificationQueueName, ) where @@ -184,3 +185,7 @@ userNotificationDlxName = "dead-user-notifications" -- | The name of the RabbitMQ queue for dead-lettered user notifications. userNotificationDlqName :: Text userNotificationDlqName = "dead-user-notifications" + +clientNotificationQueueName :: UserId -> ClientId -> Text +clientNotificationQueueName uid cid = + "user-notifications." <> idToText uid <> "." <> clientToText cid diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 02ba59d1bbe..a9475bbc879 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -14,20 +14,20 @@ import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log import UnliftIO (catches) -import Wire.NotificationSubsystem.Interpreter +import Wire.API.Notification rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) + -- TODO: Don't create new conns for every client, this will definitely kill rabbit withConnection e.logg e.rabbitmq $ \conn -> do chan <- liftIO $ Amqp.openChannel conn - -- TODO: Don't use the interpreter - qName <- setupConsumableNotificationsImpl chan uid cid let cleanup :: (Exception e, MonadThrow m, MonadIO m) => e -> m () cleanup err = do Log.err e.logg $ Log.msg (Log.val "Pushing to WS failed") . Log.field "error" (displayException err) throwM err handlers = [Handler $ cleanup @SomeException, Handler $ cleanup @SomeAsyncException] + qName = clientNotificationQueueName uid cid _consumerTag <- AmqpL.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) forever $ do diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index d89f8f3759d..5a779b84968 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -50,9 +50,9 @@ setupConsumableNotifications :: ClientId -> IO Text setupConsumableNotifications chan uid cid = do - let qName = "user-notifications." <> idToText uid <> "." <> clientToText cid -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies - let headers = + let qName = clientNotificationQueueName uid cid + headers = FieldTable $ Map.fromList [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), From d059fb9ce6aaacff91997ac126110146554223e2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 14:18:27 +0200 Subject: [PATCH 34/93] cannon: close ws connection when something goes wrong --- services/cannon/cannon.cabal | 1 - .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 59 +++++++++++++------ 2 files changed, 42 insertions(+), 18 deletions(-) diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index f8f9ea0cb87..8e3988ec1a8 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -120,7 +120,6 @@ library , websockets >=0.11.2 , wire-api , wire-otel - , wire-subsystems default-language: GHC2021 diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index a9475bbc879..5f22fd7ef50 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -2,46 +2,71 @@ module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) import Cannon.WS -import Control.Exception (catch) -import Control.Monad.Catch (Handler (..), MonadThrow, throwM) +import Control.Concurrent.Async (race) +import Control.Exception (Handler (..), catch, catches, throwIO) import Data.Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp import Network.AMQP.Extended (withConnection) -import Network.AMQP.Lifted qualified as AmqpL import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log -import UnliftIO (catches) import Wire.API.Notification rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) + closeWS <- newEmptyMVar -- TODO: Don't create new conns for every client, this will definitely kill rabbit withConnection e.logg e.rabbitmq $ \conn -> do - chan <- liftIO $ Amqp.openChannel conn - let cleanup :: (Exception e, MonadThrow m, MonadIO m) => e -> m () - cleanup err = do - Log.err e.logg $ Log.msg (Log.val "Pushing to WS failed") . Log.field "error" (displayException err) - throwM err - handlers = [Handler $ cleanup @SomeException, Handler $ cleanup @SomeAsyncException] + chan <- Amqp.openChannel conn + let handleConsumerError :: (Exception e) => e -> IO () + handleConsumerError err = do + Log.err e.logg $ + Log.msg (Log.val "Pushing to WS failed, closing connection") + . Log.field "error" (displayException err) + . Log.field "user" (idToText uid) + . Log.field "client" (clientToText cid) + _ <- tryPutMVar closeWS () + throwIO err + handlers = + [ Handler $ handleConsumerError @SomeException, + Handler $ handleConsumerError @SomeAsyncException + ] qName = clientNotificationQueueName uid cid + _consumerTag <- - AmqpL.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) - forever $ do - eitherMsg :: Either String ClientMessage <- eitherDecode <$> WS.receiveData wsConn - case eitherMsg of - Left err -> error err - Right msg -> do - void $ Amqp.ackMsg chan msg.ack False + Amqp.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) + + let wsRecieverLoop = do + eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) + case eitherData of + Left () -> do + Log.info e.logg $ + Log.msg (Log.val "gracefully closing websocket") + . Log.field "user" (idToText uid) + . Log.field "client" (clientToText cid) + WS.sendClose wsConn ("goaway" :: ByteString) + Right dat -> case eitherDecode @ClientMessage dat of + Left err -> do + WS.sendClose wsConn ("invalid-message" :: ByteString) + throwIO $ FailedToParseClientMesage err + Right msg -> do + void $ Amqp.ackMsg chan msg.ack False + wsRecieverLoop + wsRecieverLoop data ClientMessage = ClientMessage {ack :: Word64} instance FromJSON ClientMessage where parseJSON = withObject "ClientMessage" $ \o -> ClientMessage <$> o .: "ack" +data WebSockerServerError = FailedToParseClientMesage String + deriving (Show) + +instance Exception WebSockerServerError + pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () pushEventsToWS wsConn (msg, envelope) = case eitherDecode @Value msg.msgBody of From db306e84d264233111cb800e26532d2baae34eff Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 16:48:44 +0200 Subject: [PATCH 35/93] Funky! --- libs/wire-api/src/Wire/API/WebSocket.hs | 156 ++++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 libs/wire-api/src/Wire/API/WebSocket.hs diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs new file mode 100644 index 00000000000..c5a059a90bb --- /dev/null +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- TODO: Rename this module to something that is more specific than "websocket" +module Wire.API.WebSocket where + +import Control.Lens (makePrisms) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A +import Data.Schema +import Data.Word +import Imports +import Network.WebSockets + +data AckData = AckData + { deliveryTag :: Word64, + -- | Acknowledge all deliveryTags <= 'deliveryTag', see RabbitMQ + -- documenation: + -- https://www.rabbitmq.com/docs/confirms#consumer-acks-multiple-parameter + multiple :: Bool + } + deriving (Show, Eq) + deriving (FromJSON, ToJSON) via (Schema AckData) + +instance ToSchema AckData where + schema = + object "AckData" $ + AckData + <$> (.deliveryTag) .= field "delivery_tag" schema + <*> multiple .= field "multiple" schema + +data EventData = EventData + { payload :: [A.Object], + deliveryTag :: Word64 + } + deriving (Show, Eq) + deriving (FromJSON, ToJSON) via (Schema EventData) + +instance ToSchema EventData where + schema = + object "EventData" $ + EventData + <$> payload .= field "payload" (array genericToSchema) + <*> (.deliveryTag) .= field "delivery_tag" schema + +data Direction = ServerToClient | ClientToServer + deriving (Eq, Show) + +class KnownDirection (k :: Direction) where + directionVal :: Direction + +instance KnownDirection 'ServerToClient where + directionVal = ServerToClient + +instance KnownDirection 'ClientToServer where + directionVal = ClientToServer + +data WSMessage (direction :: Direction) where + EventMessage :: EventData -> WSMessage ServerToClient + AckMessage :: AckData -> WSMessage ClientToServer + PingMessage :: WSMessage direction + PongMessage :: WSMessage direction + +deriving instance Show (WSMessage dir) + +deriving instance Eq (WSMessage dir) + +makePrisms ''WSMessage + +-- | Only useful for writing the ToSchema instance for 'WSMessage' +data WSMessageType (dir :: Direction) where + MsgTypeEvent :: WSMessageType ServerToClient + MsgTypeAck :: WSMessageType ClientToServer + MsgTypePing :: WSMessageType dir + MsgTypePong :: WSMessageType dir + +deriving instance Show (WSMessageType dir) + +deriving instance Eq (WSMessageType dir) + +instance Enum (WSMessageType ServerToClient) where + toEnum = \case + 0 -> MsgTypeEvent + 1 -> MsgTypePing + 2 -> MsgTypePong + _ -> error "Enum out of bound" + fromEnum = \case + MsgTypeEvent -> 0 + MsgTypePing -> 1 + MsgTypePong -> 2 + +instance Bounded (WSMessageType ServerToClient) where + minBound = MsgTypeEvent + maxBound = MsgTypePong + +instance Enum (WSMessageType ClientToServer) where + toEnum = \case + 0 -> MsgTypeAck + 1 -> MsgTypePing + 2 -> MsgTypePong + _ -> error "Enum out of bound" + fromEnum = \case + MsgTypeAck -> 0 + MsgTypePing -> 1 + MsgTypePong -> 2 + +instance Bounded (WSMessageType ClientToServer) where + minBound = MsgTypeAck + maxBound = MsgTypePong + +instance ToSchema (WSMessageType ServerToClient) where + schema = + enum @Text "WSMessageType S2C" $ + mconcat + [ element "event" MsgTypeEvent, + element "ping" MsgTypePing, + element "pong" MsgTypePong + ] + +instance ToSchema (WSMessageType ClientToServer) where + schema = + enum @Text "WSMessageType C2S" $ + mconcat + [ element "ack" MsgTypeAck, + element "ping" MsgTypePing, + element "pong" MsgTypePong + ] + +instance forall (dir :: Direction). (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => ToSchema (WSMessage dir) where + schema = + object "WSMessage" $ + fromTagged + <$> toTagged + .= bind + (fst .= field "type" (schema @(WSMessageType dir))) + (snd .= untaggedSchema) + where + toTagged :: WSMessage dir -> (WSMessageType dir, WSMessage dir) + toTagged d@(EventMessage _) = (MsgTypeEvent, d) + toTagged d@(AckMessage _) = (MsgTypeAck, d) + toTagged d@PingMessage = (MsgTypePing, d) + toTagged d@PongMessage = (MsgTypePong, d) + + fromTagged :: (WSMessageType dir, WSMessage dir) -> WSMessage dir + fromTagged = snd + + untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageType dir) [A.Pair] (WSMessage dir) (WSMessage dir) + untaggedSchema = dispatch $ \case + MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) + MsgTypeAck -> tag _AckMessage (id .= field "data" schema) + MsgTypePing -> tag _PingMessage (id .= pure ()) + MsgTypePong -> tag _PongMessage (id .= pure ()) + +deriving via Schema (WSMessage dir) instance (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => FromJSON (WSMessage dir) + +deriving via Schema (WSMessage dir) instance (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => ToJSON (WSMessage dir) From e368674a672301dde314b0df476a16d69b586314 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 16:51:14 +0200 Subject: [PATCH 36/93] Undo funkiness: Create Wire.API.WebSocket with types for comms on the new websocket --- libs/wire-api/src/Wire/API/WebSocket.hs | 101 ++++++------------------ 1 file changed, 26 insertions(+), 75 deletions(-) diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs index c5a059a90bb..a2374d464c6 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -10,7 +10,6 @@ import Data.Aeson.Types qualified as A import Data.Schema import Data.Word import Imports -import Network.WebSockets data AckData = AckData { deliveryTag :: Word64, @@ -55,102 +54,54 @@ instance KnownDirection 'ServerToClient where instance KnownDirection 'ClientToServer where directionVal = ClientToServer -data WSMessage (direction :: Direction) where - EventMessage :: EventData -> WSMessage ServerToClient - AckMessage :: AckData -> WSMessage ClientToServer - PingMessage :: WSMessage direction - PongMessage :: WSMessage direction - -deriving instance Show (WSMessage dir) - -deriving instance Eq (WSMessage dir) +data WSMessage (direction :: Direction) + = EventMessage EventData + | AckMessage AckData + | PingMessage + | PongMessage + deriving (Show, Eq) makePrisms ''WSMessage -- | Only useful for writing the ToSchema instance for 'WSMessage' -data WSMessageType (dir :: Direction) where - MsgTypeEvent :: WSMessageType ServerToClient - MsgTypeAck :: WSMessageType ClientToServer - MsgTypePing :: WSMessageType dir - MsgTypePong :: WSMessageType dir - -deriving instance Show (WSMessageType dir) - -deriving instance Eq (WSMessageType dir) - -instance Enum (WSMessageType ServerToClient) where - toEnum = \case - 0 -> MsgTypeEvent - 1 -> MsgTypePing - 2 -> MsgTypePong - _ -> error "Enum out of bound" - fromEnum = \case - MsgTypeEvent -> 0 - MsgTypePing -> 1 - MsgTypePong -> 2 - -instance Bounded (WSMessageType ServerToClient) where - minBound = MsgTypeEvent - maxBound = MsgTypePong - -instance Enum (WSMessageType ClientToServer) where - toEnum = \case - 0 -> MsgTypeAck - 1 -> MsgTypePing - 2 -> MsgTypePong - _ -> error "Enum out of bound" - fromEnum = \case - MsgTypeAck -> 0 - MsgTypePing -> 1 - MsgTypePong -> 2 - -instance Bounded (WSMessageType ClientToServer) where - minBound = MsgTypeAck - maxBound = MsgTypePong - -instance ToSchema (WSMessageType ServerToClient) where - schema = - enum @Text "WSMessageType S2C" $ - mconcat - [ element "event" MsgTypeEvent, - element "ping" MsgTypePing, - element "pong" MsgTypePong - ] - -instance ToSchema (WSMessageType ClientToServer) where - schema = - enum @Text "WSMessageType C2S" $ - mconcat - [ element "ack" MsgTypeAck, - element "ping" MsgTypePing, - element "pong" MsgTypePong - ] - -instance forall (dir :: Direction). (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => ToSchema (WSMessage dir) where +data WSMessageType = MsgTypeEvent | MsgTypeAck | MsgTypePing | MsgTypePong + deriving (Eq, Enum, Bounded) + +msgTypeSchema :: Direction -> ValueSchema NamedSwaggerDoc WSMessageType +msgTypeSchema dir = + enum @Text "WSMessageType" $ + mconcat $ + [element "event" MsgTypeEvent | dir == ServerToClient] + <> [element "ack" MsgTypeAck | dir == ClientToServer] + <> [ element "ping" MsgTypePing, + element "pong" MsgTypePong + ] + +instance forall dir. (KnownDirection dir) => ToSchema (WSMessage dir) where schema = object "WSMessage" $ fromTagged <$> toTagged .= bind - (fst .= field "type" (schema @(WSMessageType dir))) + (fst .= field "type" (msgTypeSchema $ directionVal @dir)) (snd .= untaggedSchema) where - toTagged :: WSMessage dir -> (WSMessageType dir, WSMessage dir) + toTagged :: WSMessage dir -> (WSMessageType, WSMessage dir) toTagged d@(EventMessage _) = (MsgTypeEvent, d) toTagged d@(AckMessage _) = (MsgTypeAck, d) toTagged d@PingMessage = (MsgTypePing, d) toTagged d@PongMessage = (MsgTypePong, d) - fromTagged :: (WSMessageType dir, WSMessage dir) -> WSMessage dir + fromTagged :: (WSMessageType, WSMessage dir) -> WSMessage dir fromTagged = snd - untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageType dir) [A.Pair] (WSMessage dir) (WSMessage dir) + untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageType) [A.Pair] (WSMessage dir) (WSMessage dir) untaggedSchema = dispatch $ \case MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) MsgTypeAck -> tag _AckMessage (id .= field "data" schema) MsgTypePing -> tag _PingMessage (id .= pure ()) MsgTypePong -> tag _PongMessage (id .= pure ()) -deriving via Schema (WSMessage dir) instance (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => FromJSON (WSMessage dir) +deriving via Schema (WSMessage dir) instance (KnownDirection dir) => FromJSON (WSMessage dir) -deriving via Schema (WSMessage dir) instance (ToSchema (WSMessageType dir), Bounded (WSMessageType dir), Enum (WSMessageType dir)) => ToJSON (WSMessage dir) +deriving via Schema (WSMessage dir) instance (KnownDirection dir) => ToJSON (WSMessage dir) From 3ace3530566b5da5fbe570b0aa3d55eea7c15d87 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 16:58:15 +0200 Subject: [PATCH 37/93] WIP: cannon: try to use the new types from wire-api The case split is not the nicest, perhaps we can solve it with one these things: - Bring back the funkiness for couple of commits ago - Use separate types for server to client and client to server messages --- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 27 ++++++++++++------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 5f22fd7ef50..75ef39134f5 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -5,6 +5,7 @@ import Cannon.WS import Control.Concurrent.Async (race) import Control.Exception (Handler (..), catch, catches, throwIO) import Data.Aeson +import Data.Aeson qualified as Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp @@ -13,6 +14,7 @@ import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log import Wire.API.Notification +import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do @@ -28,7 +30,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "error" (displayException err) . Log.field "user" (idToText uid) . Log.field "client" (clientToText cid) - _ <- tryPutMVar closeWS () + void $ tryPutMVar closeWS () throwIO err handlers = [ Handler $ handleConsumerError @SomeException, @@ -48,21 +50,26 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "user" (idToText uid) . Log.field "client" (clientToText cid) WS.sendClose wsConn ("goaway" :: ByteString) - Right dat -> case eitherDecode @ClientMessage dat of + Right dat -> case eitherDecode @(WSMessage ClientToServer) dat of Left err -> do WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMesage err - Right msg -> do - void $ Amqp.ackMsg chan msg.ack False + Right (EventMessage ev) -> do + WS.sendClose wsConn ("invalid-message" :: ByteString) + throwIO $ ClientSentAnEvent ev + Right (AckMessage ackData) -> do + void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + wsRecieverLoop + Right PingMessage -> do + WS.sendBinaryData wsConn $ Aeson.encode @(WSMessage ServerToClient) PongMessage + wsRecieverLoop + Right PongMessage -> wsRecieverLoop wsRecieverLoop -data ClientMessage = ClientMessage {ack :: Word64} - -instance FromJSON ClientMessage where - parseJSON = withObject "ClientMessage" $ \o -> ClientMessage <$> o .: "ack" - -data WebSockerServerError = FailedToParseClientMesage String +data WebSockerServerError + = FailedToParseClientMesage String + | ClientSentAnEvent EventData deriving (Show) instance Exception WebSockerServerError From ded46221690cb36d0a82d6e8aff77f1598e74874 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 2 Oct 2024 16:59:28 +0200 Subject: [PATCH 38/93] wire-api: Cabal file --- libs/wire-api/wire-api.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 1091c12f7f3..62b1a355863 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -250,6 +250,7 @@ library Wire.API.UserMap Wire.API.Util.Aeson Wire.API.VersionInfo + Wire.API.WebSocket Wire.API.Wrapped other-modules: Paths_wire_api From 108e2416b617513b442cfd1298ebf224f5d2b942 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 08:51:45 +0200 Subject: [PATCH 39/93] gen nix stuff --- libs/wire-subsystems/default.nix | 2 ++ services/cannon/default.nix | 2 ++ services/gundeck/default.nix | 4 ++++ 3 files changed, 8 insertions(+) diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index ead2f2a9c9d..3a9271a0e72 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -7,6 +7,7 @@ , amazonka , amazonka-core , amazonka-ses +, amqp , async , attoparsec , base @@ -96,6 +97,7 @@ mkDerivation { amazonka amazonka-core amazonka-ses + amqp async attoparsec base diff --git a/services/cannon/default.nix b/services/cannon/default.nix index c0e94ff02f7..3c1da8fca8f 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -4,6 +4,7 @@ # dependencies are added or removed. { mkDerivation , aeson +, amqp , api-field-json-th , async , base @@ -61,6 +62,7 @@ mkDerivation { isExecutable = true; libraryHaskellDepends = [ aeson + amqp api-field-json-th async base diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index 7629d0712c5..a9ed8fed5ac 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -9,6 +9,7 @@ , amazonka-core , amazonka-sns , amazonka-sqs +, amqp , async , attoparsec , auto-update @@ -69,6 +70,7 @@ , tasty-hunit , tasty-quickcheck , text +, these , time , tinylog , tls @@ -98,6 +100,7 @@ mkDerivation { amazonka-core amazonka-sns amazonka-sqs + amqp async attoparsec auto-update @@ -135,6 +138,7 @@ mkDerivation { servant servant-server text + these time tinylog tls From f5a48c83548d2bcf727341c90a8f884b6a494fdd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 08:53:55 +0200 Subject: [PATCH 40/93] ormolu --- .../src/Wire/API/Routes/Public/Cannon.hs | 33 ++++++++++--------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs index 4608e229600..c6f55ef6d6d 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cannon.hs @@ -41,22 +41,23 @@ type CannonAPI = -- FUTUREWORK: Consider higher-level web socket combinator :> WebSocketPending ) - :<|> Named - "consume-events" - ( Summary "Consume events over a websocket connection" - :> "events" - :> ZUser - :> QueryParam' - [ -- Make this optional in https://wearezeta.atlassian.net/browse/WPB-11173 - Required, - Strict, - Description "Client ID" - ] - "client" - ClientId - -- FUTUREWORK: Consider higher-level web socket combinator - :> WebSocketPending - ) + :<|> Named + "consume-events" + ( Summary "Consume events over a websocket connection" + :> "events" + :> ZUser + :> QueryParam' + [ -- Make this optional in https://wearezeta.atlassian.net/browse/WPB-11173 + Required, + Strict, + Description "Client ID" + ] + "client" + ClientId + -- FUTUREWORK: Consider higher-level web socket combinator + :> WebSocketPending + ) + data CannonAPITag instance ServiceAPI CannonAPITag v where From 8148e576069082a905dba0dd6c9558a5dbff12b7 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 09:27:16 +0200 Subject: [PATCH 41/93] Is this a good way of representing websocket messages? --- libs/wire-api/src/Wire/API/WebSocket.hs | 116 +++++++++++------- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 11 +- 2 files changed, 77 insertions(+), 50 deletions(-) diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs index a2374d464c6..2e1dd7a38c5 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -42,66 +42,96 @@ instance ToSchema EventData where <$> payload .= field "payload" (array genericToSchema) <*> (.deliveryTag) .= field "delivery_tag" schema -data Direction = ServerToClient | ClientToServer - deriving (Eq, Show) - -class KnownDirection (k :: Direction) where - directionVal :: Direction - -instance KnownDirection 'ServerToClient where - directionVal = ServerToClient +data WSMessageServerToClient + = EventMessage EventData + | PingDownMessage + | PongDownMessage + deriving (Show, Eq) -instance KnownDirection 'ClientToServer where - directionVal = ClientToServer +makePrisms ''WSMessageServerToClient -data WSMessage (direction :: Direction) - = EventMessage EventData - | AckMessage AckData - | PingMessage - | PongMessage +data WSMessageClientToServer + = AckMessage AckData + | PingUpMessage + | PongUpMessage deriving (Show, Eq) -makePrisms ''WSMessage +makePrisms ''WSMessageClientToServer + +---------------------------------------------------------------------- +-- ServerToClient --- | Only useful for writing the ToSchema instance for 'WSMessage' -data WSMessageType = MsgTypeEvent | MsgTypeAck | MsgTypePing | MsgTypePong +-- | Local type, only needed for writing the ToSchema instance for 'WSMessage'. +data WSMessageTypeServerToClient = MsgTypeEvent | MsgTypePingDown | MsgTypePongDown deriving (Eq, Enum, Bounded) -msgTypeSchema :: Direction -> ValueSchema NamedSwaggerDoc WSMessageType -msgTypeSchema dir = - enum @Text "WSMessageType" $ +msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc WSMessageTypeServerToClient +msgTypeSchemaServerToClient = + enum @Text "WSMessageTypeServerToClient" $ mconcat $ - [element "event" MsgTypeEvent | dir == ServerToClient] - <> [element "ack" MsgTypeAck | dir == ClientToServer] - <> [ element "ping" MsgTypePing, - element "pong" MsgTypePong - ] + [ element "event" MsgTypeEvent, + element "ping" MsgTypePingDown, + element "pong" MsgTypePongDown + ] -instance forall dir. (KnownDirection dir) => ToSchema (WSMessage dir) where +instance ToSchema WSMessageServerToClient where schema = - object "WSMessage" $ - fromTagged - <$> toTagged - .= bind - (fst .= field "type" (msgTypeSchema $ directionVal @dir)) - (snd .= untaggedSchema) + object "WSMessageServerToClient" $ + fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaServerToClient) (snd .= untaggedSchema) where - toTagged :: WSMessage dir -> (WSMessageType, WSMessage dir) + toTagged :: WSMessageServerToClient -> (WSMessageTypeServerToClient, WSMessageServerToClient) toTagged d@(EventMessage _) = (MsgTypeEvent, d) - toTagged d@(AckMessage _) = (MsgTypeAck, d) - toTagged d@PingMessage = (MsgTypePing, d) - toTagged d@PongMessage = (MsgTypePong, d) + toTagged d@PingDownMessage = (MsgTypePingDown, d) + toTagged d@PongDownMessage = (MsgTypePongDown, d) - fromTagged :: (WSMessageType, WSMessage dir) -> WSMessage dir + fromTagged :: (WSMessageTypeServerToClient, WSMessageServerToClient) -> WSMessageServerToClient fromTagged = snd - untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageType) [A.Pair] (WSMessage dir) (WSMessage dir) + untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageTypeServerToClient) [A.Pair] (WSMessageServerToClient) (WSMessageServerToClient) untaggedSchema = dispatch $ \case MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) + MsgTypePingDown -> tag _PingDownMessage (id .= pure ()) + MsgTypePongDown -> tag _PongDownMessage (id .= pure ()) + +deriving via Schema WSMessageServerToClient instance FromJSON WSMessageServerToClient + +deriving via Schema WSMessageServerToClient instance ToJSON WSMessageServerToClient + +---------------------------------------------------------------------- +-- ClientToServer + +-- | Local type, only needed for writing the ToSchema instance for 'WSMessage'. +data WSMessageTypeClientToServer = MsgTypeAck | MsgTypePingUp | MsgTypePongUp + deriving (Eq, Enum, Bounded) + +msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc WSMessageTypeClientToServer +msgTypeSchemaClientToServer = + enum @Text "WSMessageTypeClientToServer" $ + mconcat $ + [ element "ack" MsgTypeAck, + element "ping" MsgTypePingUp, + element "pong" MsgTypePongUp + ] + +instance ToSchema WSMessageClientToServer where + schema = + object "WSMessageClientToServer" $ + fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaClientToServer) (snd .= untaggedSchema) + where + toTagged :: WSMessageClientToServer -> (WSMessageTypeClientToServer, WSMessageClientToServer) + toTagged d@(AckMessage _) = (MsgTypeAck, d) + toTagged d@PingUpMessage = (MsgTypePingUp, d) + toTagged d@PongUpMessage = (MsgTypePongUp, d) + + fromTagged :: (WSMessageTypeClientToServer, WSMessageClientToServer) -> WSMessageClientToServer + fromTagged = snd + + untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageTypeClientToServer) [A.Pair] WSMessageClientToServer WSMessageClientToServer + untaggedSchema = dispatch $ \case MsgTypeAck -> tag _AckMessage (id .= field "data" schema) - MsgTypePing -> tag _PingMessage (id .= pure ()) - MsgTypePong -> tag _PongMessage (id .= pure ()) + MsgTypePingUp -> tag _PingUpMessage (id .= pure ()) + MsgTypePongUp -> tag _PongUpMessage (id .= pure ()) -deriving via Schema (WSMessage dir) instance (KnownDirection dir) => FromJSON (WSMessage dir) +deriving via Schema WSMessageClientToServer instance FromJSON WSMessageClientToServer -deriving via Schema (WSMessage dir) instance (KnownDirection dir) => ToJSON (WSMessage dir) +deriving via Schema WSMessageClientToServer instance ToJSON WSMessageClientToServer diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 75ef39134f5..1db8cdee913 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -50,20 +50,17 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "user" (idToText uid) . Log.field "client" (clientToText cid) WS.sendClose wsConn ("goaway" :: ByteString) - Right dat -> case eitherDecode @(WSMessage ClientToServer) dat of + Right dat -> case eitherDecode @(WSMessageClientToServer) dat of Left err -> do WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMesage err - Right (EventMessage ev) -> do - WS.sendClose wsConn ("invalid-message" :: ByteString) - throwIO $ ClientSentAnEvent ev Right (AckMessage ackData) -> do void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple wsRecieverLoop - Right PingMessage -> do - WS.sendBinaryData wsConn $ Aeson.encode @(WSMessage ServerToClient) PongMessage + Right PingUpMessage -> do + WS.sendBinaryData wsConn $ Aeson.encode @(WSMessageServerToClient) PongDownMessage wsRecieverLoop - Right PongMessage -> + Right PongUpMessage -> wsRecieverLoop wsRecieverLoop From 1b590ed84f53f2098b1d8edef3ca9d9db9da6f48 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 09:48:15 +0200 Subject: [PATCH 42/93] Resolve TODO. amqp doesn't offer a bulk push operation. instead it makes individual pushes performant enough. https://www.rabbitmq.com/docs/publishers --- services/gundeck/src/Gundeck/Push.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index f32881e9ed0..c694d7cc7d5 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -267,7 +267,6 @@ pushViaRabbitMq p = do Set.singleton $ userRoutingKey r._recipientId RecipientClientsSome (toList -> cs) -> Set.fromList $ map (clientRoutingKey r._recipientId) cs - -- TODO: Figure out if there is a bulk operation in amqp for_ routingKeys $ \routingKey -> mpaPublishToRabbitMq routingKey qMsg From fe2608055775b67b23a351d8ab9b12c3c749ba99 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 10:22:11 +0200 Subject: [PATCH 43/93] Refactor test, extend coverage. --- integration/test/Test/Events.hs | 116 +++++++++++++++++++++++++------- 1 file changed, 90 insertions(+), 26 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 30929138d28..4076a5d608f 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -5,7 +5,9 @@ import API.BrigCommon import API.Common import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan +import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') +import Data.String.Conversions (cs) import qualified Network.WebSockets.Client as WS import qualified Network.WebSockets.Connection as WS import SetupHelpers @@ -13,38 +15,100 @@ import Testlib.Prelude import UnliftIO (Async, async, cancel, race, waitAny) import UnliftIO.Concurrent (threadDelay) -testConsumeEvents :: (HasCallStack) => App () -testConsumeEvents = do +testConsumeEventsOneWebSocket :: (HasCallStack) => App () +testConsumeEventsOneWebSocket = do alice <- randomUser OwnDomain def client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket alice clientId eventsChan ackChan - mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - case mEvent of - Left () -> assertFailure "No event recieved for 1s" - Right e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - deliveryTag <- e %. "delivery_tag" - liftIO $ atomically $ writeTChan ackChan $ object ["ack" .= deliveryTag] - cancel wsThread + + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket alice clientId eventsChan ackChan + + deliveryTag <- assertEventOnSameWebSocket eventsChan $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" + + sendEventOnSameWebSocket ackChan $ object ["ack" .= deliveryTag] + assertNoEventOnSameWebSocket eventsChan + + handle <- randomHandle + putHandle alice handle >>= assertSuccess + + assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle + + cancel wsThread + +testConsumeEventsNewWebSockets :: (HasCallStack) => App () +testConsumeEventsNewWebSockets = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + deliveryTag <- assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" + + sendEventOnNewWebSocket alice clientId $ object ["ack" .= deliveryTag] + assertNoEventOnNewWebSocket alice clientId handle <- randomHandle putHandle alice handle >>= assertSuccess - do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket alice clientId eventsChan ackChan - mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - case mEvent of - Left () -> assertFailure "No event recieved for 1s" - Right e -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle - cancel wsThread + + assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle + +---------------------------------------------------------------------- +-- helpers + +sendEventOnSameWebSocket :: (HasCallStack) => TChan Value -> Value -> App () +sendEventOnSameWebSocket ackChan msg = do + liftIO $ atomically $ writeTChan ackChan msg + +sendEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> Value -> App () +sendEventOnNewWebSocket uid cid msg = do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket uid cid eventsChan ackChan + sendEventOnSameWebSocket ackChan msg + -- TODO: is there enough time here to send the message before the websocket is closed? + cancel wsThread + +assertEventOnSameWebSocket :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a +assertEventOnSameWebSocket eventsChan expectations = do + mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) + case mEvent of + Left () -> assertFailure "No event recieved for 1s" + Right e -> expectations e + +assertEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (Value -> App a) -> App a +assertEventOnNewWebSocket uid cid expectations = do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket uid cid eventsChan ackChan + result <- assertEventOnSameWebSocket eventsChan expectations + cancel wsThread + pure result + +assertNoEventOnSameWebSocket :: (HasCallStack) => TChan Value -> App () +assertNoEventOnSameWebSocket eventsChan = do + mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) + case mEvent of + Left () -> pure () + Right e -> assertFailure $ "Did not expect event: " <> cs (A.encode e) + +assertNoEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> App () +assertNoEventOnNewWebSocket uid cid = do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket uid cid eventsChan ackChan + assertNoEventOnSameWebSocket eventsChan + cancel wsThread eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> App (Async ()) eventsWebSocket user clientId eventsChan ackChan = do From c3c231ea5b76f2a01eb666b25ff65cd8a234f012 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 4 Oct 2024 11:25:08 +0200 Subject: [PATCH 44/93] Suggestions for better module name; removed "websocket" reference from some names. --- libs/wire-api/src/Wire/API/WebSocket.hs | 58 ++++++++++--------- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 4 +- 2 files changed, 33 insertions(+), 29 deletions(-) diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs index 2e1dd7a38c5..086c4ad3ee3 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -1,6 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} --- TODO: Rename this module to something that is more specific than "websocket" +-- TODO: Rename this module to something that is more specific than "websocket". +-- - "Wire.API.Event.WebSocket"? +-- - "Wire.API.Event.ClientChan"? +-- - "Wire.API.Event.APIChan"? or "ApiChan"? +-- - "MessageBus"? "Bus"? module Wire.API.WebSocket where import Control.Lens (makePrisms) @@ -42,96 +46,96 @@ instance ToSchema EventData where <$> payload .= field "payload" (array genericToSchema) <*> (.deliveryTag) .= field "delivery_tag" schema -data WSMessageServerToClient +data MessageServerToClient = EventMessage EventData | PingDownMessage | PongDownMessage deriving (Show, Eq) -makePrisms ''WSMessageServerToClient +makePrisms ''MessageServerToClient -data WSMessageClientToServer +data MessageClientToServer = AckMessage AckData | PingUpMessage | PongUpMessage deriving (Show, Eq) -makePrisms ''WSMessageClientToServer +makePrisms ''MessageClientToServer ---------------------------------------------------------------------- -- ServerToClient --- | Local type, only needed for writing the ToSchema instance for 'WSMessage'. -data WSMessageTypeServerToClient = MsgTypeEvent | MsgTypePingDown | MsgTypePongDown +-- | Local type, only needed for writing the ToSchema instance for 'MessageServerToClient'. +data MessageTypeServerToClient = MsgTypeEvent | MsgTypePingDown | MsgTypePongDown deriving (Eq, Enum, Bounded) -msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc WSMessageTypeServerToClient +msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc MessageTypeServerToClient msgTypeSchemaServerToClient = - enum @Text "WSMessageTypeServerToClient" $ + enum @Text "MessageTypeServerToClient" $ mconcat $ [ element "event" MsgTypeEvent, element "ping" MsgTypePingDown, element "pong" MsgTypePongDown ] -instance ToSchema WSMessageServerToClient where +instance ToSchema MessageServerToClient where schema = - object "WSMessageServerToClient" $ + object "MessageServerToClient" $ fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaServerToClient) (snd .= untaggedSchema) where - toTagged :: WSMessageServerToClient -> (WSMessageTypeServerToClient, WSMessageServerToClient) + toTagged :: MessageServerToClient -> (MessageTypeServerToClient, MessageServerToClient) toTagged d@(EventMessage _) = (MsgTypeEvent, d) toTagged d@PingDownMessage = (MsgTypePingDown, d) toTagged d@PongDownMessage = (MsgTypePongDown, d) - fromTagged :: (WSMessageTypeServerToClient, WSMessageServerToClient) -> WSMessageServerToClient + fromTagged :: (MessageTypeServerToClient, MessageServerToClient) -> MessageServerToClient fromTagged = snd - untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageTypeServerToClient) [A.Pair] (WSMessageServerToClient) (WSMessageServerToClient) + untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeServerToClient) [A.Pair] (MessageServerToClient) (MessageServerToClient) untaggedSchema = dispatch $ \case MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) MsgTypePingDown -> tag _PingDownMessage (id .= pure ()) MsgTypePongDown -> tag _PongDownMessage (id .= pure ()) -deriving via Schema WSMessageServerToClient instance FromJSON WSMessageServerToClient +deriving via Schema MessageServerToClient instance FromJSON MessageServerToClient -deriving via Schema WSMessageServerToClient instance ToJSON WSMessageServerToClient +deriving via Schema MessageServerToClient instance ToJSON MessageServerToClient ---------------------------------------------------------------------- -- ClientToServer --- | Local type, only needed for writing the ToSchema instance for 'WSMessage'. -data WSMessageTypeClientToServer = MsgTypeAck | MsgTypePingUp | MsgTypePongUp +-- | Local type, only needed for writing the ToSchema instance for 'MessageClientToServer'. +data MessageTypeClientToServer = MsgTypeAck | MsgTypePingUp | MsgTypePongUp deriving (Eq, Enum, Bounded) -msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc WSMessageTypeClientToServer +msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc MessageTypeClientToServer msgTypeSchemaClientToServer = - enum @Text "WSMessageTypeClientToServer" $ + enum @Text "MessageTypeClientToServer" $ mconcat $ [ element "ack" MsgTypeAck, element "ping" MsgTypePingUp, element "pong" MsgTypePongUp ] -instance ToSchema WSMessageClientToServer where +instance ToSchema MessageClientToServer where schema = - object "WSMessageClientToServer" $ + object "MessageClientToServer" $ fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaClientToServer) (snd .= untaggedSchema) where - toTagged :: WSMessageClientToServer -> (WSMessageTypeClientToServer, WSMessageClientToServer) + toTagged :: MessageClientToServer -> (MessageTypeClientToServer, MessageClientToServer) toTagged d@(AckMessage _) = (MsgTypeAck, d) toTagged d@PingUpMessage = (MsgTypePingUp, d) toTagged d@PongUpMessage = (MsgTypePongUp, d) - fromTagged :: (WSMessageTypeClientToServer, WSMessageClientToServer) -> WSMessageClientToServer + fromTagged :: (MessageTypeClientToServer, MessageClientToServer) -> MessageClientToServer fromTagged = snd - untaggedSchema :: SchemaP SwaggerDoc (A.Object, WSMessageTypeClientToServer) [A.Pair] WSMessageClientToServer WSMessageClientToServer + untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeClientToServer) [A.Pair] MessageClientToServer MessageClientToServer untaggedSchema = dispatch $ \case MsgTypeAck -> tag _AckMessage (id .= field "data" schema) MsgTypePingUp -> tag _PingUpMessage (id .= pure ()) MsgTypePongUp -> tag _PongUpMessage (id .= pure ()) -deriving via Schema WSMessageClientToServer instance FromJSON WSMessageClientToServer +deriving via Schema MessageClientToServer instance FromJSON MessageClientToServer -deriving via Schema WSMessageClientToServer instance ToJSON WSMessageClientToServer +deriving via Schema MessageClientToServer instance ToJSON MessageClientToServer diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 1db8cdee913..d0d113e7d36 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -50,7 +50,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "user" (idToText uid) . Log.field "client" (clientToText cid) WS.sendClose wsConn ("goaway" :: ByteString) - Right dat -> case eitherDecode @(WSMessageClientToServer) dat of + Right dat -> case eitherDecode @MessageClientToServer dat of Left err -> do WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMesage err @@ -58,7 +58,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple wsRecieverLoop Right PingUpMessage -> do - WS.sendBinaryData wsConn $ Aeson.encode @(WSMessageServerToClient) PongDownMessage + WS.sendBinaryData wsConn $ Aeson.encode @MessageServerToClient PongDownMessage wsRecieverLoop Right PongUpMessage -> wsRecieverLoop From 9a655504cc7bf52de166536a814055e712581293 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 7 Oct 2024 09:38:51 +0200 Subject: [PATCH 45/93] Roundtrip tests for Message*To*. --- libs/wire-api/src/Wire/API/WebSocket.hs | 13 +++++++++---- .../test/unit/Test/Wire/API/Roundtrip/Aeson.hs | 3 +++ 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs index 086c4ad3ee3..2b8cc328a4e 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -14,6 +14,7 @@ import Data.Aeson.Types qualified as A import Data.Schema import Data.Word import Imports +import Wire.Arbitrary data AckData = AckData { deliveryTag :: Word64, @@ -22,7 +23,8 @@ data AckData = AckData -- https://www.rabbitmq.com/docs/confirms#consumer-acks-multiple-parameter multiple :: Bool } - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform AckData) deriving (FromJSON, ToJSON) via (Schema AckData) instance ToSchema AckData where @@ -36,7 +38,8 @@ data EventData = EventData { payload :: [A.Object], deliveryTag :: Word64 } - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform EventData) deriving (FromJSON, ToJSON) via (Schema EventData) instance ToSchema EventData where @@ -50,7 +53,8 @@ data MessageServerToClient = EventMessage EventData | PingDownMessage | PongDownMessage - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform MessageServerToClient) makePrisms ''MessageServerToClient @@ -58,7 +62,8 @@ data MessageClientToServer = AckMessage AckData | PingUpMessage | PongUpMessage - deriving (Show, Eq) + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform MessageClientToServer) makePrisms ''MessageClientToServer diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 65be7b6ef80..0fbfee822b9 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -76,6 +76,7 @@ import Wire.API.User.Profile qualified as User.Profile import Wire.API.User.RichInfo qualified as User.RichInfo import Wire.API.User.Scim qualified as Scim import Wire.API.User.Search qualified as User.Search +import Wire.API.WebSocket qualified as WebSocket import Wire.API.Wrapped qualified as Wrapped -- FUTUREWORK(#1446): fix tests marked as failing @@ -337,6 +338,8 @@ tests = testRoundTrip @(User.Search.SearchResult User.Search.TeamContact), testRoundTrip @User.Search.PagingState, testRoundTrip @User.Search.TeamContact, + testRoundTrip @WebSocket.MessageServerToClient, + testRoundTrip @WebSocket.MessageClientToServer, testRoundTrip @(Wrapped.Wrapped "some_int" Int), testRoundTrip @Conversation.Action.SomeConversationAction, testRoundTrip @Routes.Version.Version, From 6e75fcc69945d4a6b26e045edb915ef7c84139e7 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 7 Oct 2024 09:49:03 +0200 Subject: [PATCH 46/93] Source comments. --- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index d0d113e7d36..19f0e603354 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -22,7 +22,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do closeWS <- newEmptyMVar -- TODO: Don't create new conns for every client, this will definitely kill rabbit withConnection e.logg e.rabbitmq $ \conn -> do - chan <- Amqp.openChannel conn + chan <- Amqp.openChannel conn -- TODO: should we open a channel for every request? or have a pool of them? let handleConsumerError :: (Exception e) => e -> IO () handleConsumerError err = do Log.err e.logg $ @@ -42,7 +42,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do Amqp.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) let wsRecieverLoop = do - eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) + eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) -- no timeout necessary here, we want to keep running forever. case eitherData of Left () -> do Log.info e.logg $ From c4dc1686988abc73aa64bde58294380a4af6099c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 7 Oct 2024 10:50:15 +0200 Subject: [PATCH 47/93] debug failing test [WIP] --- integration/test/Test/Events.hs | 2 ++ services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 7 ++++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 4076a5d608f..08a94fb5401 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -138,3 +138,5 @@ eventsWebSocket user clientId eventsChan ackChan = do WS.defaultConnectionOptions caHdrs app + +-- TODO: test pingpong? or drop it? diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 19f0e603354..d82bff85ebc 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -7,6 +7,7 @@ import Control.Exception (Handler (..), catch, catches, throwIO) import Data.Aeson import Data.Aeson qualified as Aeson import Data.Id +import Debug.Trace import Imports import Network.AMQP qualified as Amqp import Network.AMQP.Extended (withConnection) @@ -18,6 +19,8 @@ import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do + traceM $ "*********************************** entering rabbitMQWebSocketApp: " <> show (uid, cid) + wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) closeWS <- newEmptyMVar -- TODO: Don't create new conns for every client, this will definitely kill rabbit @@ -42,6 +45,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do Amqp.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) let wsRecieverLoop = do + traceM $ "*********************************** entering rabbitMQWebSocketApp receive loop" eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) -- no timeout necessary here, we want to keep running forever. case eitherData of Left () -> do @@ -55,7 +59,8 @@ rabbitMQWebSocketApp uid cid e pendingConn = do WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMesage err Right (AckMessage ackData) -> do - void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + result <- Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + () <- error $ "************* " <> show (ackData, result) wsRecieverLoop Right PingUpMessage -> do WS.sendBinaryData wsConn $ Aeson.encode @MessageServerToClient PongDownMessage From 42142a5140238cfa5020eeb07ab3e96e092b5b65 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 7 Oct 2024 10:49:42 +0000 Subject: [PATCH 48/93] refactor tests a bit, fix ack, fix typos --- integration/test/Test/Events.hs | 114 ++++++++---------- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 14 ++- services/gundeck/src/Gundeck/Push.hs | 2 +- 3 files changed, 59 insertions(+), 71 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 08a94fb5401..af75203b868 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -1,4 +1,4 @@ -module Test.Events where +module Test.Events (testConsumeEventsOneWebSocket, testConsumeEventsNewWebSockets ) where import API.Brig import API.BrigCommon @@ -11,8 +11,8 @@ import Data.String.Conversions (cs) import qualified Network.WebSockets.Client as WS import qualified Network.WebSockets.Connection as WS import SetupHelpers -import Testlib.Prelude -import UnliftIO (Async, async, cancel, race, waitAny) +import Testlib.Prelude hiding (assertNoEvent) +import UnliftIO (Async, async, cancel, race, waitAny, bracket) import UnliftIO.Concurrent (threadDelay) testConsumeEventsOneWebSocket :: (HasCallStack) => App () @@ -21,26 +21,21 @@ testConsumeEventsOneWebSocket = do client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket alice clientId eventsChan ackChan + withNewWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTag <- assertEvent eventsChan $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" - deliveryTag <- assertEventOnSameWebSocket eventsChan $ \(e :: Value) -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + sendAck ackChan deliveryTag + assertNoEvent eventsChan - sendEventOnSameWebSocket ackChan $ object ["ack" .= deliveryTag] - assertNoEventOnSameWebSocket eventsChan + handle <- randomHandle + putHandle alice handle >>= assertSuccess - handle <- randomHandle - putHandle alice handle >>= assertSuccess - - assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle - - cancel wsThread + assertEvent eventsChan $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle testConsumeEventsNewWebSockets :: (HasCallStack) => App () testConsumeEventsNewWebSockets = do @@ -48,68 +43,59 @@ testConsumeEventsNewWebSockets = do client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - deliveryTag <- assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + deliveryTag <- withNewWebSocket alice clientId $ \eventsChan _ -> do + assertEvent eventsChan $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" + + withNewWebSocket alice clientId $ \_ ackChan -> do + sendAck ackChan deliveryTag - sendEventOnNewWebSocket alice clientId $ object ["ack" .= deliveryTag] - assertNoEventOnNewWebSocket alice clientId + withNewWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan handle <- randomHandle putHandle alice handle >>= assertSuccess - assertEventOnNewWebSocket alice clientId $ \(e :: Value) -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle + void $ withNewWebSocket alice clientId $ \eventsChan _ -> do + assertEvent eventsChan $ \(e :: Value) -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle ---------------------------------------------------------------------- -- helpers -sendEventOnSameWebSocket :: (HasCallStack) => TChan Value -> Value -> App () -sendEventOnSameWebSocket ackChan msg = do - liftIO $ atomically $ writeTChan ackChan msg - -sendEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> Value -> App () -sendEventOnNewWebSocket uid cid msg = do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket uid cid eventsChan ackChan - sendEventOnSameWebSocket ackChan msg - -- TODO: is there enough time here to send the message before the websocket is closed? - cancel wsThread - -assertEventOnSameWebSocket :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a -assertEventOnSameWebSocket eventsChan expectations = do +withNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a +withNewWebSocket uid cid f = do + bracket setup (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, _) -> f eventsChan ackChan + where + setup :: HasCallStack => App (TChan Value, TChan Value, Async ()) + setup = do + eventsChan <- liftIO newTChanIO + ackChan <- liftIO newTChanIO + wsThread <- eventsWebSocket uid cid eventsChan ackChan + pure (eventsChan, ackChan, wsThread) + + +sendAck :: (HasCallStack) => TChan Value -> Value -> App () +sendAck ackChan deliveryTag = do + liftIO $ atomically $ writeTChan ackChan $ object [ "type" .= "ack", "data" .= object ["delivery_tag" .= deliveryTag, "multiple" .= False] ] + +assertEvent:: (HasCallStack) => TChan Value -> (Value -> App a) -> App a +assertEvent eventsChan expectations = do mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) case mEvent of - Left () -> assertFailure "No event recieved for 1s" + Left () -> assertFailure "No event received for 1s" Right e -> expectations e -assertEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (Value -> App a) -> App a -assertEventOnNewWebSocket uid cid expectations = do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket uid cid eventsChan ackChan - result <- assertEventOnSameWebSocket eventsChan expectations - cancel wsThread - pure result - -assertNoEventOnSameWebSocket :: (HasCallStack) => TChan Value -> App () -assertNoEventOnSameWebSocket eventsChan = do +assertNoEvent :: (HasCallStack) => TChan Value -> App () +assertNoEvent eventsChan = do mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) case mEvent of Left () -> pure () Right e -> assertFailure $ "Did not expect event: " <> cs (A.encode e) -assertNoEventOnNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> App () -assertNoEventOnNewWebSocket uid cid = do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO - wsThread <- eventsWebSocket uid cid eventsChan ackChan - assertNoEventOnSameWebSocket eventsChan - cancel wsThread - eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> App (Async ()) eventsWebSocket user clientId eventsChan ackChan = do serviceMap <- getServiceMap =<< objDomain user diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index d82bff85ebc..509438e4188 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -47,6 +47,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do let wsRecieverLoop = do traceM $ "*********************************** entering rabbitMQWebSocketApp receive loop" eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) -- no timeout necessary here, we want to keep running forever. + traceM $ "*********************************** eitherData: " <> show eitherData case eitherData of Left () -> do Log.info e.logg $ @@ -56,11 +57,12 @@ rabbitMQWebSocketApp uid cid e pendingConn = do WS.sendClose wsConn ("goaway" :: ByteString) Right dat -> case eitherDecode @MessageClientToServer dat of Left err -> do + traceM $ "*********************************** err: " <> show err WS.sendClose wsConn ("invalid-message" :: ByteString) - throwIO $ FailedToParseClientMesage err + throwIO $ FailedToParseClientMessage err Right (AckMessage ackData) -> do - result <- Amqp.ackMsg chan ackData.deliveryTag ackData.multiple - () <- error $ "************* " <> show (ackData, result) + traceM $ "*********************************** ackData: " <> show ackData + void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple wsRecieverLoop Right PingUpMessage -> do WS.sendBinaryData wsConn $ Aeson.encode @MessageServerToClient PongDownMessage @@ -69,12 +71,12 @@ rabbitMQWebSocketApp uid cid e pendingConn = do wsRecieverLoop wsRecieverLoop -data WebSockerServerError - = FailedToParseClientMesage String +data WebSocketServerError + = FailedToParseClientMessage String | ClientSentAnEvent EventData deriving (Show) -instance Exception WebSockerServerError +instance Exception WebSocketServerError pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () pushEventsToWS wsConn (msg, envelope) = diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index c694d7cc7d5..9f0d2e5b9ef 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -211,7 +211,7 @@ getClients uid = do pushAll :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m, Log.MonadLogger m) => [Push] -> m () pushAll pushes = do - Log.warn $ msg (val "pushing") . Log.field "pushes" (Aeson.encode pushes) + Log.debug $ msg (val "pushing") . Log.field "pushes" (Aeson.encode pushes) (rabbitmqPushes, legacyPushes) <- splitPushes pushes pushAllLegacy legacyPushes pushAllViaRabbitMq rabbitmqPushes From d68e3a6baf2f63548f1e0dbd566a1f44889b872e Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 7 Oct 2024 15:06:53 +0000 Subject: [PATCH 49/93] fix test, handle connection closed, format --- integration/test/Test/Events.hs | 28 ++++++++-------- .../src/Network/Wai/Utilities/Server.hs | 3 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 32 +++++++++++-------- 3 files changed, 34 insertions(+), 29 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index af75203b868..b7e1036b9b3 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -1,4 +1,4 @@ -module Test.Events (testConsumeEventsOneWebSocket, testConsumeEventsNewWebSockets ) where +module Test.Events (testConsumeEventsOneWebSocket, testConsumeEventsNewWebSockets) where import API.Brig import API.BrigCommon @@ -12,7 +12,7 @@ import qualified Network.WebSockets.Client as WS import qualified Network.WebSockets.Connection as WS import SetupHelpers import Testlib.Prelude hiding (assertNoEvent) -import UnliftIO (Async, async, cancel, race, waitAny, bracket) +import UnliftIO (Async, async, bracket, cancel, race, waitAny) import UnliftIO.Concurrent (threadDelay) testConsumeEventsOneWebSocket :: (HasCallStack) => App () @@ -43,13 +43,14 @@ testConsumeEventsNewWebSockets = do client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - deliveryTag <- withNewWebSocket alice clientId $ \eventsChan _ -> do - assertEvent eventsChan $ \(e :: Value) -> do + withNewWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTag <- assertEvent eventsChan $ \(e :: Value) -> do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" - - withNewWebSocket alice clientId $ \_ ackChan -> do + -- if you close the WS in this line, the client-add message will remain + -- in the queue and will be received through the next WS connection, + -- before we are able to sne the Ack message sendAck ackChan deliveryTag withNewWebSocket alice clientId $ \eventsChan _ -> do @@ -68,21 +69,22 @@ testConsumeEventsNewWebSockets = do withNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a withNewWebSocket uid cid f = do - bracket setup (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, _) -> f eventsChan ackChan + bracket setup (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, _) -> do + f eventsChan ackChan where - setup :: HasCallStack => App (TChan Value, TChan Value, Async ()) + setup :: (HasCallStack) => App (TChan Value, TChan Value, Async ()) setup = do - eventsChan <- liftIO newTChanIO - ackChan <- liftIO newTChanIO + (eventsChan, ackChan) <- liftIO $ (,) <$> newTChanIO <*> newTChanIO wsThread <- eventsWebSocket uid cid eventsChan ackChan pure (eventsChan, ackChan, wsThread) +sendMsg :: (HasCallStack) => TChan Value -> Value -> App () +sendMsg eventsChan msg = liftIO $ atomically $ writeTChan eventsChan msg sendAck :: (HasCallStack) => TChan Value -> Value -> App () -sendAck ackChan deliveryTag = do - liftIO $ atomically $ writeTChan ackChan $ object [ "type" .= "ack", "data" .= object ["delivery_tag" .= deliveryTag, "multiple" .= False] ] +sendAck ackChan deliveryTag = sendMsg ackChan $ object ["type" .= "ack", "data" .= object ["delivery_tag" .= deliveryTag, "multiple" .= False]] -assertEvent:: (HasCallStack) => TChan Value -> (Value -> App a) -> App a +assertEvent :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a assertEvent eventsChan expectations = do mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) case mEvent of diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 20f8fc9b934..fea394e5af9 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -208,6 +208,7 @@ requestIdMiddleware logger reqIdHeaderName origApp req responder = let reqWithId = req {requestHeaders = (reqIdHeaderName, reqId) : req.requestHeaders} origApp reqWithId responder +{-# INLINEABLE catchErrors #-} catchErrors :: Logger -> HeaderName -> Middleware catchErrors l reqIdHeaderName = catchErrorsWithRequestId (lookupRequestId reqIdHeaderName) l @@ -232,8 +233,6 @@ catchErrorsWithRequestId getRequestId l app req k = er <- runHandlers ex errorHandlers onError l mReqId req k er -{-# INLINEABLE catchErrors #-} - -- | Standard handlers for turning exceptions into appropriate -- 'Error' responses. errorHandlers :: [Handler IO (Either Wai.Error JSONResponse)] diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 509438e4188..fa9a848f1b3 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -7,7 +7,6 @@ import Control.Exception (Handler (..), catch, catches, throwIO) import Data.Aeson import Data.Aeson qualified as Aeson import Data.Id -import Debug.Trace import Imports import Network.AMQP qualified as Amqp import Network.AMQP.Extended (withConnection) @@ -19,8 +18,6 @@ import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do - traceM $ "*********************************** entering rabbitMQWebSocketApp: " <> show (uid, cid) - wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) closeWS <- newEmptyMVar -- TODO: Don't create new conns for every client, this will definitely kill rabbit @@ -35,8 +32,19 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "client" (clientToText cid) void $ tryPutMVar closeWS () throwIO err + + handleConnectionClosed :: ConnectionException -> IO () + handleConnectionClosed err = do + Log.info e.logg $ + Log.msg (Log.val "Pushing to WS failed, closing connection") + . Log.field "error" (displayException err) + . Log.field "user" (idToText uid) + . Log.field "client" (clientToText cid) + void $ tryPutMVar closeWS () + handlers = - [ Handler $ handleConsumerError @SomeException, + [ Handler $ handleConnectionClosed, + Handler $ handleConsumerError @SomeException, Handler $ handleConsumerError @SomeAsyncException ] qName = clientNotificationQueueName uid cid @@ -44,10 +52,8 @@ rabbitMQWebSocketApp uid cid e pendingConn = do _consumerTag <- Amqp.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) - let wsRecieverLoop = do - traceM $ "*********************************** entering rabbitMQWebSocketApp receive loop" + let wsReceiverLoop = do eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) -- no timeout necessary here, we want to keep running forever. - traceM $ "*********************************** eitherData: " <> show eitherData case eitherData of Left () -> do Log.info e.logg $ @@ -57,19 +63,17 @@ rabbitMQWebSocketApp uid cid e pendingConn = do WS.sendClose wsConn ("goaway" :: ByteString) Right dat -> case eitherDecode @MessageClientToServer dat of Left err -> do - traceM $ "*********************************** err: " <> show err WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMessage err Right (AckMessage ackData) -> do - traceM $ "*********************************** ackData: " <> show ackData - void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple - wsRecieverLoop + void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + wsReceiverLoop Right PingUpMessage -> do WS.sendBinaryData wsConn $ Aeson.encode @MessageServerToClient PongDownMessage - wsRecieverLoop + wsReceiverLoop Right PongUpMessage -> - wsRecieverLoop - wsRecieverLoop + wsReceiverLoop + wsReceiverLoop `catches` handlers data WebSocketServerError = FailedToParseClientMessage String From 4508ea7cdfacec1a80842b4ea217b21c310b16b5 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Mon, 7 Oct 2024 15:16:02 +0000 Subject: [PATCH 50/93] ping pong test --- integration/test/Test/Events.hs | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index b7e1036b9b3..88718d09e1b 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -1,4 +1,4 @@ -module Test.Events (testConsumeEventsOneWebSocket, testConsumeEventsNewWebSockets) where +module Test.Events where import API.Brig import API.BrigCommon @@ -22,7 +22,7 @@ testConsumeEventsOneWebSocket = do clientId <- objId client withNewWebSocket alice clientId $ \eventsChan ackChan -> do - deliveryTag <- assertEvent eventsChan $ \(e :: Value) -> do + deliveryTag <- assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" @@ -33,7 +33,7 @@ testConsumeEventsOneWebSocket = do handle <- randomHandle putHandle alice handle >>= assertSuccess - assertEvent eventsChan $ \(e :: Value) -> do + assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.update" e %. "payload.0.user.handle" `shouldMatch` handle @@ -44,7 +44,7 @@ testConsumeEventsNewWebSockets = do clientId <- objId client withNewWebSocket alice clientId $ \eventsChan ackChan -> do - deliveryTag <- assertEvent eventsChan $ \(e :: Value) -> do + deliveryTag <- assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" @@ -60,10 +60,21 @@ testConsumeEventsNewWebSockets = do putHandle alice handle >>= assertSuccess void $ withNewWebSocket alice clientId $ \eventsChan _ -> do - assertEvent eventsChan $ \(e :: Value) -> do + assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.update" e %. "payload.0.user.handle" `shouldMatch` handle +testPingPong :: (HasCallStack) => App () +testPingPong = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + withNewWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ const $ pure () + sendMsg ackChan $ object ["type" .= "ping"] + assertEvent eventsChan $ \e -> e %. "type" `shouldMatch` "pong" + ---------------------------------------------------------------------- -- helpers @@ -126,5 +137,3 @@ eventsWebSocket user clientId eventsChan ackChan = do WS.defaultConnectionOptions caHdrs app - --- TODO: test pingpong? or drop it? From b302c8e4a0e9ab0aa69b7635b10a6d981a7af5d6 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 7 Oct 2024 18:22:24 +0200 Subject: [PATCH 51/93] Maintain stable connection to rabbitmq from cannon. [WIP] --- libs/extended/src/Network/AMQP/Extended.hs | 44 ++++++++++++++----- services/cannon/src/Cannon/API/Public.hs | 3 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 19 +++++--- services/cannon/src/Cannon/Run.hs | 7 ++- services/cannon/src/Cannon/Types.hs | 15 ++++--- services/cannon/src/Cannon/WS.hs | 5 +-- 6 files changed, 63 insertions(+), 30 deletions(-) diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 055cdd57154..62659bb3e48 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -4,7 +4,11 @@ module Network.AMQP.Extended ( RabbitMqHooks (..), RabbitMqAdminOpts (..), AmqpEndpoint (..), - withConnection, + mkStableRabbitmqConn, + mkRabbitmqConn, + getStableRabbitmqConn, + taintStableRabbitmqConn, + stableRabbitmqConnRepairLoop, openConnectionWithRetries, mkRabbitMqAdminClientEnv, mkRabbitMqChannelMVar, @@ -146,15 +150,11 @@ data RabbitMqConnectionError = RabbitMqConnectionFailed String instance Exception RabbitMqConnectionError --- | Connects with RabbitMQ and opens a channel. -withConnection :: - forall m a. - (MonadIO m, MonadMask m) => - Logger -> - AmqpEndpoint -> - (Q.Connection -> m a) -> - m a -withConnection l AmqpEndpoint {..} k = do +mkStableRabbitmqConn :: (MonadIO m, MonadMask m) => Logger -> AmqpEndpoint -> m (MVar (Maybe Q.Connection)) +mkStableRabbitmqConn l ep = (newMVar . Just) =<< mkRabbitmqConn l ep + +mkRabbitmqConn :: (MonadIO m, MonadMask m) => Logger -> AmqpEndpoint -> m Q.Connection +mkRabbitmqConn l AmqpEndpoint {..} = do (username, password) <- liftIO $ readCredsFromEnv -- Jittered exponential backoff with 1ms as starting delay and 1s as total -- wait time. @@ -173,7 +173,7 @@ withConnection l AmqpEndpoint {..} k = do ) ( const $ do Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") - mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls + mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls -- TODO: error here is about ambiguous record fields i think? liftIO $ Q.openConnection'' $ Q.defaultConnectionOpts @@ -183,7 +183,27 @@ withConnection l AmqpEndpoint {..} k = do Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings } ) - bracket getConn (liftIO . Q.closeConnection) k + getConn + +getStableRabbitmqConn :: (MonadIO m) => MVar (Maybe Q.Connection) -> m (Maybe Q.Connection) +getStableRabbitmqConn = readMVar + +taintStableRabbitmqConn :: (MonadIO m) => MVar (Maybe Q.Connection) -> m () +taintStableRabbitmqConn mvar = void $ swapMVar mvar Nothing + +-- | Keep an eye on the stableRabbitmqConnection. If it is tainted (eg., there is Nothing in +-- it, see above), create a new one and put it. +stableRabbitmqConnRepairLoop :: (MonadMask m, MonadUnliftIO m) => Logger -> AmqpEndpoint -> MVar (Maybe Q.Connection) -> m (Async ()) +stableRabbitmqConnRepairLoop l ep mvar = async . forever $ do + mustRepair <- isNothing <$> readMVar mvar + if mustRepair + then do + -- TODO: this block should probably catch at least SomeException (and probably not SomeAsyncException. + conn <- mkRabbitmqConn l ep + void $ swapMVar mvar (Just conn) + threadDelay 1_800_000 -- if it fails, retry connecting every 1.8s + else do + threadDelay 100_000 -- checking for Nothing is very cheap, so it's ok to run this every 100ms. -- | Connects with RabbitMQ and opens a channel. If the channel is closed for -- some reasons, reopens the channel. If the connection is closed for some diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index e895429ae8b..c301d69548f 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -45,4 +45,5 @@ streamData userId connId clientId con = do consumeEvents :: UserId -> ClientId -> PendingConnection -> Cannon () consumeEvents userId clientId con = do e <- wsenv - liftIO $ rabbitMQWebSocketApp userId clientId e con + r <- stableRabbitmqConn + liftIO $ rabbitMQWebSocketApp userId clientId r e con diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index fa9a848f1b3..d4967b5feaa 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -9,20 +9,26 @@ import Data.Aeson qualified as Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp -import Network.AMQP.Extended (withConnection) +import Network.AMQP.Extended (getStableRabbitmqConn) import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log import Wire.API.Notification import Wire.API.WebSocket -rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp -rabbitMQWebSocketApp uid cid e pendingConn = do +rabbitMQWebSocketApp :: UserId -> ClientId -> MVar (Maybe Amqp.Connection) -> Env -> ServerApp +rabbitMQWebSocketApp uid cid rConn e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) closeWS <- newEmptyMVar - -- TODO: Don't create new conns for every client, this will definitely kill rabbit - withConnection e.logg e.rabbitmq $ \conn -> do - chan <- Amqp.openChannel conn -- TODO: should we open a channel for every request? or have a pool of them? + + do + -- FUTUREWORK: we pool connections, but not channels. however, channel pooling is also a + -- thing! we should generate some performance data using otel and decide whether we want + -- to do it. + -- https://stackoverflow.com/questions/10365867/how-can-i-pool-channels-in-rabbitmq + mConn <- getStableRabbitmqConn rConn + chan <- maybe (throwIO ConnectionClosed) Amqp.openChannel mConn + let handleConsumerError :: (Exception e) => e -> IO () handleConsumerError err = do Log.err e.logg $ @@ -35,6 +41,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do handleConnectionClosed :: ConnectionException -> IO () handleConnectionClosed err = do + -- TODO: extract "Log.msg ..." into helper function. don't say "pushing" in pulling exceptions. make everything nicer. Log.info e.logg $ Log.msg (Log.val "Pushing to WS failed, closing connection") . Log.field "error" (displayException err) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 1905f7ae70b..ec5e294d818 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -42,7 +42,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Imports hiding (head, threadDelay) import Network.AMQP -import Network.AMQP.Extended (mkRabbitMqChannelMVar) +import Network.AMQP.Extended (mkRabbitMqChannelMVar, mkStableRabbitmqConn, stableRabbitmqConnRepairLoop) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Middleware.Gzip qualified as Gzip @@ -75,13 +75,15 @@ run o = withTracer \tracer -> do error "drainOpts.gracePeriodSeconds must not be set to 0." ext <- loadExternal g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) + rabbitConn <- mkStableRabbitmqConn g (o ^. Cannon.Options.rabbitmq) + rabbitRepairLoop <- stableRabbitmqConnRepairLoop g (o ^. Cannon.Options.rabbitmq) rabbitConn e <- mkEnv ext o g <$> D.empty 128 <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock - <*> pure (o ^. Cannon.Options.rabbitmq) + <*> pure rabbitConn createUserNotificationsExchange $ applog e refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) @@ -110,6 +112,7 @@ run o = withTracer \tracer -> do -- but it's a sensitive change, and it looks like this is closing all the websockets at -- the same time and then calling the drain script. I suspect this might be due to some -- cleanup in wai. this needs to be tested very carefully when touched. + Async.cancel rabbitRepairLoop Async.cancel refreshMetricsThread L.close (applog e) where diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index e1da89a70af..12b94833135 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -20,6 +20,7 @@ module Cannon.Types ( Env, opts, + stableRabbitmqConn, applog, dict, env, @@ -45,7 +46,7 @@ import Control.Monad.Catch import Data.Id import Data.Text.Encoding import Imports -import Network.AMQP.Extended (AmqpEndpoint) +import Network.AMQP (Connection) import Prometheus import Servant qualified import System.Logger qualified as Logger @@ -60,6 +61,7 @@ data Env = Env applog :: !Logger, dict :: !(Dict Key Websocket), reqId :: !RequestId, + stableRabbitmqConn_ :: MVar (Maybe Connection), env :: !WS.Env } @@ -100,11 +102,11 @@ mkEnv :: Manager -> GenIO -> Clock -> - AmqpEndpoint -> + MVar (Maybe Connection) -> Env -mkEnv external o l d p g t rabbitmqOpts = - Env o l d (RequestId defRequestId) $ - WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) rabbitmqOpts +mkEnv external o l d p g t stableRabbit = + Env o l d (RequestId defRequestId) stableRabbit $ + WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) runCannon :: Env -> Cannon a -> IO a runCannon e c = runReaderT (unCannon c) e @@ -118,6 +120,9 @@ wsenv = Cannon $ do r <- asks reqId pure $ WS.setRequestId r e +stableRabbitmqConn :: Cannon (MVar (Maybe Connection)) +stableRabbitmqConn = Cannon $ asks stableRabbitmqConn_ + -- | Natural transformation from 'Cannon' to 'Handler' monad. -- Used to call 'Cannon' from servant. runCannonToServant :: Cannon.Types.Env -> Cannon x -> Servant.Handler x diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index ae3cfd82bd1..23a9b3c7cc1 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -67,7 +67,6 @@ import Data.List.Extra (chunksOf) import Data.Text.Encoding (decodeUtf8) import Data.Timeout (TimeoutUnit (..), (#)) import Imports hiding (threadDelay) -import Network.AMQP.Extended import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error @@ -146,8 +145,7 @@ data Env = Env dict :: !(Dict Key Websocket), rand :: !GenIO, clock :: !Clock, - drainOpts :: DrainOpts, - rabbitmq :: !AmqpEndpoint + drainOpts :: DrainOpts } setRequestId :: RequestId -> Env -> Env @@ -193,7 +191,6 @@ env :: GenIO -> Clock -> DrainOpts -> - AmqpEndpoint -> Env env leh lp gh gp = Env leh lp (Bilge.host gh . Bilge.port gp $ empty) (RequestId defRequestId) From 5ac11b07d452ed2ee0a97637477e4d643d657682 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 8 Oct 2024 09:20:45 +0200 Subject: [PATCH 52/93] Fix typo. --- services/brig/src/Brig/API/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 3685605c7ce..052c5cdb59f 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -196,7 +196,7 @@ accountAPI :: Member PropertySubsystem r, Member Events r, Member PasswordResetCodeStore r, - Member InvitationCodeStore r + Member InvitationStore r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = From a70071b90bb73b4fb848718d1840e3528f12d55c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 8 Oct 2024 09:38:21 +0200 Subject: [PATCH 53/93] Tune tests. --- integration/test/Test/Events.hs | 34 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 88718d09e1b..3f7eac031ce 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -21,11 +21,12 @@ testConsumeEventsOneWebSocket = do client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - withNewWebSocket alice clientId $ \eventsChan ackChan -> do + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do deliveryTag <- assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" + assertNoEvent eventsChan sendAck ackChan deliveryTag assertNoEvent eventsChan @@ -37,40 +38,35 @@ testConsumeEventsOneWebSocket = do e %. "payload.0.type" `shouldMatch` "user.update" e %. "payload.0.user.handle" `shouldMatch` handle -testConsumeEventsNewWebSockets :: (HasCallStack) => App () -testConsumeEventsNewWebSockets = do +testConsumeEventsAcks :: (HasCallStack) => App () +testConsumeEventsAcks = do alice <- randomUser OwnDomain def client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - withNewWebSocket alice clientId $ \eventsChan ackChan -> do + withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + + -- without ack, we receive the same event again + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do deliveryTag <- assertEvent eventsChan $ \e -> do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" - -- if you close the WS in this line, the client-add message will remain - -- in the queue and will be received through the next WS connection, - -- before we are able to sne the Ack message sendAck ackChan deliveryTag - withNewWebSocket alice clientId $ \eventsChan _ -> do + withEventsWebSocket alice clientId $ \eventsChan _ -> do assertNoEvent eventsChan - handle <- randomHandle - putHandle alice handle >>= assertSuccess - - void $ withNewWebSocket alice clientId $ \eventsChan _ -> do - assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle - testPingPong :: (HasCallStack) => App () testPingPong = do alice <- randomUser OwnDomain def client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - withNewWebSocket alice clientId $ \eventsChan ackChan -> do + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do assertEvent eventsChan $ const $ pure () sendMsg ackChan $ object ["type" .= "ping"] assertEvent eventsChan $ \e -> e %. "type" `shouldMatch` "pong" @@ -78,8 +74,8 @@ testPingPong = do ---------------------------------------------------------------------- -- helpers -withNewWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a -withNewWebSocket uid cid f = do +withEventsWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a +withEventsWebSocket uid cid f = do bracket setup (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, _) -> do f eventsChan ackChan where From 67f91878792c1ea9bd843dac8edbfe3e4d4bfc50 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 8 Oct 2024 09:46:19 +0200 Subject: [PATCH 54/93] Remove ping-pong stuff. --- integration/test/Test/Events.hs | 11 -------- libs/wire-api/src/Wire/API/WebSocket.hs | 27 +++---------------- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 6 ----- 3 files changed, 4 insertions(+), 40 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 3f7eac031ce..ca1c8f90805 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -60,17 +60,6 @@ testConsumeEventsAcks = do withEventsWebSocket alice clientId $ \eventsChan _ -> do assertNoEvent eventsChan -testPingPong :: (HasCallStack) => App () -testPingPong = do - alice <- randomUser OwnDomain def - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client - - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - assertEvent eventsChan $ const $ pure () - sendMsg ackChan $ object ["type" .= "ping"] - assertEvent eventsChan $ \e -> e %. "type" `shouldMatch` "pong" - ---------------------------------------------------------------------- -- helpers diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/WebSocket.hs index 2b8cc328a4e..e3501688462 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/WebSocket.hs @@ -51,8 +51,6 @@ instance ToSchema EventData where data MessageServerToClient = EventMessage EventData - | PingDownMessage - | PongDownMessage deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform MessageServerToClient) @@ -60,8 +58,6 @@ makePrisms ''MessageServerToClient data MessageClientToServer = AckMessage AckData - | PingUpMessage - | PongUpMessage deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform MessageClientToServer) @@ -71,17 +67,12 @@ makePrisms ''MessageClientToServer -- ServerToClient -- | Local type, only needed for writing the ToSchema instance for 'MessageServerToClient'. -data MessageTypeServerToClient = MsgTypeEvent | MsgTypePingDown | MsgTypePongDown +data MessageTypeServerToClient = MsgTypeEvent deriving (Eq, Enum, Bounded) msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc MessageTypeServerToClient msgTypeSchemaServerToClient = - enum @Text "MessageTypeServerToClient" $ - mconcat $ - [ element "event" MsgTypeEvent, - element "ping" MsgTypePingDown, - element "pong" MsgTypePongDown - ] + enum @Text "MessageTypeServerToClient" $ mconcat $ [element "event" MsgTypeEvent] instance ToSchema MessageServerToClient where schema = @@ -90,8 +81,6 @@ instance ToSchema MessageServerToClient where where toTagged :: MessageServerToClient -> (MessageTypeServerToClient, MessageServerToClient) toTagged d@(EventMessage _) = (MsgTypeEvent, d) - toTagged d@PingDownMessage = (MsgTypePingDown, d) - toTagged d@PongDownMessage = (MsgTypePongDown, d) fromTagged :: (MessageTypeServerToClient, MessageServerToClient) -> MessageServerToClient fromTagged = snd @@ -99,8 +88,6 @@ instance ToSchema MessageServerToClient where untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeServerToClient) [A.Pair] (MessageServerToClient) (MessageServerToClient) untaggedSchema = dispatch $ \case MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) - MsgTypePingDown -> tag _PingDownMessage (id .= pure ()) - MsgTypePongDown -> tag _PongDownMessage (id .= pure ()) deriving via Schema MessageServerToClient instance FromJSON MessageServerToClient @@ -110,16 +97,14 @@ deriving via Schema MessageServerToClient instance ToJSON MessageServerToClient -- ClientToServer -- | Local type, only needed for writing the ToSchema instance for 'MessageClientToServer'. -data MessageTypeClientToServer = MsgTypeAck | MsgTypePingUp | MsgTypePongUp +data MessageTypeClientToServer = MsgTypeAck deriving (Eq, Enum, Bounded) msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc MessageTypeClientToServer msgTypeSchemaClientToServer = enum @Text "MessageTypeClientToServer" $ mconcat $ - [ element "ack" MsgTypeAck, - element "ping" MsgTypePingUp, - element "pong" MsgTypePongUp + [ element "ack" MsgTypeAck ] instance ToSchema MessageClientToServer where @@ -129,8 +114,6 @@ instance ToSchema MessageClientToServer where where toTagged :: MessageClientToServer -> (MessageTypeClientToServer, MessageClientToServer) toTagged d@(AckMessage _) = (MsgTypeAck, d) - toTagged d@PingUpMessage = (MsgTypePingUp, d) - toTagged d@PongUpMessage = (MsgTypePongUp, d) fromTagged :: (MessageTypeClientToServer, MessageClientToServer) -> MessageClientToServer fromTagged = snd @@ -138,8 +121,6 @@ instance ToSchema MessageClientToServer where untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeClientToServer) [A.Pair] MessageClientToServer MessageClientToServer untaggedSchema = dispatch $ \case MsgTypeAck -> tag _AckMessage (id .= field "data" schema) - MsgTypePingUp -> tag _PingUpMessage (id .= pure ()) - MsgTypePongUp -> tag _PongUpMessage (id .= pure ()) deriving via Schema MessageClientToServer instance FromJSON MessageClientToServer diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index d4967b5feaa..23fb419948c 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -5,7 +5,6 @@ import Cannon.WS import Control.Concurrent.Async (race) import Control.Exception (Handler (..), catch, catches, throwIO) import Data.Aeson -import Data.Aeson qualified as Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp @@ -75,11 +74,6 @@ rabbitMQWebSocketApp uid cid rConn e pendingConn = do Right (AckMessage ackData) -> do void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple wsReceiverLoop - Right PingUpMessage -> do - WS.sendBinaryData wsConn $ Aeson.encode @MessageServerToClient PongDownMessage - wsReceiverLoop - Right PongUpMessage -> - wsReceiverLoop wsReceiverLoop `catches` handlers data WebSocketServerError From 310732c6b08b2719658fea188f64e6788e31f256 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 8 Oct 2024 09:49:36 +0200 Subject: [PATCH 55/93] Revert "Maintain stable connection to rabbitmq from cannon. [WIP]" This reverts commit 861ee102beb5b065e98e58377cf6fc519e69e44b. problems with this approach: - there is a maximum number of chans / conn. - this is all very complicated and should be done separately. --- libs/extended/src/Network/AMQP/Extended.hs | 44 +++++-------------- services/cannon/src/Cannon/API/Public.hs | 3 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 19 +++----- services/cannon/src/Cannon/Run.hs | 7 +-- services/cannon/src/Cannon/Types.hs | 15 +++---- services/cannon/src/Cannon/WS.hs | 5 ++- 6 files changed, 30 insertions(+), 63 deletions(-) diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 62659bb3e48..055cdd57154 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -4,11 +4,7 @@ module Network.AMQP.Extended ( RabbitMqHooks (..), RabbitMqAdminOpts (..), AmqpEndpoint (..), - mkStableRabbitmqConn, - mkRabbitmqConn, - getStableRabbitmqConn, - taintStableRabbitmqConn, - stableRabbitmqConnRepairLoop, + withConnection, openConnectionWithRetries, mkRabbitMqAdminClientEnv, mkRabbitMqChannelMVar, @@ -150,11 +146,15 @@ data RabbitMqConnectionError = RabbitMqConnectionFailed String instance Exception RabbitMqConnectionError -mkStableRabbitmqConn :: (MonadIO m, MonadMask m) => Logger -> AmqpEndpoint -> m (MVar (Maybe Q.Connection)) -mkStableRabbitmqConn l ep = (newMVar . Just) =<< mkRabbitmqConn l ep - -mkRabbitmqConn :: (MonadIO m, MonadMask m) => Logger -> AmqpEndpoint -> m Q.Connection -mkRabbitmqConn l AmqpEndpoint {..} = do +-- | Connects with RabbitMQ and opens a channel. +withConnection :: + forall m a. + (MonadIO m, MonadMask m) => + Logger -> + AmqpEndpoint -> + (Q.Connection -> m a) -> + m a +withConnection l AmqpEndpoint {..} k = do (username, password) <- liftIO $ readCredsFromEnv -- Jittered exponential backoff with 1ms as starting delay and 1s as total -- wait time. @@ -173,7 +173,7 @@ mkRabbitmqConn l AmqpEndpoint {..} = do ) ( const $ do Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") - mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls -- TODO: error here is about ambiguous record fields i think? + mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls liftIO $ Q.openConnection'' $ Q.defaultConnectionOpts @@ -183,27 +183,7 @@ mkRabbitmqConn l AmqpEndpoint {..} = do Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings } ) - getConn - -getStableRabbitmqConn :: (MonadIO m) => MVar (Maybe Q.Connection) -> m (Maybe Q.Connection) -getStableRabbitmqConn = readMVar - -taintStableRabbitmqConn :: (MonadIO m) => MVar (Maybe Q.Connection) -> m () -taintStableRabbitmqConn mvar = void $ swapMVar mvar Nothing - --- | Keep an eye on the stableRabbitmqConnection. If it is tainted (eg., there is Nothing in --- it, see above), create a new one and put it. -stableRabbitmqConnRepairLoop :: (MonadMask m, MonadUnliftIO m) => Logger -> AmqpEndpoint -> MVar (Maybe Q.Connection) -> m (Async ()) -stableRabbitmqConnRepairLoop l ep mvar = async . forever $ do - mustRepair <- isNothing <$> readMVar mvar - if mustRepair - then do - -- TODO: this block should probably catch at least SomeException (and probably not SomeAsyncException. - conn <- mkRabbitmqConn l ep - void $ swapMVar mvar (Just conn) - threadDelay 1_800_000 -- if it fails, retry connecting every 1.8s - else do - threadDelay 100_000 -- checking for Nothing is very cheap, so it's ok to run this every 100ms. + bracket getConn (liftIO . Q.closeConnection) k -- | Connects with RabbitMQ and opens a channel. If the channel is closed for -- some reasons, reopens the channel. If the connection is closed for some diff --git a/services/cannon/src/Cannon/API/Public.hs b/services/cannon/src/Cannon/API/Public.hs index c301d69548f..e895429ae8b 100644 --- a/services/cannon/src/Cannon/API/Public.hs +++ b/services/cannon/src/Cannon/API/Public.hs @@ -45,5 +45,4 @@ streamData userId connId clientId con = do consumeEvents :: UserId -> ClientId -> PendingConnection -> Cannon () consumeEvents userId clientId con = do e <- wsenv - r <- stableRabbitmqConn - liftIO $ rabbitMQWebSocketApp userId clientId r e con + liftIO $ rabbitMQWebSocketApp userId clientId e con diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 23fb419948c..e37cb3f676f 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -8,26 +8,20 @@ import Data.Aeson import Data.Id import Imports import Network.AMQP qualified as Amqp -import Network.AMQP.Extended (getStableRabbitmqConn) +import Network.AMQP.Extended (withConnection) import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log import Wire.API.Notification import Wire.API.WebSocket -rabbitMQWebSocketApp :: UserId -> ClientId -> MVar (Maybe Amqp.Connection) -> Env -> ServerApp -rabbitMQWebSocketApp uid cid rConn e pendingConn = do +rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp +rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) closeWS <- newEmptyMVar - - do - -- FUTUREWORK: we pool connections, but not channels. however, channel pooling is also a - -- thing! we should generate some performance data using otel and decide whether we want - -- to do it. - -- https://stackoverflow.com/questions/10365867/how-can-i-pool-channels-in-rabbitmq - mConn <- getStableRabbitmqConn rConn - chan <- maybe (throwIO ConnectionClosed) Amqp.openChannel mConn - + -- TODO: Don't create new conns for every client, this will definitely kill rabbit + withConnection e.logg e.rabbitmq $ \conn -> do + chan <- Amqp.openChannel conn -- TODO: should we open a channel for every request? or have a pool of them? let handleConsumerError :: (Exception e) => e -> IO () handleConsumerError err = do Log.err e.logg $ @@ -40,7 +34,6 @@ rabbitMQWebSocketApp uid cid rConn e pendingConn = do handleConnectionClosed :: ConnectionException -> IO () handleConnectionClosed err = do - -- TODO: extract "Log.msg ..." into helper function. don't say "pushing" in pulling exceptions. make everything nicer. Log.info e.logg $ Log.msg (Log.val "Pushing to WS failed, closing connection") . Log.field "error" (displayException err) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index ec5e294d818..1905f7ae70b 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -42,7 +42,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Imports hiding (head, threadDelay) import Network.AMQP -import Network.AMQP.Extended (mkRabbitMqChannelMVar, mkStableRabbitmqConn, stableRabbitmqConnRepairLoop) +import Network.AMQP.Extended (mkRabbitMqChannelMVar) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Middleware.Gzip qualified as Gzip @@ -75,15 +75,13 @@ run o = withTracer \tracer -> do error "drainOpts.gracePeriodSeconds must not be set to 0." ext <- loadExternal g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) - rabbitConn <- mkStableRabbitmqConn g (o ^. Cannon.Options.rabbitmq) - rabbitRepairLoop <- stableRabbitmqConnRepairLoop g (o ^. Cannon.Options.rabbitmq) rabbitConn e <- mkEnv ext o g <$> D.empty 128 <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom <*> mkClock - <*> pure rabbitConn + <*> pure (o ^. Cannon.Options.rabbitmq) createUserNotificationsExchange $ applog e refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) @@ -112,7 +110,6 @@ run o = withTracer \tracer -> do -- but it's a sensitive change, and it looks like this is closing all the websockets at -- the same time and then calling the drain script. I suspect this might be due to some -- cleanup in wai. this needs to be tested very carefully when touched. - Async.cancel rabbitRepairLoop Async.cancel refreshMetricsThread L.close (applog e) where diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index 12b94833135..e1da89a70af 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -20,7 +20,6 @@ module Cannon.Types ( Env, opts, - stableRabbitmqConn, applog, dict, env, @@ -46,7 +45,7 @@ import Control.Monad.Catch import Data.Id import Data.Text.Encoding import Imports -import Network.AMQP (Connection) +import Network.AMQP.Extended (AmqpEndpoint) import Prometheus import Servant qualified import System.Logger qualified as Logger @@ -61,7 +60,6 @@ data Env = Env applog :: !Logger, dict :: !(Dict Key Websocket), reqId :: !RequestId, - stableRabbitmqConn_ :: MVar (Maybe Connection), env :: !WS.Env } @@ -102,11 +100,11 @@ mkEnv :: Manager -> GenIO -> Clock -> - MVar (Maybe Connection) -> + AmqpEndpoint -> Env -mkEnv external o l d p g t stableRabbit = - Env o l d (RequestId defRequestId) stableRabbit $ - WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) +mkEnv external o l d p g t rabbitmqOpts = + Env o l d (RequestId defRequestId) $ + WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) rabbitmqOpts runCannon :: Env -> Cannon a -> IO a runCannon e c = runReaderT (unCannon c) e @@ -120,9 +118,6 @@ wsenv = Cannon $ do r <- asks reqId pure $ WS.setRequestId r e -stableRabbitmqConn :: Cannon (MVar (Maybe Connection)) -stableRabbitmqConn = Cannon $ asks stableRabbitmqConn_ - -- | Natural transformation from 'Cannon' to 'Handler' monad. -- Used to call 'Cannon' from servant. runCannonToServant :: Cannon.Types.Env -> Cannon x -> Servant.Handler x diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index 23a9b3c7cc1..ae3cfd82bd1 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -67,6 +67,7 @@ import Data.List.Extra (chunksOf) import Data.Text.Encoding (decodeUtf8) import Data.Timeout (TimeoutUnit (..), (#)) import Imports hiding (threadDelay) +import Network.AMQP.Extended import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai.Utilities.Error @@ -145,7 +146,8 @@ data Env = Env dict :: !(Dict Key Websocket), rand :: !GenIO, clock :: !Clock, - drainOpts :: DrainOpts + drainOpts :: DrainOpts, + rabbitmq :: !AmqpEndpoint } setRequestId :: RequestId -> Env -> Env @@ -191,6 +193,7 @@ env :: GenIO -> Clock -> DrainOpts -> + AmqpEndpoint -> Env env leh lp gh gp = Env leh lp (Bilge.host gh . Bilge.port gp $ empty) (RequestId defRequestId) From f451f8982bee436092fb02d37d5a3bcdf182f778 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 8 Oct 2024 10:10:06 +0200 Subject: [PATCH 56/93] Test multiple acks and out of order acks --- integration/test/Test/Events.hs | 75 +++++++++++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 4 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index ca1c8f90805..55221c3dc15 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -28,7 +28,7 @@ testConsumeEventsOneWebSocket = do e %. "delivery_tag" assertNoEvent eventsChan - sendAck ackChan deliveryTag + sendAck ackChan deliveryTag False assertNoEvent eventsChan handle <- randomHandle @@ -55,7 +55,65 @@ testConsumeEventsAcks = do e %. "payload.0.type" `shouldMatch` "user.client-add" e %. "payload.0.client.id" `shouldMatch` clientId e %. "delivery_tag" - sendAck ackChan deliveryTag + sendAck ackChan deliveryTag False + + withEventsWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan + +testConsumeEventsMultipleAcks :: (HasCallStack) => App () +testConsumeEventsMultipleAcks = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + handle <- randomHandle + putHandle alice handle >>= assertSuccess + + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + + deliveryTag <- assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle + e %. "delivery_tag" + + sendAck ackChan deliveryTag True + + withEventsWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan + +testConsumeEventsAckNewEventWithoutAckingOldOne :: (HasCallStack) => App () +testConsumeEventsAckNewEventWithoutAckingOldOne = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + handle <- randomHandle + putHandle alice handle >>= assertSuccess + + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + + deliveryTagHandleAdd <- assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.update" + e %. "payload.0.user.handle" `shouldMatch` handle + e %. "delivery_tag" + + -- Only ack the handle add delivery tag + sendAck ackChan deliveryTagHandleAdd False + + -- Expect client-add event to be delivered again. + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTagClientAdd <- assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" + + sendAck ackChan deliveryTagClientAdd False withEventsWebSocket alice clientId $ \eventsChan _ -> do assertNoEvent eventsChan @@ -77,8 +135,17 @@ withEventsWebSocket uid cid f = do sendMsg :: (HasCallStack) => TChan Value -> Value -> App () sendMsg eventsChan msg = liftIO $ atomically $ writeTChan eventsChan msg -sendAck :: (HasCallStack) => TChan Value -> Value -> App () -sendAck ackChan deliveryTag = sendMsg ackChan $ object ["type" .= "ack", "data" .= object ["delivery_tag" .= deliveryTag, "multiple" .= False]] +sendAck :: (HasCallStack) => TChan Value -> Value -> Bool -> App () +sendAck ackChan deliveryTag multiple = + sendMsg ackChan + $ object + [ "type" .= "ack", + "data" + .= object + [ "delivery_tag" .= deliveryTag, + "multiple" .= multiple + ] + ] assertEvent :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a assertEvent eventsChan expectations = do From bd4adb2d83421ef9021cff42de95c341c0d00511 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 8 Oct 2024 12:29:32 +0200 Subject: [PATCH 57/93] cannon: Refactor code a little and more logging --- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 137 ++++++++++++------ 1 file changed, 89 insertions(+), 48 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index e37cb3f676f..1c88a5dc148 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -18,56 +18,103 @@ import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - closeWS <- newEmptyMVar -- TODO: Don't create new conns for every client, this will definitely kill rabbit withConnection e.logg e.rabbitmq $ \conn -> do chan <- Amqp.openChannel conn -- TODO: should we open a channel for every request? or have a pool of them? - let handleConsumerError :: (Exception e) => e -> IO () - handleConsumerError err = do + closeWS <- newEmptyMVar + amqpConsumerTag <- startWsSender wsConn chan closeWS + wsReceiverLoop wsConn chan closeWS amqpConsumerTag + where + logClient = + Log.field "user" (idToText uid) + . Log.field "client" (clientToText cid) + + pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () + pushEventsToWS wsConn (msg, envelope) = + case eitherDecode @Value msg.msgBody of + Left err -> do Log.err e.logg $ - Log.msg (Log.val "Pushing to WS failed, closing connection") - . Log.field "error" (displayException err) - . Log.field "user" (idToText uid) - . Log.field "client" (clientToText cid) - void $ tryPutMVar closeWS () - throwIO err + Log.msg (Log.val "failed to decode event from the queue as a JSON") + . logClient + . Log.field "parse_error" err + -- TODO: Make it a nicer exception + error err + Right payload -> do + WS.sendBinaryData wsConn . encode $ + object + [ "payload" .= payload, + "delivery_tag" .= envelope.envDeliveryTag + ] + + startWsSender :: Connection -> Amqp.Channel -> MVar () -> IO Amqp.ConsumerTag + startWsSender wsConn chan closeWS = do + let handleException :: (Exception e) => e -> IO () + handleException err = do + Log.err e.logg $ + Log.msg (Log.val "Pushing to WS failed, closing connection") + . Log.field "error" (displayException err) + . logClient + void $ tryPutMVar closeWS () + throwIO err - handleConnectionClosed :: ConnectionException -> IO () - handleConnectionClosed err = do - Log.info e.logg $ - Log.msg (Log.val "Pushing to WS failed, closing connection") - . Log.field "error" (displayException err) - . Log.field "user" (idToText uid) - . Log.field "client" (clientToText cid) - void $ tryPutMVar closeWS () + exceptionHandlers = + [ Handler $ handleException @SomeException, + Handler $ handleException @SomeAsyncException + ] - handlers = - [ Handler $ handleConnectionClosed, - Handler $ handleConsumerError @SomeException, - Handler $ handleConsumerError @SomeAsyncException - ] - qName = clientNotificationQueueName uid cid + qName = clientNotificationQueueName uid cid - _consumerTag <- - Amqp.consumeMsgs chan qName Amqp.Ack (\msg -> pushEventsToWS wsConn msg `catches` handlers) + Amqp.consumeMsgs chan qName Amqp.Ack $ \msg -> + pushEventsToWS wsConn msg `catches` exceptionHandlers - let wsReceiverLoop = do - eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) -- no timeout necessary here, we want to keep running forever. - case eitherData of - Left () -> do - Log.info e.logg $ - Log.msg (Log.val "gracefully closing websocket") - . Log.field "user" (idToText uid) - . Log.field "client" (clientToText cid) - WS.sendClose wsConn ("goaway" :: ByteString) - Right dat -> case eitherDecode @MessageClientToServer dat of - Left err -> do - WS.sendClose wsConn ("invalid-message" :: ByteString) - throwIO $ FailedToParseClientMessage err - Right (AckMessage ackData) -> do - void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple - wsReceiverLoop - wsReceiverLoop `catches` handlers + wsReceiverLoop :: Connection -> Amqp.Channel -> MVar () -> Amqp.ConsumerTag -> IO () + wsReceiverLoop wsConn chan closeWS amqpConsumerTag = do + let handleConnectionClosed :: ConnectionException -> IO () + handleConnectionClosed err = do + Log.info e.logg $ + Log.msg (Log.val "Websocket connection closed") + . Log.field "error" (displayException err) + . logClient + Amqp.cancelConsumer chan amqpConsumerTag + handleException :: (Exception e) => e -> IO () + handleException err = do + Log.info e.logg $ + Log.msg (Log.val "Unexpected exception in receive loop") + . Log.field "error" (displayException err) + . logClient + Amqp.cancelConsumer chan amqpConsumerTag + throwIO err + exceptionHandlers = + [ Handler $ handleConnectionClosed, + Handler $ handleException @SomeException, + Handler $ handleException @SomeAsyncException + ] + let loop = do + -- no timeout necessary here, we want to keep running forever. + eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) + case eitherData of + Left () -> do + Log.info e.logg $ + Log.msg (Log.val "gracefully closing websocket") + . logClient + -- Look at the status codes: https://datatracker.ietf.org/doc/html/rfc6455#section-7.4 + WS.sendClose wsConn ("goaway" :: ByteString) + Right dat -> case eitherDecode @MessageClientToServer dat of + Left err -> do + Log.info e.logg $ + Log.msg (Log.val "log failed to parse received message, gracefully closing websocket") + . logClient + WS.sendClose wsConn ("invalid-message" :: ByteString) + throwIO $ FailedToParseClientMessage err + Right (AckMessage ackData) -> do + Log.debug e.logg $ + Log.msg (Log.val "Received ACK") + . Log.field "delivery_tag" ackData.deliveryTag + . Log.field "multiple" ackData.multiple + . logClient + void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + loop + loop `catches` exceptionHandlers data WebSocketServerError = FailedToParseClientMessage String @@ -75,9 +122,3 @@ data WebSocketServerError deriving (Show) instance Exception WebSocketServerError - -pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () -pushEventsToWS wsConn (msg, envelope) = - case eitherDecode @Value msg.msgBody of - Left e -> error e - Right payload -> WS.sendBinaryData wsConn (encode $ object ["payload" .= payload, "delivery_tag" .= envelope.envDeliveryTag]) From 0c9eadd6dba376da17e00246d806918b3393b960 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 8 Oct 2024 12:29:59 +0200 Subject: [PATCH 58/93] integration: Deal with events websocket more gracefully, ensure all acks are sent --- integration/test/Test/Events.hs | 76 ++++++++++++++++++++++----------- 1 file changed, 50 insertions(+), 26 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 55221c3dc15..7fdecd131aa 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -3,17 +3,16 @@ module Test.Events where import API.Brig import API.BrigCommon import API.Common -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TChan +import Control.Retry import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import Data.String.Conversions (cs) -import qualified Network.WebSockets.Client as WS -import qualified Network.WebSockets.Connection as WS +import qualified Data.Text as Text +import qualified Network.WebSockets as WS import SetupHelpers import Testlib.Prelude hiding (assertNoEvent) -import UnliftIO (Async, async, bracket, cancel, race, waitAny) -import UnliftIO.Concurrent (threadDelay) +import Testlib.Printing +import UnliftIO hiding (handle) testConsumeEventsOneWebSocket :: (HasCallStack) => App () testConsumeEventsOneWebSocket = do @@ -122,21 +121,40 @@ testConsumeEventsAckNewEventWithoutAckingOldOne = do -- helpers withEventsWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a -withEventsWebSocket uid cid f = do - bracket setup (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, _) -> do - f eventsChan ackChan +withEventsWebSocket uid cid k = do + closeWS <- newEmptyMVar + bracket (setup closeWS) (\(_, _, wsThread) -> cancel wsThread) $ \(eventsChan, ackChan, wsThread) -> do + x <- k eventsChan ackChan + + -- Ensure all the acks are sent before closing the websocket + isAckChanEmpty <- + retrying + (limitRetries 5 <> constantDelay 10_000) + (\_ isEmpty -> pure $ not isEmpty) + (\_ -> atomically $ isEmptyTChan ackChan) + unless isAckChanEmpty $ do + putStrLn $ colored yellow $ "The ack chan is not empty after 50ms, some acks may not make it to the server" + + void $ tryPutMVar closeWS () + + timeout 1_000_000 (wait wsThread) >>= \case + Nothing -> + putStrLn $ colored yellow $ "The websocket thread did not close after waiting for 1s" + Just () -> pure () + + pure x where - setup :: (HasCallStack) => App (TChan Value, TChan Value, Async ()) - setup = do + setup :: (HasCallStack) => MVar () -> App (TChan Value, TChan Value, Async ()) + setup closeWS = do (eventsChan, ackChan) <- liftIO $ (,) <$> newTChanIO <*> newTChanIO - wsThread <- eventsWebSocket uid cid eventsChan ackChan + wsThread <- eventsWebSocket uid cid eventsChan ackChan closeWS pure (eventsChan, ackChan, wsThread) sendMsg :: (HasCallStack) => TChan Value -> Value -> App () sendMsg eventsChan msg = liftIO $ atomically $ writeTChan eventsChan msg sendAck :: (HasCallStack) => TChan Value -> Value -> Bool -> App () -sendAck ackChan deliveryTag multiple = +sendAck ackChan deliveryTag multiple = do sendMsg ackChan $ object [ "type" .= "ack", @@ -149,37 +167,43 @@ sendAck ackChan deliveryTag multiple = assertEvent :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a assertEvent eventsChan expectations = do - mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - case mEvent of - Left () -> assertFailure "No event received for 1s" - Right e -> expectations e + timeout 1_000_000 (atomically (readTChan eventsChan)) >>= \case + Nothing -> assertFailure "No event received for 1s" + Just e -> expectations e assertNoEvent :: (HasCallStack) => TChan Value -> App () assertNoEvent eventsChan = do - mEvent <- race (threadDelay 1_000_000) (liftIO $ atomically (readTChan eventsChan)) - case mEvent of - Left () -> pure () - Right e -> assertFailure $ "Did not expect event: " <> cs (A.encode e) + timeout 1_000_000 (atomically (readTChan eventsChan)) >>= \case + Nothing -> pure () + Just e -> assertFailure $ "Did not expect event: " <> cs (A.encode e) -eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> App (Async ()) -eventsWebSocket user clientId eventsChan ackChan = do +eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> MVar () -> App (Async ()) +eventsWebSocket user clientId eventsChan ackChan closeWS = do serviceMap <- getServiceMap =<< objDomain user uid <- objId =<< objQidObject user let HostPort caHost caPort = serviceHostPort serviceMap Cannon path = "/events?client=" <> clientId caHdrs = [(fromString "Z-User", toByteString' uid)] app conn = do - r <- async $ wsRead conn + r <- + async $ wsRead conn `catch` \(e :: WS.ConnectionException) -> + case e of + WS.CloseRequest {} -> pure () + _ -> throwIO e w <- async $ wsWrite conn void $ waitAny [r, w] + wsRead conn = forever $ do bs <- WS.receiveData conn case decodeStrict' bs of Just n -> atomically $ writeTChan eventsChan n Nothing -> putStrLn $ "Failed to decode events: " ++ show bs + wsWrite conn = forever $ do - ack <- atomically $ readTChan ackChan - WS.sendBinaryData conn (encode ack) + eitherAck <- race (readMVar closeWS) (atomically $ readTChan ackChan) + case eitherAck of + Left () -> WS.sendClose conn (Text.pack "") + Right ack -> WS.sendBinaryData conn (encode ack) liftIO $ async $ WS.runClientWith From df36aee43b25cb0470e3f21b15e6618d15c422b5 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 8 Oct 2024 17:09:49 +0200 Subject: [PATCH 59/93] cannon: Easier to understand cleanup code --- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 54 +++++++++++-------- 1 file changed, 32 insertions(+), 22 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 1c88a5dc148..ef801bb93c0 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -3,7 +3,7 @@ module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) import Cannon.WS import Control.Concurrent.Async (race) -import Control.Exception (Handler (..), catch, catches, throwIO) +import Control.Exception (Handler (..), bracket, catch, catches, throwIO) import Data.Aeson import Data.Id import Imports @@ -18,12 +18,12 @@ import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - -- TODO: Don't create new conns for every client, this will definitely kill rabbit + -- FUTUREWORK: Pool connections withConnection e.logg e.rabbitmq $ \conn -> do - chan <- Amqp.openChannel conn -- TODO: should we open a channel for every request? or have a pool of them? - closeWS <- newEmptyMVar - amqpConsumerTag <- startWsSender wsConn chan closeWS - wsReceiverLoop wsConn chan closeWS amqpConsumerTag + bracket (Amqp.openChannel conn) (Amqp.closeChannel) $ \chan -> do + closeWS <- newEmptyMVar + bracket (startWsSender wsConn chan closeWS) (Amqp.cancelConsumer chan) $ \_ -> do + wsReceiverLoop wsConn chan closeWS where logClient = Log.field "user" (idToText uid) @@ -67,42 +67,52 @@ rabbitMQWebSocketApp uid cid e pendingConn = do Amqp.consumeMsgs chan qName Amqp.Ack $ \msg -> pushEventsToWS wsConn msg `catches` exceptionHandlers - wsReceiverLoop :: Connection -> Amqp.Channel -> MVar () -> Amqp.ConsumerTag -> IO () - wsReceiverLoop wsConn chan closeWS amqpConsumerTag = do + wsReceiverLoop :: Connection -> Amqp.Channel -> MVar () -> IO () + wsReceiverLoop wsConn chan closeWS = do let handleConnectionClosed :: ConnectionException -> IO () - handleConnectionClosed err = do - Log.info e.logg $ - Log.msg (Log.val "Websocket connection closed") - . Log.field "error" (displayException err) - . logClient - Amqp.cancelConsumer chan amqpConsumerTag + handleConnectionClosed connException = do + case connException of + CloseRequest code reason -> + Log.debug e.logg $ + Log.msg (Log.val "Client requested to close connection") + . Log.field "status_code" code + . Log.field "reason" reason + . logClient + ConnectionClosed -> + Log.info e.logg $ + Log.msg (Log.val "client closed tcp connection abruptly") + . logClient + _ -> do + Log.info e.logg $ + Log.msg (Log.val "failed to receive message, closing websocket") + . Log.field "error" (displayException connException) + . logClient + WS.send wsConn (WS.ControlMessage $ WS.Close 1003 "failed-to-parse") handleException :: (Exception e) => e -> IO () handleException err = do - Log.info e.logg $ + Log.err e.logg $ Log.msg (Log.val "Unexpected exception in receive loop") . Log.field "error" (displayException err) . logClient - Amqp.cancelConsumer chan amqpConsumerTag throwIO err exceptionHandlers = [ Handler $ handleConnectionClosed, Handler $ handleException @SomeException, Handler $ handleException @SomeAsyncException ] - let loop = do + loop = do -- no timeout necessary here, we want to keep running forever. eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) case eitherData of Left () -> do - Log.info e.logg $ - Log.msg (Log.val "gracefully closing websocket") + Log.debug e.logg $ + Log.msg (Log.val "closing the websocket") . logClient - -- Look at the status codes: https://datatracker.ietf.org/doc/html/rfc6455#section-7.4 - WS.sendClose wsConn ("goaway" :: ByteString) + WS.sendClose wsConn ("" :: ByteString) Right dat -> case eitherDecode @MessageClientToServer dat of Left err -> do Log.info e.logg $ - Log.msg (Log.val "log failed to parse received message, gracefully closing websocket") + Log.msg (Log.val "failed to parse received message, closing websocket") . logClient WS.sendClose wsConn ("invalid-message" :: ByteString) throwIO $ FailedToParseClientMessage err From f7cb1be75492965ad81e80636b3c6f0bbe9d0031 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 8 Oct 2024 17:31:49 +0200 Subject: [PATCH 60/93] Add TODO for tomorrow --- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index ef801bb93c0..8a554c5cb59 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -37,8 +37,8 @@ rabbitMQWebSocketApp uid cid e pendingConn = do Log.msg (Log.val "failed to decode event from the queue as a JSON") . logClient . Log.field "parse_error" err - -- TODO: Make it a nicer exception - error err + -- TODO: reject this event so it doesn't keep reappearing, test it somehow? + throwIO $ FailedToParseEvent err Right payload -> do WS.sendBinaryData wsConn . encode $ object @@ -128,7 +128,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do data WebSocketServerError = FailedToParseClientMessage String - | ClientSentAnEvent EventData + | FailedToParseEvent String deriving (Show) instance Exception WebSocketServerError From d329c79f4c3aa2359777a7687a47d1b270954ca2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 09:07:29 +0200 Subject: [PATCH 61/93] cannon: Ensure invalid messages don't accumulate --- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 8a554c5cb59..c3a5a877384 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -37,8 +37,15 @@ rabbitMQWebSocketApp uid cid e pendingConn = do Log.msg (Log.val "failed to decode event from the queue as a JSON") . logClient . Log.field "parse_error" err - -- TODO: reject this event so it doesn't keep reappearing, test it somehow? - throwIO $ FailedToParseEvent err + -- This message cannot be parsed, make sure it doesn't requeue. There + -- is no need to throw an error and kill the websocket as this is + -- probably caused by a bug or someone messing with RabbitMQ. + -- + -- The bug case is slightly dangerous as it could drop a lot of events + -- en masse, if at some point we decide that Events should not be + -- pushed as JSONs, hopefully we think of the parsing side if/when + -- that happens. + Amqp.rejectEnv envelope False Right payload -> do WS.sendBinaryData wsConn . encode $ object @@ -128,7 +135,6 @@ rabbitMQWebSocketApp uid cid e pendingConn = do data WebSocketServerError = FailedToParseClientMessage String - | FailedToParseEvent String deriving (Show) instance Exception WebSocketServerError From 21444ee68a1c58e04d56bfcd97e2e0e0ea8691ac Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 09:49:08 +0200 Subject: [PATCH 62/93] small re-org of code --- integration/test/Testlib/ModService.hs | 2 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 70 +++++++++---------- 2 files changed, 36 insertions(+), 36 deletions(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 057559d2ed2..e6a12582f23 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -220,7 +220,7 @@ startDynamicBackend resource beOverrides = do def { sparCfg = setField "saml.logLevel" ("Warn" :: String), brigCfg = setField "logLevel" ("Warn" :: String), - cannonCfg = setField "logLevel" ("Warn" :: String), + cannonCfg = setField "logLevel" ("Debug" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), gundeckCfg = setField "logLevel" ("Warn" :: String), diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index c3a5a877384..bb15c52fc58 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -71,12 +71,37 @@ rabbitMQWebSocketApp uid cid e pendingConn = do qName = clientNotificationQueueName uid cid - Amqp.consumeMsgs chan qName Amqp.Ack $ \msg -> - pushEventsToWS wsConn msg `catches` exceptionHandlers + Amqp.consumeMsgs chan qName Amqp.Ack $ \msgWithEnv -> + pushEventsToWS wsConn msgWithEnv `catches` exceptionHandlers wsReceiverLoop :: Connection -> Amqp.Channel -> MVar () -> IO () wsReceiverLoop wsConn chan closeWS = do - let handleConnectionClosed :: ConnectionException -> IO () + let loop = do + -- no timeout necessary here, we want to keep running forever. + eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) + case eitherData of + Left () -> do + Log.debug e.logg $ + Log.msg (Log.val "Closing the websocket") + . logClient + WS.sendClose wsConn ("" :: ByteString) + Right dat -> case eitherDecode @MessageClientToServer dat of + Left err -> do + Log.info e.logg $ + Log.msg (Log.val "Failed to parse received message, closing websocket") + . logClient + WS.sendCloseCode wsConn 1003 ("failed-to-parse" :: ByteString) + throwIO $ FailedToParseClientMessage err + Right (AckMessage ackData) -> do + Log.debug e.logg $ + Log.msg (Log.val "Received ACK") + . Log.field "delivery_tag" ackData.deliveryTag + . Log.field "multiple" ackData.multiple + . logClient + void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple + loop + + handleConnectionClosed :: ConnectionException -> IO () handleConnectionClosed connException = do case connException of CloseRequest code reason -> @@ -87,11 +112,11 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . logClient ConnectionClosed -> Log.info e.logg $ - Log.msg (Log.val "client closed tcp connection abruptly") + Log.msg (Log.val "Client closed tcp connection abruptly") . logClient _ -> do Log.info e.logg $ - Log.msg (Log.val "failed to receive message, closing websocket") + Log.msg (Log.val "Failed to receive message, closing websocket") . Log.field "error" (displayException connException) . logClient WS.send wsConn (WS.ControlMessage $ WS.Close 1003 "failed-to-parse") @@ -102,36 +127,11 @@ rabbitMQWebSocketApp uid cid e pendingConn = do . Log.field "error" (displayException err) . logClient throwIO err - exceptionHandlers = - [ Handler $ handleConnectionClosed, - Handler $ handleException @SomeException, - Handler $ handleException @SomeAsyncException - ] - loop = do - -- no timeout necessary here, we want to keep running forever. - eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) - case eitherData of - Left () -> do - Log.debug e.logg $ - Log.msg (Log.val "closing the websocket") - . logClient - WS.sendClose wsConn ("" :: ByteString) - Right dat -> case eitherDecode @MessageClientToServer dat of - Left err -> do - Log.info e.logg $ - Log.msg (Log.val "failed to parse received message, closing websocket") - . logClient - WS.sendClose wsConn ("invalid-message" :: ByteString) - throwIO $ FailedToParseClientMessage err - Right (AckMessage ackData) -> do - Log.debug e.logg $ - Log.msg (Log.val "Received ACK") - . Log.field "delivery_tag" ackData.deliveryTag - . Log.field "multiple" ackData.multiple - . logClient - void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple - loop - loop `catches` exceptionHandlers + loop + `catches` [ Handler $ handleConnectionClosed, + Handler $ handleException @SomeException, + Handler $ handleException @SomeAsyncException + ] data WebSocketServerError = FailedToParseClientMessage String From 0943ec95678b4334ff20419fff4834991f91912d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 14:16:21 +0200 Subject: [PATCH 63/93] Avoid using unsafeRange --- libs/types-common/src/Data/Range.hs | 38 ++++++++++++++++++++++- services/gundeck/src/Gundeck/Push.hs | 45 +++++++++++++++++++--------- 2 files changed, 68 insertions(+), 15 deletions(-) diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index c4401541756..45788db529b 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -27,6 +27,7 @@ module Data.Range ( Range, toRange, mapRange, + traverseRange, Within, Bounds (..), checked, @@ -42,9 +43,13 @@ module Data.Range rnil, rcons, (<|), + runcons, rinc, rappend, rsingleton, + rconcat, + rangeSetToList, + rangeListToSet, -- * 'Arbitrary' generators Ranged (..), @@ -86,6 +91,7 @@ import Data.Text qualified as T import Data.Text.Ascii (AsciiChar, AsciiChars, AsciiText, fromAsciiChars) import Data.Text.Ascii qualified as Ascii import Data.Text.Lazy qualified as TL +import Data.Type.Bool import Data.Type.Ord import GHC.TypeNats import Imports @@ -107,6 +113,10 @@ mapRange f (Range as) = Range (f `map` as) toRange :: (n <= x, x <= m, KnownNat x, Num a) => Proxy x -> Range n m a toRange = Range . fromIntegral . natVal +traverseRange :: (Traversable t, Applicative f) => (a -> f b) -> Range n m (t a) -> f (Range n m (t b)) +traverseRange f (Range xs) = + Range <$> traverse f xs + instance (Show a, Num a, Within a n m, KnownNat n, KnownNat m) => Bounded (Range n m a) where minBound = unsafeRange (fromKnownNat (Proxy @n) :: a) maxBound = unsafeRange (fromKnownNat (Proxy @m) :: a) @@ -308,13 +318,25 @@ rcast (Range a) = Range a rnil :: (Monoid a) => Range 0 0 a rnil = Range mempty -rcons, (<|) :: (n <= m) => a -> Range n m [a] -> Range n (m + 1) [a] +rcons, (<|) :: (n <= m) => a -> Range n m [a] -> Range (n + 1) (m + 1) [a] rcons a (Range aa) = Range (a : aa) infixr 5 <| (<|) = rcons +runcons :: + ( n <= m, + n' ~ If (n >=? 1) (n - 1) 0, + m' ~ If (m >=? 1) (m - 1) 0 + ) => + Range n m [a] -> + Maybe (a, Range n' m' [a]) +runcons r = + case fromRange r of + [] -> Nothing + (x : xs) -> Just (x, Range xs) + rinc :: (Integral a, n <= m) => Range n m a -> Range n (m + 1) a rinc (Range a) = Range (a + 1) @@ -330,6 +352,20 @@ rangedNumToParamSchema _ = & S.minimum_ ?~ fromKnownNat (Proxy @n) & S.maximum_ ?~ fromKnownNat (Proxy @m) +rconcat :: Range n m [Range 0 1 [a]] -> Range 0 m [a] +rconcat (Range rs) = Range $ concatMap fromRange rs + +-- | Going from a set to a List should keep the same range because the number of +-- elements cannot grow or shrink. +rangeSetToList :: Range n m (Set a) -> Range n m [a] +rangeSetToList = Range . Set.toList . fromRange + +-- | A list can only shrink when it is converted to a Set, so the min bound +-- changes to 0 if the list can be empty, otherwise the min bound is 1 as the +-- list is guaranteed to have at least 1 element. +rangeListToSet :: (If (n >=? 1) (n' ~ 1) (n' ~ 0), Ord a) => Range n m [a] -> Range n' m (Set a) +rangeListToSet = Range . Set.fromList . fromRange + ----------------------------------------------------------------------------- class Bounds a where diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 9f0d2e5b9ef..be11e0c1d4b 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -146,23 +146,39 @@ instance MonadMapAsync Gundeck where splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) splitPushes = fmap partitionHereThere . traverse splitPush -splitPush :: (MonadPushAll m) => Push -> m (These Push Push) +partitionHereThereRange :: Range 0 m [These a b] -> (Range 0 m [a], Range 0 m [b]) +partitionHereThereRange = + ((&&&) (rconcat . mapRange fst) (rconcat . mapRange snd)) + . mapRange partitionToRange + where + rsingleton0 :: forall x. x -> Range 0 1 [x] + rsingleton0 = rcast . rsingleton + + rnil1 :: forall x. Range 0 1 [x] + rnil1 = rcast rnil + + partitionToRange :: These a b -> (Range 0 1 [a], Range 0 1 [b]) + partitionToRange = \case + (This a) -> (rsingleton0 a, rnil1) + (That b) -> (rnil1, rsingleton0 b) + (These a b) -> (rsingleton0 a, rsingleton0 b) + +splitPush :: + (MonadPushAll m) => + Push -> + m (These Push Push) splitPush p = do - let allRecipients = Set.toList $ fromRange $ p._pushRecipients - (rabbitmqRecipients, legacyRecipients) <- partitionHereThere <$> traverse splitRecipient allRecipients - case (rabbitmqRecipients, legacyRecipients) of - ([], _) -> pure (That p) - (_, []) -> pure (This p) - (_ : _, _ : _) -> - -- Since we just proved that both the recipient lists are not empty and - -- they cannot be bigger than the limit as none of them can be bigger than - -- the original recipient set, it is safe to use unsafeRange here. - -- - -- TODO: See if there is a better way, so we don't have to use unsafeRange + (rabbitmqRecipients, legacyRecipients) <- + partitionHereThereRange . rcast @_ @_ @1024 + <$> traverseRange splitRecipient (rangeSetToList $ p._pushRecipients) + case (runcons rabbitmqRecipients, runcons legacyRecipients) of + (Nothing, _) -> pure (That p) + (_, Nothing) -> pure (This p) + (Just (rabbit0, rabbits), Just (legacy0, legacies)) -> pure $ These - p {_pushRecipients = unsafeRange $ Set.fromList rabbitmqRecipients} - p {_pushRecipients = unsafeRange $ Set.fromList legacyRecipients} + p {_pushRecipients = rangeListToSet $ rcons rabbit0 rabbits} + p {_pushRecipients = rangeListToSet $ rcons legacy0 legacies} -- TODO: optimize for possibility of many pushes having the same users splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) @@ -200,6 +216,7 @@ getClients uid = do error "something went wrong" Bilge.responseJsonError r +-- TODO: Delete this comment -- Old way: -- Client -> Cannon: establish WS (/await) -- Galley -> Gundeck -> Cannon -> Client : only if client is present on cannon From b438882a552f0f1ab999c7e920aae6ed0d63f95c Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 14:27:37 +0200 Subject: [PATCH 64/93] Reduce top level functions --- services/gundeck/src/Gundeck/Push.hs | 77 ++++++++++++++-------------- 1 file changed, 39 insertions(+), 38 deletions(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index be11e0c1d4b..4d2c08a90b9 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -146,23 +146,6 @@ instance MonadMapAsync Gundeck where splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) splitPushes = fmap partitionHereThere . traverse splitPush -partitionHereThereRange :: Range 0 m [These a b] -> (Range 0 m [a], Range 0 m [b]) -partitionHereThereRange = - ((&&&) (rconcat . mapRange fst) (rconcat . mapRange snd)) - . mapRange partitionToRange - where - rsingleton0 :: forall x. x -> Range 0 1 [x] - rsingleton0 = rcast . rsingleton - - rnil1 :: forall x. Range 0 1 [x] - rnil1 = rcast rnil - - partitionToRange :: These a b -> (Range 0 1 [a], Range 0 1 [b]) - partitionToRange = \case - (This a) -> (rsingleton0 a, rnil1) - (That b) -> (rnil1, rsingleton0 b) - (These a b) -> (rsingleton0 a, rsingleton0 b) - splitPush :: (MonadPushAll m) => Push -> @@ -179,29 +162,47 @@ splitPush p = do These p {_pushRecipients = rangeListToSet $ rcons rabbit0 rabbits} p {_pushRecipients = rangeListToSet $ rcons legacy0 legacies} + where + -- TODO: optimize for possibility of many pushes having the same users + splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) + splitRecipient rcpt = do + clientsFull <- mpaGetClients rcpt._recipientId + let allClients = Map.findWithDefault mempty rcpt._recipientId $ clientsFull.userClientsFull + let relevantClients = case rcpt._recipientClients of + RecipientClientsSome cs -> + Set.filter (\c -> c.clientId `elem` toList cs) allClients + RecipientClientsAll -> allClients + isClientForRabbitMq c = ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList + (rabbitmqClients, legacyClients) = Set.partition isClientForRabbitMq relevantClients + rabbitmqClientIds = (.clientId) <$> Set.toList rabbitmqClients + legacyClientIds = (.clientId) <$> Set.toList legacyClients + case (rabbitmqClientIds, legacyClientIds) of + ([], _) -> pure (That rcpt) + (_, []) -> pure (This rcpt) + (r : rs, l : ls) -> + pure $ + These + rcpt {_recipientClients = RecipientClientsSome $ list1 r rs} + rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} + + partitionHereThereRange :: Range 0 m [These a b] -> (Range 0 m [a], Range 0 m [b]) + partitionHereThereRange = + ((&&&) (rconcat . mapRange fst) (rconcat . mapRange snd)) + . mapRange partitionToRange + where + rsingleton0 :: forall x. x -> Range 0 1 [x] + rsingleton0 = rcast . rsingleton --- TODO: optimize for possibility of many pushes having the same users -splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) -splitRecipient rcpt = do - clientsFull <- mpaGetClients rcpt._recipientId - let allClients = Map.findWithDefault mempty rcpt._recipientId $ clientsFull.userClientsFull - let relevantClients = case rcpt._recipientClients of - RecipientClientsSome cs -> - Set.filter (\c -> c.clientId `elem` toList cs) allClients - RecipientClientsAll -> allClients - isClientForRabbitMq c = ClientSupportsConsumableNotifications `Set.member` c.clientCapabilities.fromClientCapabilityList - (rabbitmqClients, legacyClients) = Set.partition isClientForRabbitMq relevantClients - rabbitmqClientIds = (.clientId) <$> Set.toList rabbitmqClients - legacyClientIds = (.clientId) <$> Set.toList legacyClients - case (rabbitmqClientIds, legacyClientIds) of - ([], _) -> pure (That rcpt) - (_, []) -> pure (This rcpt) - (r : rs, l : ls) -> - pure $ - These - rcpt {_recipientClients = RecipientClientsSome $ list1 r rs} - rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} + rnil1 :: forall x. Range 0 1 [x] + rnil1 = rcast rnil + + partitionToRange :: These a b -> (Range 0 1 [a], Range 0 1 [b]) + partitionToRange = \case + (This a) -> (rsingleton0 a, rnil1) + (That b) -> (rnil1, rsingleton0 b) + (These a b) -> (rsingleton0 a, rsingleton0 b) +-- TODO: Move to some util module getClients :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => UserId -> m UserClientsFull getClients uid = do r <- do From 954b46630b023a446b04859f8fdbb62783611b3d Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 15:31:04 +0200 Subject: [PATCH 65/93] integration: Test that old and new clients can co-exist --- integration/test/Test/Events.hs | 48 +++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 7fdecd131aa..f7420afc40c 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -3,12 +3,14 @@ module Test.Events where import API.Brig import API.BrigCommon import API.Common +import API.Gundeck import Control.Retry import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') import Data.String.Conversions (cs) import qualified Data.Text as Text import qualified Network.WebSockets as WS +import Notifications (isUserClientAddNotif) import SetupHelpers import Testlib.Prelude hiding (assertNoEvent) import Testlib.Printing @@ -17,6 +19,12 @@ import UnliftIO hiding (handle) testConsumeEventsOneWebSocket :: (HasCallStack) => App () testConsumeEventsOneWebSocket = do alice <- randomUser OwnDomain def + + lastNotifId <- + getLastNotification alice def `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "id" & asString + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client @@ -37,6 +45,46 @@ testConsumeEventsOneWebSocket = do e %. "payload.0.type" `shouldMatch` "user.update" e %. "payload.0.user.handle" `shouldMatch` handle + -- No new notifications should be stored in Cassandra as the user doesn't have + -- any legacy clients + getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + shouldBeEmpty $ resp.json %. "notifications" + +testConsumeEventsWhileHavingLegacyClients :: (HasCallStack) => App () +testConsumeEventsWhileHavingLegacyClients = do + alice <- randomUser OwnDomain def + + -- Even if alice has no clients, the notifications should still be persisted + -- in Cassandra. This choice is kinda arbitrary as these notifications + -- probably don't mean much, however, it ensures backwards compatibility. + lastNotifId <- + getNotifications alice def `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "notifications.0.payload.0.type" `shouldMatch` "user.activate" + resp.json %. "has_more" `shouldMatch` False + resp.json %. "notifications.-1.id" & asString + + oldClient <- addClient alice def {acapabilities = Just []} >>= getJSON 201 + + withWebSocket (alice, "anything-but-conn", oldClient %. "id") $ \oldWS -> do + newClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + newClientId <- newClient %. "id" & asString + + oldNotif <- awaitMatch isUserClientAddNotif oldWS + oldNotif %. "payload.0.client.id" `shouldMatch` newClientId + + withEventsWebSocket alice newClientId $ \eventsChan _ -> + assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` newClientId + + -- All notifs are also in Cassandra because of the legacy client + getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "notifications.0.payload.0.type" `shouldMatch` "user.client-add" + resp.json %. "notifications.1.payload.0.type" `shouldMatch` "user.client-add" + testConsumeEventsAcks :: (HasCallStack) => App () testConsumeEventsAcks = do alice <- randomUser OwnDomain def From e18fbf4c624e6604ca777da76f74bce38bb2d01e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 16:08:49 +0200 Subject: [PATCH 66/93] gundeck: Optimize number of calls to brig --- libs/types-common/src/Data/Range.hs | 5 --- services/gundeck/src/Gundeck/Push.hs | 61 +++++++++++++++------------- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 45788db529b..87e550db0a2 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -27,7 +27,6 @@ module Data.Range ( Range, toRange, mapRange, - traverseRange, Within, Bounds (..), checked, @@ -113,10 +112,6 @@ mapRange f (Range as) = Range (f `map` as) toRange :: (n <= x, x <= m, KnownNat x, Num a) => Proxy x -> Range n m a toRange = Range . fromIntegral . natVal -traverseRange :: (Traversable t, Applicative f) => (a -> f b) -> Range n m (t a) -> f (Range n m (t b)) -traverseRange f (Range xs) = - Range <$> traverse f xs - instance (Show a, Num a, Within a n m, KnownNat n, KnownNat m) => Bounded (Range n m a) where minBound = unsafeRange (fromKnownNat (Proxy @n) :: a) maxBound = unsafeRange (fromKnownNat (Proxy @m) :: a) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 4d2c08a90b9..9bc014b31ae 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -95,7 +95,7 @@ class (MonadThrow m) => MonadPushAll m where mpaPushNative :: Notification -> Priority -> [Address] -> m () mpaForkIO :: m () -> m () mpaRunWithBudget :: Int -> a -> m a -> m a - mpaGetClients :: UserId -> m UserClientsFull + mpaGetClients :: Set UserId -> m UserClientsFull mpaPublishToRabbitMq :: Text -> Q.Message -> m () instance MonadPushAll Gundeck where @@ -144,31 +144,33 @@ instance MonadMapAsync Gundeck where Just chunkSize -> concat <$> mapM (mapAsync f) (List.chunksOf chunkSize l) splitPushes :: (MonadPushAll m) => [Push] -> m ([Push], [Push]) -splitPushes = fmap partitionHereThere . traverse splitPush +splitPushes ps = do + allUserClients <- mpaGetClients (Set.unions $ map (\p -> Set.map (._recipientId) $ p._pushRecipients.fromRange) ps) + pure . partitionHereThere $ map (splitPush allUserClients) ps +-- | Split a puish into rabbitmq and legacy push. This code exists to help with +-- migration. Once it is completed and old APIs are not supported anymore we can +-- assume everything is meant for RabbtiMQ and stop splitting. splitPush :: - (MonadPushAll m) => + UserClientsFull -> Push -> - m (These Push Push) -splitPush p = do - (rabbitmqRecipients, legacyRecipients) <- - partitionHereThereRange . rcast @_ @_ @1024 - <$> traverseRange splitRecipient (rangeSetToList $ p._pushRecipients) + These Push Push +splitPush clientsFull p = do + let (rabbitmqRecipients, legacyRecipients) = + partitionHereThereRange . rcast @_ @_ @1024 $ + mapRange splitRecipient (rangeSetToList $ p._pushRecipients) case (runcons rabbitmqRecipients, runcons legacyRecipients) of - (Nothing, _) -> pure (That p) - (_, Nothing) -> pure (This p) + (Nothing, _) -> (That p) + (_, Nothing) -> (This p) (Just (rabbit0, rabbits), Just (legacy0, legacies)) -> - pure $ - These - p {_pushRecipients = rangeListToSet $ rcons rabbit0 rabbits} - p {_pushRecipients = rangeListToSet $ rcons legacy0 legacies} + These + p {_pushRecipients = rangeListToSet $ rcons rabbit0 rabbits} + p {_pushRecipients = rangeListToSet $ rcons legacy0 legacies} where - -- TODO: optimize for possibility of many pushes having the same users - splitRecipient :: (MonadPushAll m) => Recipient -> m (These Recipient Recipient) + splitRecipient :: Recipient -> These Recipient Recipient splitRecipient rcpt = do - clientsFull <- mpaGetClients rcpt._recipientId let allClients = Map.findWithDefault mempty rcpt._recipientId $ clientsFull.userClientsFull - let relevantClients = case rcpt._recipientClients of + relevantClients = case rcpt._recipientClients of RecipientClientsSome cs -> Set.filter (\c -> c.clientId `elem` toList cs) allClients RecipientClientsAll -> allClients @@ -177,13 +179,17 @@ splitPush p = do rabbitmqClientIds = (.clientId) <$> Set.toList rabbitmqClients legacyClientIds = (.clientId) <$> Set.toList legacyClients case (rabbitmqClientIds, legacyClientIds) of - ([], _) -> pure (That rcpt) - (_, []) -> pure (This rcpt) + ([], _) -> + -- Checking for rabbitmqClientIds first ensures that we fall back to + -- old behaviour even if legacyClientIds is empty too. This way we + -- won't break things before clients are ready for it. + (That rcpt) + (_, []) -> + (This rcpt) (r : rs, l : ls) -> - pure $ - These - rcpt {_recipientClients = RecipientClientsSome $ list1 r rs} - rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} + These + rcpt {_recipientClients = RecipientClientsSome $ list1 r rs} + rcpt {_recipientClients = RecipientClientsSome $ list1 l ls} partitionHereThereRange :: Range 0 m [These a b] -> (Range 0 m [a], Range 0 m [b]) partitionHereThereRange = @@ -202,16 +208,15 @@ splitPush p = do (That b) -> (rnil1, rsingleton0 b) (These a b) -> (rsingleton0 a, rsingleton0 b) --- TODO: Move to some util module -getClients :: (MonadReader Env m, Bilge.MonadHttp m, MonadThrow m) => UserId -> m UserClientsFull -getClients uid = do +getClients :: Set UserId -> Gundeck UserClientsFull +getClients uids = do r <- do Endpoint h p <- view $ options . brig Bilge.post ( Bilge.host (toByteString' h) . Bilge.port p . Bilge.path "/i/clients/full" - . Bilge.json (UserSet $ Set.singleton uid) + . Bilge.json (UserSet uids) ) when (Bilge.statusCode r /= 200) $ do error "something went wrong" From 97ee4fbd6e03fc583d3aa9f0ab4bc04a4bf74234 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 16:21:58 +0200 Subject: [PATCH 67/93] gundeck: Try to not kill brig --- services/gundeck/src/Gundeck/Push.hs | 29 +++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 9bc014b31ae..b96ac1f1bcc 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -69,6 +69,7 @@ import Network.HTTP.Types import Network.Wai.Utilities import System.Logger.Class (msg, val, (+++), (.=), (~~)) import System.Logger.Class qualified as Log +import UnliftIO (pooledMapConcurrentlyN) import Util.Options import Wire.API.Internal.Notification import Wire.API.Notification (userNotificationExchangeName) @@ -210,17 +211,23 @@ splitPush clientsFull p = do getClients :: Set UserId -> Gundeck UserClientsFull getClients uids = do - r <- do - Endpoint h p <- view $ options . brig - Bilge.post - ( Bilge.host (toByteString' h) - . Bilge.port p - . Bilge.path "/i/clients/full" - . Bilge.json (UserSet uids) - ) - when (Bilge.statusCode r /= 200) $ do - error "something went wrong" - Bilge.responseJsonError r + fmap mconcat + . pooledMapConcurrentlyN 4 getBatch + . List.chunksOf 100 + $ Set.toList uids + where + getBatch :: [UserId] -> Gundeck UserClientsFull + getBatch uidsChunk = do + r <- do + Endpoint h p <- view $ options . brig + Bilge.post + ( Bilge.host (toByteString' h) + . Bilge.port p + . Bilge.path "/i/clients/full" + . Bilge.json (UserSet $ Set.fromList uidsChunk) + . Bilge.expect2xx + ) + Bilge.responseJsonError r -- TODO: Delete this comment -- Old way: From 98c8e582d65e9858992e627e2a776ca228fdacec Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 16:24:46 +0200 Subject: [PATCH 68/93] Fix typo --- services/gundeck/src/Gundeck/Push.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index b96ac1f1bcc..59910eab27c 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -149,7 +149,7 @@ splitPushes ps = do allUserClients <- mpaGetClients (Set.unions $ map (\p -> Set.map (._recipientId) $ p._pushRecipients.fromRange) ps) pure . partitionHereThere $ map (splitPush allUserClients) ps --- | Split a puish into rabbitmq and legacy push. This code exists to help with +-- | Split a push into rabbitmq and legacy push. This code exists to help with -- migration. Once it is completed and old APIs are not supported anymore we can -- assume everything is meant for RabbtiMQ and stop splitting. splitPush :: From 2c2d1a71394eedc03358aa913e6e7e090cfac392 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 17:05:15 +0200 Subject: [PATCH 69/93] gundeck: Remove pairing comment --- services/gundeck/src/Gundeck/Push.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 59910eab27c..c3e3cbba202 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -229,16 +229,6 @@ getClients uids = do ) Bilge.responseJsonError r --- TODO: Delete this comment --- Old way: --- Client -> Cannon: establish WS (/await) --- Galley -> Gundeck -> Cannon -> Client : only if client is present on cannon --- -> Cassandra : always write --- --- New way: --- Galley -> Gundeck -> RabbitMQ: Always Publish to queue --- Client -> Cannon -> RabbitMQ: establish WS and subscribe to the queue (/events) - pushAll :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m, Log.MonadLogger m) => [Push] -> m () pushAll pushes = do Log.debug $ msg (val "pushing") . Log.field "pushes" (Aeson.encode pushes) From 304886ba9c292b7b95c7bc7e11f426ab547b7c60 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Oct 2024 18:14:03 +0200 Subject: [PATCH 70/93] wire-api: Rename Wire.API.WebSocket -> Wire.API.Event.WebSocketProtocol --- .../Wire/API/{WebSocket.hs => Event/WebSocketProtocol.hs} | 7 +------ libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs | 6 +++--- libs/wire-api/wire-api.cabal | 2 +- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 2 +- 4 files changed, 6 insertions(+), 11 deletions(-) rename libs/wire-api/src/Wire/API/{WebSocket.hs => Event/WebSocketProtocol.hs} (94%) diff --git a/libs/wire-api/src/Wire/API/WebSocket.hs b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs similarity index 94% rename from libs/wire-api/src/Wire/API/WebSocket.hs rename to libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs index e3501688462..f62ec771119 100644 --- a/libs/wire-api/src/Wire/API/WebSocket.hs +++ b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs @@ -1,11 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} --- TODO: Rename this module to something that is more specific than "websocket". --- - "Wire.API.Event.WebSocket"? --- - "Wire.API.Event.ClientChan"? --- - "Wire.API.Event.APIChan"? or "ApiChan"? --- - "MessageBus"? "Bus"? -module Wire.API.WebSocket where +module Wire.API.Event.WebSocketProtocol where import Control.Lens (makePrisms) import Data.Aeson (FromJSON, ToJSON) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 0fbfee822b9..deddacc4a23 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -38,6 +38,7 @@ import Wire.API.Conversation.Typing qualified as Conversation.Typing import Wire.API.CustomBackend qualified as CustomBackend import Wire.API.Event.Conversation qualified as Event.Conversation import Wire.API.Event.Team qualified as Event.Team +import Wire.API.Event.WebSocketProtocol qualified as EventWebSocketProtocol import Wire.API.FederationStatus qualified as FederationStatus import Wire.API.Locale qualified as Locale import Wire.API.Message qualified as Message @@ -76,7 +77,6 @@ import Wire.API.User.Profile qualified as User.Profile import Wire.API.User.RichInfo qualified as User.RichInfo import Wire.API.User.Scim qualified as Scim import Wire.API.User.Search qualified as User.Search -import Wire.API.WebSocket qualified as WebSocket import Wire.API.Wrapped qualified as Wrapped -- FUTUREWORK(#1446): fix tests marked as failing @@ -338,8 +338,8 @@ tests = testRoundTrip @(User.Search.SearchResult User.Search.TeamContact), testRoundTrip @User.Search.PagingState, testRoundTrip @User.Search.TeamContact, - testRoundTrip @WebSocket.MessageServerToClient, - testRoundTrip @WebSocket.MessageClientToServer, + testRoundTrip @EventWebSocketProtocol.MessageServerToClient, + testRoundTrip @EventWebSocketProtocol.MessageClientToServer, testRoundTrip @(Wrapped.Wrapped "some_int" Int), testRoundTrip @Conversation.Action.SomeConversationAction, testRoundTrip @Routes.Version.Version, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 62b1a355863..393499a55c7 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -100,6 +100,7 @@ library Wire.API.Event.Gundeck Wire.API.Event.LeaveReason Wire.API.Event.Team + Wire.API.Event.WebSocketProtocol Wire.API.FederationStatus Wire.API.FederationUpdate Wire.API.Internal.BulkPush @@ -250,7 +251,6 @@ library Wire.API.UserMap Wire.API.Util.Aeson Wire.API.VersionInfo - Wire.API.WebSocket Wire.API.Wrapped other-modules: Paths_wire_api diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index bb15c52fc58..e4cf36cb761 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -12,8 +12,8 @@ import Network.AMQP.Extended (withConnection) import Network.WebSockets import Network.WebSockets qualified as WS import System.Logger qualified as Log +import Wire.API.Event.WebSocketProtocol import Wire.API.Notification -import Wire.API.WebSocket rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do From 935af4ea5d30695602253c8486290084be1130b6 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 09:46:53 +0200 Subject: [PATCH 71/93] gundeck: Don't configure dead-lettering while declaring queues This should be done via Policies: https://www.rabbitmq.com/docs/parameters#policies When done with Policies, we can change our mind about how to deal with dead-lettering later because queues cannot be redeclared with with different headers. --- services/gundeck/src/Gundeck/Client.hs | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index 5a779b84968..a0a0a734111 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -19,15 +19,12 @@ module Gundeck.Client where import Control.Lens (view) import Data.Id -import Data.Map qualified as Map -import Data.Text.Encoding (encodeUtf8) import Gundeck.Monad import Gundeck.Notification.Data qualified as Notifications import Gundeck.Push.Data qualified as Push import Gundeck.Push.Native import Imports import Network.AMQP -import Network.AMQP.Types import Wire.API.Notification unregister :: UserId -> ClientId -> Gundeck () @@ -50,15 +47,8 @@ setupConsumableNotifications :: ClientId -> IO Text setupConsumableNotifications chan uid cid = do - -- TODO: Do this using policies: https://www.rabbitmq.com/docs/parameters#policies let qName = clientNotificationQueueName uid cid - headers = - FieldTable $ - Map.fromList - [ ("x-dead-letter-exchange", FVString $ encodeUtf8 userNotificationDlxName), - ("x-dead-letter-routing-key", FVString $ encodeUtf8 userNotificationDlqName) - ] - void $ declareQueue chan newQueue {queueName = qName, queueHeaders = headers} + void $ declareQueue chan newQueue {queueName = qName} for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName pure qName From 10d9504f4ae392dc7d169f158b264e2e5e2c384c Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 12:37:20 +0200 Subject: [PATCH 72/93] More TODOs --- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 4 ++-- services/gundeck/src/Gundeck/Push.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index e4cf36cb761..00825bb4d2b 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -18,7 +18,7 @@ import Wire.API.Notification rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - -- FUTUREWORK: Pool connections + -- FUTUREWORK: Pool connections -- TODO: Create ticket withConnection e.logg e.rabbitmq $ \conn -> do bracket (Amqp.openChannel conn) (Amqp.closeChannel) $ \chan -> do closeWS <- newEmptyMVar @@ -80,7 +80,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do -- no timeout necessary here, we want to keep running forever. eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) case eitherData of - Left () -> do + Left _closeWS -> do Log.debug e.logg $ Log.msg (Log.val "Closing the websocket") . logClient diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index c3e3cbba202..a42d64d7141 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -276,7 +276,7 @@ pushViaRabbitMq :: (MonadPushAll m) => Push -> m () pushViaRabbitMq p = do let qMsg = Q.newMsg - { msgBody = Aeson.encode p._pushPayload, + { msgBody = Aeson.encode p._pushPayload, -- TODO: Include NotificationId msgContentType = Just "application/json" } routingKeys = From e06817902e89523df14725a1b3f9247f198e7a38 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 12:37:37 +0200 Subject: [PATCH 73/93] Use direct exchange for user notifications Topic exchange is not very useful for our usecase --- services/gundeck/src/Gundeck/Run.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs index a580986722c..1f73490862b 100644 --- a/services/gundeck/src/Gundeck/Run.hs +++ b/services/gundeck/src/Gundeck/Run.hs @@ -100,7 +100,7 @@ run opts = withTracer \tracer -> do createUserNotificationsExchange :: Channel -> IO () createUserNotificationsExchange chan = do - declareExchange chan newExchange {exchangeName = userNotificationExchangeName, exchangeType = "topic"} + declareExchange chan newExchange {exchangeName = userNotificationExchangeName, exchangeType = "direct"} createDeadUserNotificationsExchange :: Channel -> IO () createDeadUserNotificationsExchange chan = do From 9510c874842857d97827169713c014746b97cf0b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 12:38:43 +0200 Subject: [PATCH 74/93] integration: Test that users only get notifs meant for them --- integration/test/SetupHelpers.hs | 10 +++++++ integration/test/Test/Events.hs | 48 +++++++++++++++++++++++++++++--- integration/test/Test/Teams.hs | 10 ------- 3 files changed, 54 insertions(+), 14 deletions(-) diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 4e19ae9b0a6..a5ad209fc3a 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -403,3 +403,13 @@ uploadDownloadProfilePicture :: (HasCallStack, MakesValue usr) => usr -> App (St uploadDownloadProfilePicture usr = do (dom, key, _payload) <- uploadProfilePicture usr downloadProfilePicture usr dom key + +mkContextUserIds :: (MakesValue user) => [(String, user)] -> App String +mkContextUserIds = + fmap (intercalate "\n") + . traverse + ( \(name, user) -> do + uid <- objQidObject user %. "id" & asString + domain <- objDomain user + pure $ name <> ": " <> uid <> "@" <> domain + ) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index f7420afc40c..dafb5d680df 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -51,6 +51,32 @@ testConsumeEventsOneWebSocket = do resp.status `shouldMatchInt` 200 shouldBeEmpty $ resp.json %. "notifications" +testConsumeEventsForDifferentUsers :: (HasCallStack) => App () +testConsumeEventsForDifferentUsers = do + alice <- randomUser OwnDomain def + bob <- randomUser OwnDomain def + + aliceClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + aliceClientId <- objId aliceClient + + bobClient <- addClient bob def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + bobClientId <- objId bobClient + + userIdsContext <- mkContextUserIds [("alice", alice), ("bob", bob)] + addFailureContext userIdsContext $ do + withEventsWebSockets [(alice, aliceClientId), (bob, bobClientId)] $ \[(aliceEventsChan, aliceAckChan), (bobEventsChan, bobAckChan)] -> do + assertClientAdd aliceClientId aliceEventsChan aliceAckChan + assertClientAdd bobClientId bobEventsChan bobAckChan + where + assertClientAdd :: (HasCallStack) => String -> TChan Value -> TChan Value -> App () + assertClientAdd clientId eventsChan ackChan = do + deliveryTag <- assertEvent eventsChan $ \e -> do + e %. "payload.0.type" `shouldMatch` "user.client-add" + e %. "payload.0.client.id" `shouldMatch` clientId + e %. "delivery_tag" + assertNoEvent eventsChan + sendAck ackChan deliveryTag False + testConsumeEventsWhileHavingLegacyClients :: (HasCallStack) => App () testConsumeEventsWhileHavingLegacyClients = do alice <- randomUser OwnDomain def @@ -168,6 +194,15 @@ testConsumeEventsAckNewEventWithoutAckingOldOne = do ---------------------------------------------------------------------- -- helpers +withEventsWebSockets :: forall uid a. (HasCallStack, MakesValue uid) => [(uid, String)] -> ([(TChan Value, TChan Value)] -> App a) -> App a +withEventsWebSockets userClients k = go [] $ reverse userClients + where + go :: [(TChan Value, TChan Value)] -> [(uid, String)] -> App a + go chans [] = k chans + go chans ((uid, cid) : remaining) = + withEventsWebSocket uid cid $ \eventsChan ackChan -> + go ((eventsChan, ackChan) : chans) remaining + withEventsWebSocket :: (HasCallStack, MakesValue uid) => uid -> String -> (TChan Value -> TChan Value -> App a) -> App a withEventsWebSocket uid cid k = do closeWS <- newEmptyMVar @@ -213,11 +248,14 @@ sendAck ackChan deliveryTag multiple = do ] ] -assertEvent :: (HasCallStack) => TChan Value -> (Value -> App a) -> App a +assertEvent :: (HasCallStack) => TChan Value -> ((HasCallStack) => Value -> App a) -> App a assertEvent eventsChan expectations = do - timeout 1_000_000 (atomically (readTChan eventsChan)) >>= \case + timeout 10_000_000 (atomically (readTChan eventsChan)) >>= \case Nothing -> assertFailure "No event received for 1s" - Just e -> expectations e + Just e -> do + pretty <- prettyJSON e + addFailureContext ("event:\n" <> pretty) + $ expectations e assertNoEvent :: (HasCallStack) => TChan Value -> App () assertNoEvent eventsChan = do @@ -245,7 +283,9 @@ eventsWebSocket user clientId eventsChan ackChan closeWS = do bs <- WS.receiveData conn case decodeStrict' bs of Just n -> atomically $ writeTChan eventsChan n - Nothing -> putStrLn $ "Failed to decode events: " ++ show bs + Nothing -> + -- TODO: Throw an error + putStrLn $ "Failed to decode events: " ++ show bs wsWrite conn = forever $ do eitherAck <- race (readMVar closeWS) (atomically $ readTChan ackChan) diff --git a/integration/test/Test/Teams.hs b/integration/test/Test/Teams.hs index 623983abcba..8eb48cbf8a6 100644 --- a/integration/test/Test/Teams.hs +++ b/integration/test/Test/Teams.hs @@ -194,16 +194,6 @@ testInvitePersonalUserToLargeTeam = do resp.json %. "notifications.1.payload.0.team" `shouldMatch` tid resp.json %. "notifications.1.payload.0.data.user" `shouldMatch` objId knut -mkContextUserIds :: (MakesValue user) => [(String, user)] -> App String -mkContextUserIds = - fmap (intercalate "\n") - . traverse - ( \(name, user) -> do - uid <- objQidObject user %. "id" & asString - domain <- objDomain user - pure $ name <> ": " <> uid <> "@" <> domain - ) - testInvitePersonalUserToTeamMultipleInvitations :: (HasCallStack) => App () testInvitePersonalUserToTeamMultipleInvitations = do (owner, tid, _) <- createTeam OwnDomain 0 From 0fa079c6ce58431d6f18288d83ac8d8815b604e7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:19:53 +0200 Subject: [PATCH 75/93] integration/Notifications: Allow waiting for notifs without a client --- integration/test/Notifications.hs | 26 ++++++++++++++++++-------- integration/test/Test/Conversation.hs | 16 +++++++--------- integration/test/Test/Federation.hs | 6 +++--- integration/test/Test/LegalHold.hs | 15 ++++++--------- 4 files changed, 34 insertions(+), 29 deletions(-) diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index d99b46b8897..8da4d4eff6f 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -47,7 +47,7 @@ assertNoNotifications u uc since0 p = do awaitNotifications :: (HasCallStack, MakesValue user, MakesValue client) => user -> - client -> + Maybe client -> Maybe String -> -- | Max no. of notifications Int -> @@ -62,11 +62,11 @@ awaitNotifications user client since0 n selector = do | timeRemaining <= 0 = pure res0 | otherwise = do - c <- make client & asString + c <- for client (asString . make) notifs <- getNotifications user - def {since = since, client = Just c} + def {since = since, client = c} `bindResponse` \resp -> asList (resp.json %. "notifications") lastNotifId <- case notifs of [] -> pure since @@ -85,16 +85,26 @@ awaitNotifications user client since0 n selector = do threadDelay 1_000 go (timeRemaining - 1) lastNotifId res -awaitNotification :: +awaitNotificationClient :: (HasCallStack, MakesValue user, MakesValue client, MakesValue lastNotifId) => user -> client -> Maybe lastNotifId -> (Value -> App Bool) -> App Value -awaitNotification user client lastNotifId selector = do +awaitNotificationClient user client lastNotifId selector = do + since0 <- mapM objId lastNotifId + head <$> awaitNotifications user (Just client) since0 1 selector + +awaitNotification :: + (HasCallStack, MakesValue user, MakesValue lastNotifId) => + user -> + Maybe lastNotifId -> + (Value -> App Bool) -> + App Value +awaitNotification user lastNotifId selector = do since0 <- mapM objId lastNotifId - head <$> awaitNotifications user client since0 1 selector + head <$> awaitNotifications user (Nothing :: Maybe ()) since0 1 selector isDeleteUserNotif :: (MakesValue a) => a -> App Bool isDeleteUserNotif n = @@ -219,9 +229,9 @@ assertLeaveNotification :: App () assertLeaveNotification fromUser conv user client leaver = void - $ awaitNotification + $ awaitNotificationClient user - client + (Just client) noValue ( allPreds [ isConvLeaveNotif, diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index e6ae83d1519..b9e2d2c25cf 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -492,15 +492,14 @@ testSynchroniseUserRemovalNotification domain = do otherDomain <- make domain [alice, bob] <- createAndConnectUsers [ownDomain, otherDomain] runCodensity (acquireResources 1 resourcePool) $ \[dynBackend] -> do - (conv, charlie, client) <- + (conv, charlie) <- runCodensity (startDynamicBackend dynBackend mempty) $ \_ -> do charlie <- randomUser dynBackend.berDomain def - client <- objId $ bindResponse (addClient charlie def) $ getJSON 201 mapM_ (connectTwoUsers charlie) [alice, bob] conv <- postConversation alice (defProteus {qualifiedUsers = [bob, charlie]}) >>= getJSON 201 - pure (conv, charlie, client) + pure (conv, charlie) let newConvName = "The new conversation name" bindResponse (changeConversationName alice conv newConvName) $ \resp -> @@ -508,10 +507,10 @@ testSynchroniseUserRemovalNotification domain = do bindResponse (removeMember alice conv charlie) $ \resp -> resp.status `shouldMatchInt` 200 runCodensity (startDynamicBackend dynBackend mempty) $ \_ -> do - nameNotif <- awaitNotification charlie client noValue isConvNameChangeNotif + nameNotif <- awaitNotification charlie noValue isConvNameChangeNotif nameNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv nameNotif %. "payload.0.data.name" `shouldMatch` newConvName - leaveNotif <- awaitNotification charlie client noValue isConvLeaveNotif + leaveNotif <- awaitNotification charlie noValue isConvLeaveNotif leaveNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject conv testConvRenaming :: (HasCallStack) => App () @@ -648,19 +647,18 @@ testDeleteTeamConversationWithUnreachableRemoteMembers = do notif %. "payload.0.qualified_from" `shouldMatch` objQidObject alice runCodensity (acquireResources 1 resourcePool) $ \[dynBackend] -> do - (bob, bobClient) <- runCodensity (startDynamicBackend dynBackend mempty) $ \_ -> do + bob <- runCodensity (startDynamicBackend dynBackend mempty) $ \_ -> do bob <- randomUser dynBackend.berDomain def - bobClient <- objId $ bindResponse (addClient bob def) $ getJSON 201 connectTwoUsers alice bob mem <- bob %. "qualified_id" void $ addMembers alice conv def {users = [mem]} >>= getBody 200 - pure (bob, bobClient) + pure bob withWebSocket alice $ \ws -> do void $ deleteTeamConversation team conv alice >>= getBody 200 notif <- awaitMatch isConvDeleteNotif ws assertNotification notif void $ runCodensity (startDynamicBackend dynBackend mempty) $ \_ -> do - notif <- awaitNotification bob bobClient noValue isConvDeleteNotif + notif <- awaitNotification bob noValue isConvDeleteNotif assertNotification notif testDeleteTeamMemberLimitedEventFanout :: (HasCallStack) => App () diff --git a/integration/test/Test/Federation.hs b/integration/test/Test/Federation.hs index ff1f2ae2304..7bd0c888ac0 100644 --- a/integration/test/Test/Federation.hs +++ b/integration/test/Test/Federation.hs @@ -114,7 +114,7 @@ testNotificationsForOfflineBackends = do objQid delUserDeletedNotif `shouldMatch` objQid delUser runCodensity (startDynamicBackend downBackend mempty) $ \_ -> do - newMsgNotif <- awaitNotification downUser1 downClient1 noValue isNewMessageNotif + newMsgNotif <- awaitNotificationClient downUser1 downClient1 noValue isNewMessageNotif newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` "success message for down user" @@ -124,11 +124,11 @@ testNotificationsForOfflineBackends = do isNotifConv downBackendConv, isNotifForUser delUser ] - void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) isDelUserLeaveDownConvNotif + void $ awaitNotificationClient downUser1 (Just downClient1) (Just newMsgNotif) isDelUserLeaveDownConvNotif -- FUTUREWORK: Uncomment after fixing this bug: https://wearezeta.atlassian.net/browse/WPB-3664 -- void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isOtherUser2LeaveUpConvNotif -- void $ awaitNotification otherUser otherClient (Just newMsgNotif) isDelUserLeaveDownConvNotif - delUserDeletedNotif <- nPayload $ awaitNotification downUser1 downClient1 (Just newMsgNotif) isDeleteUserNotif + delUserDeletedNotif <- nPayload $ awaitNotificationClient downUser1 downClient1 (Just newMsgNotif) isDeleteUserNotif objQid delUserDeletedNotif `shouldMatch` objQid delUser diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index e8cc0b22743..906167cb39b 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -319,7 +319,7 @@ testLHRequestDevice v = do [bobc1, bobc2] <- replicateM 2 do objId $ addClient bob def `bindResponse` getJSON 201 for_ [bobc1, bobc2] \client -> - awaitNotification bob client noValue isUserLegalholdRequestNotif >>= \notif -> do + awaitNotificationClient bob client noValue isUserLegalholdRequestNotif >>= \notif -> do notif %. "payload.0.last_prekey" `shouldMatch` lpk notif %. "payload.0.id" `shouldMatch` objId bob @@ -411,15 +411,14 @@ testLHApproveDevice = do replicateM 2 do objId $ addClient bob def `bindResponse` getJSON 201 >>= traverse_ \client -> - awaitNotification bob client noValue isUserClientAddNotif >>= \notif -> do + awaitNotificationClient bob client noValue isUserClientAddNotif >>= \notif -> do notif %. "payload.0.client.type" `shouldMatch` "legalhold" notif %. "payload.0.client.class" `shouldMatch` "legalhold" -- the other team members receive a notification about the -- legalhold device being approved in their team for_ [alice, charlie] \user -> do - client <- objId $ addClient user def `bindResponse` getJSON 201 - awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do + awaitNotification user noValue isUserLegalholdEnabledNotif >>= \notif -> do notif %. "payload.0.id" `shouldMatch` objId bob for_ [ollie, sandy] \outsider -> do outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201 @@ -489,9 +488,7 @@ testLHDisableForUser = do withMockServer def lhMockApp \lhDomAndPort chan -> do setUpLHDevice tid alice bob lhDomAndPort - bobc <- objId $ addClient bob def `bindResponse` getJSON 201 - - awaitNotification bob bobc noValue isUserClientAddNotif >>= \notif -> do + awaitNotification bob noValue isUserClientAddNotif >>= \notif -> do notif %. "payload.0.client.type" `shouldMatch` "legalhold" notif %. "payload.0.client.class" `shouldMatch` "legalhold" @@ -515,8 +512,8 @@ testLHDisableForUser = do mzero void $ local (setTimeoutTo 90) do - awaitNotification bob bobc noValue isUserClientRemoveNotif - *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif + awaitNotification bob noValue isUserClientRemoveNotif + *> awaitNotification bob noValue isUserLegalholdDisabledNotif bobId <- objId bob lhClients <- From 19197aa5969efb25b50ff622b0c99c338d622c29 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:38:35 +0200 Subject: [PATCH 76/93] Deflake newly written tests --- integration/test/Test/Events.hs | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index dafb5d680df..9f1a98ab026 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -10,7 +10,7 @@ import Data.ByteString.Conversion (toByteString') import Data.String.Conversions (cs) import qualified Data.Text as Text import qualified Network.WebSockets as WS -import Notifications (isUserClientAddNotif) +import Notifications import SetupHelpers import Testlib.Prelude hiding (assertNoEvent) import Testlib.Printing @@ -20,10 +20,12 @@ testConsumeEventsOneWebSocket :: (HasCallStack) => App () testConsumeEventsOneWebSocket = do alice <- randomUser OwnDomain def - lastNotifId <- - getLastNotification alice def `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "id" & asString + lastNotifResp <- + retrying + (constantDelay 10_000 <> limitRetries 10) + (\_ resp -> pure $ resp.status == 404) + (\_ -> getLastNotification alice def) + lastNotifId <- lastNotifResp.json %. "id" & asString client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client @@ -85,11 +87,11 @@ testConsumeEventsWhileHavingLegacyClients = do -- in Cassandra. This choice is kinda arbitrary as these notifications -- probably don't mean much, however, it ensures backwards compatibility. lastNotifId <- - getNotifications alice def `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "notifications.0.payload.0.type" `shouldMatch` "user.activate" - resp.json %. "has_more" `shouldMatch` False - resp.json %. "notifications.-1.id" & asString + awaitNotification alice noValue (const $ pure True) >>= \notif -> do + notif %. "payload.0.type" `shouldMatch` "user.activate" + -- There is only one notification (at the time of writing), so we assume + -- it to be the last one. + notif %. "id" & asString oldClient <- addClient alice def {acapabilities = Just []} >>= getJSON 201 From bc13ae312ae531a02282912294298fd8b916b2d6 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:39:38 +0200 Subject: [PATCH 77/93] cannon: Don't declare the exchange, its not needed --- services/cannon/src/Cannon/Run.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 1905f7ae70b..4f588c209ab 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -41,8 +41,6 @@ import Data.Text (pack, strip) import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Imports hiding (head, threadDelay) -import Network.AMQP -import Network.AMQP.Extended (mkRabbitMqChannelMVar) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Middleware.Gzip qualified as Gzip @@ -58,7 +56,6 @@ import System.Logger.Extended qualified as L import System.Posix.Signals import System.Posix.Signals qualified as Signals import System.Random.MWC (createSystemRandom) -import Wire.API.Notification (userNotificationExchangeName) import Wire.API.Routes.Internal.Cannon qualified as Internal import Wire.API.Routes.Public.Cannon import Wire.API.Routes.Version @@ -82,7 +79,6 @@ run o = withTracer \tracer -> do <*> createSystemRandom <*> mkClock <*> pure (o ^. Cannon.Options.rabbitmq) - createUserNotificationsExchange $ applog e refreshMetricsThread <- Async.async $ runCannon e refreshMetrics s <- newSettings $ Server (o ^. cannon . host) (o ^. cannon . port) (applog e) (Just idleTimeout) @@ -123,11 +119,6 @@ run o = withTracer \tracer -> do readExternal :: FilePath -> IO ByteString readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f - createUserNotificationsExchange :: L.Logger -> IO () - createUserNotificationsExchange l = do - chan <- Imports.readMVar =<< mkRabbitMqChannelMVar l (o ^. Cannon.Options.rabbitmq) - declareExchange chan newExchange {exchangeName = userNotificationExchangeName, exchangeType = "topic"} - signalHandler :: Env -> ThreadId -> Signals.Handler signalHandler e mainThread = CatchOnce $ do runWS e drain From 2aa58f218256a8fb75f479e877f7ec66e5f0473f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:41:09 +0200 Subject: [PATCH 78/93] integration: Make cannon logLevel Warn again --- integration/test/Testlib/ModService.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index e6a12582f23..057559d2ed2 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -220,7 +220,7 @@ startDynamicBackend resource beOverrides = do def { sparCfg = setField "saml.logLevel" ("Warn" :: String), brigCfg = setField "logLevel" ("Warn" :: String), - cannonCfg = setField "logLevel" ("Debug" :: String), + cannonCfg = setField "logLevel" ("Warn" :: String), cargoholdCfg = setField "logLevel" ("Warn" :: String), galleyCfg = setField "logLevel" ("Warn" :: String), gundeckCfg = setField "logLevel" ("Warn" :: String), From a30c2f3eff65d71f745e5383db780cfd636e7ed5 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:47:26 +0200 Subject: [PATCH 79/93] integrations: Throw error if websocket responds with invalid JSON --- integration/test/Test/Events.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 9f1a98ab026..1e473d586f8 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -286,8 +286,7 @@ eventsWebSocket user clientId eventsChan ackChan closeWS = do case decodeStrict' bs of Just n -> atomically $ writeTChan eventsChan n Nothing -> - -- TODO: Throw an error - putStrLn $ "Failed to decode events: " ++ show bs + error $ "Failed to decode events: " ++ show bs wsWrite conn = forever $ do eitherAck <- race (readMVar closeWS) (atomically $ readTChan ackChan) From 4991f1c229072b81142b9ede861acf6966a549b0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 14:53:36 +0200 Subject: [PATCH 80/93] Add ticket number to FUTUREWORK --- services/cannon/src/Cannon/RabbitMqConsumerApp.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 00825bb4d2b..91d8a5b05e0 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -18,7 +18,7 @@ import Wire.API.Notification rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - -- FUTUREWORK: Pool connections -- TODO: Create ticket + -- FUTUREWORK: Pool connections: https://wearezeta.atlassian.net/browse/WPB-11491 withConnection e.logg e.rabbitmq $ \conn -> do bracket (Amqp.openChannel conn) (Amqp.closeChannel) $ \chan -> do closeWS <- newEmptyMVar From 8f51bed7e3f5495c6ca65ae0aecbb20de3da29d0 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 15:27:43 +0200 Subject: [PATCH 81/93] Add notification Id to rabbitmq notifs This can be used by clients to detect duplicate deliveries. --- integration/test/Test/Events.hs | 58 ++++++++++--------- .../src/Wire/API/Event/WebSocketProtocol.hs | 5 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 16 ++--- services/gundeck/src/Gundeck/Push.hs | 8 ++- 4 files changed, 48 insertions(+), 39 deletions(-) diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 1e473d586f8..1f1597556a3 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -32,9 +32,10 @@ testConsumeEventsOneWebSocket = do withEventsWebSocket alice clientId $ \eventsChan ackChan -> do deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + e %. "type" `shouldMatch` "event" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" assertNoEvent eventsChan sendAck ackChan deliveryTag False @@ -44,8 +45,9 @@ testConsumeEventsOneWebSocket = do putHandle alice handle >>= assertSuccess assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle + e %. "type" `shouldMatch` "event" + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle -- No new notifications should be stored in Cassandra as the user doesn't have -- any legacy clients @@ -73,9 +75,9 @@ testConsumeEventsForDifferentUsers = do assertClientAdd :: (HasCallStack) => String -> TChan Value -> TChan Value -> App () assertClientAdd clientId eventsChan ackChan = do deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" assertNoEvent eventsChan sendAck ackChan deliveryTag False @@ -104,8 +106,8 @@ testConsumeEventsWhileHavingLegacyClients = do withEventsWebSocket alice newClientId $ \eventsChan _ -> assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` newClientId + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` newClientId -- All notifs are also in Cassandra because of the legacy client getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do @@ -121,15 +123,15 @@ testConsumeEventsAcks = do withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId -- without ack, we receive the same event again withEventsWebSocket alice clientId $ \eventsChan ackChan -> do deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" sendAck ackChan deliveryTag False withEventsWebSocket alice clientId $ \eventsChan _ -> do @@ -146,13 +148,13 @@ testConsumeEventsMultipleAcks = do withEventsWebSocket alice clientId $ \eventsChan ackChan -> do assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle - e %. "delivery_tag" + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + e %. "data.delivery_tag" sendAck ackChan deliveryTag True @@ -170,13 +172,13 @@ testConsumeEventsAckNewEventWithoutAckingOldOne = do withEventsWebSocket alice clientId $ \eventsChan ackChan -> do assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId deliveryTagHandleAdd <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.update" - e %. "payload.0.user.handle" `shouldMatch` handle - e %. "delivery_tag" + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + e %. "data.delivery_tag" -- Only ack the handle add delivery tag sendAck ackChan deliveryTagHandleAdd False @@ -184,9 +186,9 @@ testConsumeEventsAckNewEventWithoutAckingOldOne = do -- Expect client-add event to be delivered again. withEventsWebSocket alice clientId $ \eventsChan ackChan -> do deliveryTagClientAdd <- assertEvent eventsChan $ \e -> do - e %. "payload.0.type" `shouldMatch` "user.client-add" - e %. "payload.0.client.id" `shouldMatch` clientId - e %. "delivery_tag" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" sendAck ackChan deliveryTagClientAdd False diff --git a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs index f62ec771119..cb047c617e2 100644 --- a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs +++ b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs @@ -9,6 +9,7 @@ import Data.Aeson.Types qualified as A import Data.Schema import Data.Word import Imports +import Wire.API.Internal.Notification import Wire.Arbitrary data AckData = AckData @@ -30,7 +31,7 @@ instance ToSchema AckData where <*> multiple .= field "multiple" schema data EventData = EventData - { payload :: [A.Object], + { event :: QueuedNotification, deliveryTag :: Word64 } deriving (Show, Eq, Generic) @@ -41,7 +42,7 @@ instance ToSchema EventData where schema = object "EventData" $ EventData - <$> payload .= field "payload" (array genericToSchema) + <$> event .= field "event" schema <*> (.deliveryTag) .= field "delivery_tag" schema data MessageServerToClient diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 91d8a5b05e0..7d0ad849a2b 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) @@ -31,7 +33,7 @@ rabbitMQWebSocketApp uid cid e pendingConn = do pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () pushEventsToWS wsConn (msg, envelope) = - case eitherDecode @Value msg.msgBody of + case eitherDecode @(QueuedNotification) msg.msgBody of Left err -> do Log.err e.logg $ Log.msg (Log.val "failed to decode event from the queue as a JSON") @@ -46,12 +48,12 @@ rabbitMQWebSocketApp uid cid e pendingConn = do -- pushed as JSONs, hopefully we think of the parsing side if/when -- that happens. Amqp.rejectEnv envelope False - Right payload -> do - WS.sendBinaryData wsConn . encode $ - object - [ "payload" .= payload, - "delivery_tag" .= envelope.envDeliveryTag - ] + Right event -> do + Log.debug e.logg $ Log.msg (Log.val "got event") . logClient . Log.field "event" (encode event) + WS.sendBinaryData wsConn + . encode + . EventMessage + $ EventData {deliveryTag = envelope.envDeliveryTag, ..} startWsSender :: Connection -> Amqp.Channel -> MVar () -> IO Amqp.ConsumerTag startWsSender wsConn chan closeWS = do diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index a42d64d7141..a4da3f56fd5 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -40,7 +40,7 @@ import Data.Aeson qualified as Aeson import Data.ByteString.Conversion (toByteString') import Data.Id import Data.List.Extra qualified as List -import Data.List1 (List1, list1) +import Data.List1 (List1, list1, toNonEmpty) import Data.Map qualified as Map import Data.Range import Data.Set qualified as Set @@ -274,9 +274,13 @@ pushAllViaRabbitMq pushes = pushViaRabbitMq :: (MonadPushAll m) => Push -> m () pushViaRabbitMq p = do + notifId <- mpaMkNotificationId let qMsg = Q.newMsg - { msgBody = Aeson.encode p._pushPayload, -- TODO: Include NotificationId + { msgBody = + Aeson.encode + . queuedNotification notifId + $ toNonEmpty p._pushPayload, msgContentType = Just "application/json" } routingKeys = From c87d7b0debd64016c8d4d0a2481d69aca7da91ce Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Oct 2024 15:28:46 +0200 Subject: [PATCH 82/93] Makefile/clean-rabbit: Also cleanup exchanges --- Makefile | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index faee19b3dff..edc1a185b54 100644 --- a/Makefile +++ b/Makefile @@ -51,7 +51,12 @@ install: init .PHONY: clean-rabbit clean-rabbit: - rabbitmqadmin -f pretty_json list queues vhost name messages | jq -r '.[] | "rabbitmqadmin delete queue name=\(.name) --vhost=\(.vhost)"' | bash + rabbitmqadmin -f pretty_json list queues vhost name \ + | jq -r '.[] | "rabbitmqadmin delete queue name=\(.name) --vhost=\(.vhost)"' \ + | bash + rabbitmqadmin -f pretty_json list exchanges name vhost \ + | jq -r '.[] |select(.name | startswith("amq") | not) | select (.name != "") | "rabbitmqadmin delete exchange name=\(.name) --vhost=\(.vhost)"' \ + | bash # Clean .PHONY: full-clean @@ -85,7 +90,7 @@ cabal.project.local: c: treefmt c-fast .PHONY: c -c-fast: +c-fast: cabal build $(WIRE_CABAL_BUILD_OPTIONS) $(package) || ( make clean-hint; false ) ifeq ($(test), 1) ./hack/bin/cabal-run-tests.sh $(package) $(testargs) From 0cd93b1b46fbd654b86c740806e4a380764a2402 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 21 Oct 2024 13:44:01 +0200 Subject: [PATCH 83/93] gundeck: Get preexisting unit tests to pass --- services/gundeck/test/unit/MockGundeck.hs | 48 +++++++++-------------- 1 file changed, 18 insertions(+), 30 deletions(-) diff --git a/services/gundeck/test/unit/MockGundeck.hs b/services/gundeck/test/unit/MockGundeck.hs index fede2c00137..a747a6570a3 100644 --- a/services/gundeck/test/unit/MockGundeck.hs +++ b/services/gundeck/test/unit/MockGundeck.hs @@ -2,10 +2,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wno-missing-methods #-} {-# OPTIONS_GHC -Wno-orphans #-} --- Disabling to stop warnings on HasCallStack -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- This file is part of the Wire Server implementation. -- @@ -205,7 +202,7 @@ genMockEnv :: (HasCallStack) => Gen MockEnv genMockEnv = do -- This function generates a 'ClientInfo' that corresponds to one of the -- four scenarios above - let genClientInfo :: (HasCallStack) => UserId -> ClientId -> Gen ClientInfo + let genClientInfo :: UserId -> ClientId -> Gen ClientInfo genClientInfo uid cid = do _ciNativeAddress <- QC.oneof @@ -252,7 +249,7 @@ genMockEnv = do validateMockEnv env & either error (const $ pure env) -- Try to shrink a 'MockEnv' by removing some users from '_meClientInfos'. -shrinkMockEnv :: (HasCallStack) => MockEnv -> [MockEnv] +shrinkMockEnv :: MockEnv -> [MockEnv] shrinkMockEnv (MockEnv cis) = MockEnv . Map.fromList <$> filter (not . null) (shrinkList (const []) (Map.toList cis)) @@ -292,7 +289,7 @@ genRecipient' env uid = do ] pure $ Recipient uid route cids -genRoute :: (HasCallStack) => Gen Route +genRoute :: Gen Route genRoute = QC.elements [minBound ..] genId :: Gen (Id a) @@ -303,7 +300,7 @@ genId = do genClientId :: Gen ClientId genClientId = ClientId <$> arbitrary -genProtoAddress :: (HasCallStack) => UserId -> ClientId -> Gen Address +genProtoAddress :: UserId -> ClientId -> Gen Address genProtoAddress _addrUser _addrClient = do _addrTransport :: Transport <- QC.elements [minBound ..] arnEpId :: Text <- arbitrary @@ -375,14 +372,14 @@ dropSomeDevices = RecipientClientsSome . unsafeList1 . take numdevs <$> QC.shuffle (toList cids) -shrinkPushes :: (HasCallStack) => [Push] -> [[Push]] +shrinkPushes :: [Push] -> [[Push]] shrinkPushes = shrinkList shrinkPush where - shrinkPush :: (HasCallStack) => Push -> [Push] + shrinkPush :: Push -> [Push] shrinkPush psh = (\rcps -> psh & pushRecipients .~ rcps) <$> shrinkRecipients (psh ^. pushRecipients) - shrinkRecipients :: (HasCallStack) => Range 1 1024 (Set Recipient) -> [Range 1 1024 (Set Recipient)] + shrinkRecipients :: Range 1 1024 (Set Recipient) -> [Range 1 1024 (Set Recipient)] shrinkRecipients = fmap unsafeRange . map Set.fromList . filter (not . null) . shrinkList shrinkRecipient . Set.toList . fromRange - shrinkRecipient :: (HasCallStack) => Recipient -> [Recipient] + shrinkRecipient :: Recipient -> [Recipient] shrinkRecipient _ = [] -- | See 'Payload'. @@ -402,7 +399,7 @@ genNotifs env = fmap uniqNotifs . listOf $ do where uniqNotifs = nubBy ((==) `on` (ntfId . fst)) -shrinkNotifs :: (HasCallStack) => [(Notification, [Presence])] -> [[(Notification, [Presence])]] +shrinkNotifs :: [(Notification, [Presence])] -> [[(Notification, [Presence])]] shrinkNotifs = shrinkList (\(notif, prcs) -> (notif,) <$> shrinkList (const []) prcs) ---------------------------------------------------------------------- @@ -431,6 +428,8 @@ instance MonadPushAll MockGundeck where -- doesn't, this is good enough for testing). mpaRunWithBudget _ _ = id -- no throttling needed as long as we don't overdo it in the tests... + mpaGetClients _ = pure mempty + mpaPublishToRabbitMq _ _ = pure () instance MonadNativeTargets MockGundeck where mntgtLogErr _ = pure () @@ -530,10 +529,7 @@ handlePushNative Push {..} = do -- | From a single 'Push', store only those notifications that real Gundeck would put into -- Cassandra. -handlePushCass :: - (HasCallStack, m ~ MockGundeck) => - Push -> - m () +handlePushCass :: Push -> MockGundeck () handlePushCass Push {..} -- Condition 1: transient pushes are not put into Cassandra. | _pushTransient = pure () @@ -548,15 +544,10 @@ handlePushCass Push {..} = do forM_ cids' $ \cid -> msCassQueue %= deliver (uid, cid) _pushPayload -mockMkNotificationId :: - (HasCallStack, m ~ MockGundeck) => - m NotificationId +mockMkNotificationId :: MockGundeck NotificationId mockMkNotificationId = Id <$> getRandom -mockListAllPresences :: - (HasCallStack, m ~ MockGundeck) => - [UserId] -> - m [[Presence]] +mockListAllPresences :: [UserId] -> MockGundeck [[Presence]] mockListAllPresences uids = asks $ fmap fakePresences . filter ((`elem` uids) . fst) . allRecipients @@ -585,12 +576,11 @@ mockBulkPush notifs = do -- | persisting notification is not needed for the tests at the moment, so we do nothing here. mockStreamAdd :: - (HasCallStack, m ~ MockGundeck) => NotificationId -> List1 NotificationTarget -> Payload -> NotificationTTL -> - m () + MockGundeck () mockStreamAdd _ (toList -> targets) pay _ = forM_ targets $ \tgt -> case tgt ^. targetClients of clients@(_ : _) -> forM_ clients $ \cid -> @@ -599,11 +589,10 @@ mockStreamAdd _ (toList -> targets) pay _ = msCassQueue %= deliver (tgt ^. targetUser, ClientId 0) pay mockPushNative :: - (HasCallStack, m ~ MockGundeck) => Notification -> Priority -> [Address] -> - m () + MockGundeck () mockPushNative (ntfPayload -> payload) _ addrs = do env <- ask forM_ addrs $ \addr -> do @@ -624,10 +613,9 @@ mockLookupAddresses uid = do pure . mapMaybe (^? ciNativeAddress . _Just . _1) $ cinfos mockBulkSend :: - (HasCallStack, m ~ MockGundeck) => URI -> BulkPushRequest -> - m (URI, Either SomeException BulkPushResponse) + MockGundeck (URI, Either SomeException BulkPushResponse) mockBulkSend uri notifs = do getstatus <- mkWSStatus let flat :: [(Notification, PushTarget)] @@ -653,7 +641,7 @@ newtype Pretty a = Pretty a instance (Aeson.ToJSON a) => Show (Pretty a) where show (Pretty a) = cs $ Aeson.encodePretty a -shrinkPretty :: (HasCallStack) => (a -> [a]) -> Pretty a -> [Pretty a] +shrinkPretty :: (a -> [a]) -> Pretty a -> [Pretty a] shrinkPretty shrnk (Pretty xs) = Pretty <$> shrnk xs sublist1Of :: (HasCallStack) => [a] -> Gen (List1 a) From 8d4ea13749e19282f5b204c05399a75dc93fd5db Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 21 Oct 2024 14:03:48 +0200 Subject: [PATCH 84/93] Set correct expiration on events pushed to RabbitMQ --- integration/test/API/Galley.hs | 9 ++++ integration/test/Test/Events.hs | 73 ++++++++++++++++++++++++++-- services/gundeck/default.nix | 2 + services/gundeck/gundeck.cabal | 1 + services/gundeck/src/Gundeck/Push.hs | 28 ++++++++++- 5 files changed, 109 insertions(+), 4 deletions(-) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 6299fc97f8f..37cbf68a34f 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -733,3 +733,12 @@ getTeamMembersCsv :: (HasCallStack, MakesValue user) => user -> String -> App Re getTeamMembersCsv user tid = do req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tid, "members", "csv"]) submit "GET" req + +-- | https://staging-nginz-https.zinfra.io/v6/api/swagger-ui/#/default/post_conversations__cnv_domain___cnv__typing +sendTypingStatus :: (HasCallStack, MakesValue user, MakesValue conv) => user -> conv -> String -> App Response +sendTypingStatus user conv status = do + convDomain <- objDomain conv + convId <- objId conv + req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", convDomain, convId, "typing"]) + submit "POST" + $ addJSONObject ["status" .= status] req diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 1f1597556a3..ce7d598c4db 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -3,12 +3,13 @@ module Test.Events where import API.Brig import API.BrigCommon import API.Common +import API.Galley import API.Gundeck +import qualified Control.Concurrent.Timeout as Timeout import Control.Retry -import qualified Data.Aeson as A import Data.ByteString.Conversion (toByteString') -import Data.String.Conversions (cs) import qualified Data.Text as Text +import Data.Timeout import qualified Network.WebSockets as WS import Notifications import SetupHelpers @@ -195,6 +196,57 @@ testConsumeEventsAckNewEventWithoutAckingOldOne = do withEventsWebSocket alice clientId $ \eventsChan _ -> do assertNoEvent eventsChan +testEventExpiration :: (HasCallStack) => App () +testEventExpiration = do + let notifTTL = 2 # Second + withModifiedBackend (def {gundeckCfg = setField "settings.notificationTTL" (notifTTL #> Second)}) $ \domain -> do + alice <- randomUser domain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + Timeout.threadDelay (notifTTL + 1 # Second) + withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do + assertNoEvent eventsChan + +testTransientEvents :: (HasCallStack) => App () +testTransientEvents = do + alice <- randomUser OwnDomain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + -- Self conv ID is same as user's ID, we'll use this to send typing + -- indicators, so we don't have to create another conv. + selfConvId <- objQidObject alice + + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + consumeAllEvents eventsChan ackChan + sendTypingStatus alice selfConvId "started" >>= assertSuccess + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "conversation.typing" + e %. "data.event.payload.0.qualified_conversation" `shouldMatch` selfConvId + deliveryTag <- e %. "data.delivery_tag" + sendAck ackChan deliveryTag False + + handle1 <- randomHandle + putHandle alice handle1 >>= assertSuccess + + sendTypingStatus alice selfConvId "stopped" >>= assertSuccess + + handle2 <- randomHandle + putHandle alice handle2 >>= assertSuccess + + -- We shouldn't see the stopped typing status because we were not connected to + -- the websocket when it was sent. The other events should still show up in + -- order. + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + for_ [handle1, handle2] $ \handle -> + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + ackEvent ackChan e + + assertNoEvent eventsChan + ---------------------------------------------------------------------- -- helpers @@ -240,6 +292,11 @@ withEventsWebSocket uid cid k = do sendMsg :: (HasCallStack) => TChan Value -> Value -> App () sendMsg eventsChan msg = liftIO $ atomically $ writeTChan eventsChan msg +ackEvent :: (HasCallStack) => TChan Value -> Value -> App () +ackEvent ackChan event = do + deliveryTag <- event %. "data.delivery_tag" + sendAck ackChan deliveryTag False + sendAck :: (HasCallStack) => TChan Value -> Value -> Bool -> App () sendAck ackChan deliveryTag multiple = do sendMsg ackChan @@ -265,7 +322,17 @@ assertNoEvent :: (HasCallStack) => TChan Value -> App () assertNoEvent eventsChan = do timeout 1_000_000 (atomically (readTChan eventsChan)) >>= \case Nothing -> pure () - Just e -> assertFailure $ "Did not expect event: " <> cs (A.encode e) + Just e -> do + eventJSON <- prettyJSON e + assertFailure $ "Did not expect event: \n" <> eventJSON + +consumeAllEvents :: TChan Value -> TChan Value -> App () +consumeAllEvents eventsChan ackChan = do + timeout 1_000_000 (atomically (readTChan eventsChan)) >>= \case + Nothing -> pure () + Just e -> do + ackEvent ackChan e + consumeAllEvents eventsChan ackChan eventsWebSocket :: (MakesValue user) => user -> String -> TChan Value -> TChan Value -> MVar () -> App (Async ()) eventsWebSocket user clientId eventsChan ackChan closeWS = do diff --git a/services/gundeck/default.nix b/services/gundeck/default.nix index a9ed8fed5ac..9901752a620 100644 --- a/services/gundeck/default.nix +++ b/services/gundeck/default.nix @@ -23,6 +23,7 @@ , containers , criterion , crypton-x509-store +, data-timeout , errors , exceptions , extended @@ -111,6 +112,7 @@ mkDerivation { cassandra-util containers crypton-x509-store + data-timeout errors exceptions extended diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index 974d8f63845..b5014de85c1 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -127,6 +127,7 @@ library , cassandra-util >=0.16.2 , containers >=0.5 , crypton-x509-store + , data-timeout , errors >=2.0 , exceptions >=0.4 , extended diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index a4da3f56fd5..8f36118caea 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -42,10 +42,12 @@ import Data.Id import Data.List.Extra qualified as List import Data.List1 (List1, list1, toNonEmpty) import Data.Map qualified as Map +import Data.Misc import Data.Range import Data.Set qualified as Set import Data.Text qualified as Text import Data.These +import Data.Timeout import Data.UUID qualified as UUID import Gundeck.Aws (endpointUsers) import Gundeck.Aws qualified as Aws @@ -275,13 +277,37 @@ pushAllViaRabbitMq pushes = pushViaRabbitMq :: (MonadPushAll m) => Push -> m () pushViaRabbitMq p = do notifId <- mpaMkNotificationId + NotificationTTL ttl <- mpaNotificationTTL let qMsg = Q.newMsg { msgBody = Aeson.encode . queuedNotification notifId $ toNonEmpty p._pushPayload, - msgContentType = Just "application/json" + msgContentType = Just "application/json", + msgDeliveryMode = + -- Non-persistent messages never hit the disk and so do not + -- survive RabbitMQ node restarts, this is great for transient + -- notifications. + Just + ( if p._pushTransient + then Q.NonPersistent + else Q.Persistent + ), + msgExpiration = + Just + ( if p._pushTransient + then + ( -- Means that if there is no active consumer, this + -- message will never be delivered to anyone. It can + -- still take some time before RabbitMQ forgets about + -- this message because the expiration is only + -- considered for messages which are at the head of a + -- queue. See docs: https://www.rabbitmq.com/docs/ttl + "0" + ) + else showT $ fromIntegral ttl # Second #> MilliSecond + ) } routingKeys = Set.unions $ From 7c3632dd6f25398e2665e3ab804a2554aacb26ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 22 Oct 2024 14:59:03 +0200 Subject: [PATCH 85/93] fix a typo in the changelog --- changelog.d/0-release-notes/WBP-10308 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.d/0-release-notes/WBP-10308 b/changelog.d/0-release-notes/WBP-10308 index af442898d14..240287aa29f 100644 --- a/changelog.d/0-release-notes/WBP-10308 +++ b/changelog.d/0-release-notes/WBP-10308 @@ -1 +1 @@ -Notifications are now also send via RabbitMQ therefore RabbitMQ is now a required configuration in brig. +Notifications are now also sent via RabbitMQ therefore RabbitMQ is now a required configuration in brig. From b4220fdf3a1fedc057ec2e5d52107dbf98d5cde1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 22 Oct 2024 15:31:22 +0200 Subject: [PATCH 86/93] Fix a release note --- changelog.d/0-release-notes/WBP-10308 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.d/0-release-notes/WBP-10308 b/changelog.d/0-release-notes/WBP-10308 index 240287aa29f..0484164f8ca 100644 --- a/changelog.d/0-release-notes/WBP-10308 +++ b/changelog.d/0-release-notes/WBP-10308 @@ -1 +1 @@ -Notifications are now also sent via RabbitMQ therefore RabbitMQ is now a required configuration in brig. +Notifications are now also sent via RabbitMQ. Therefore, if federation is enabled, RabbitMQ is a required configuration in Brig. From 816e540a65a2de47ce10f0c10089336f15cd227a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 22 Oct 2024 15:36:25 +0200 Subject: [PATCH 87/93] Add changelogs for public and internal API changes --- changelog.d/1-api-changes/WPB-10308 | 1 + changelog.d/5-internal/WPB-10308 | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 changelog.d/1-api-changes/WPB-10308 create mode 100644 changelog.d/5-internal/WPB-10308 diff --git a/changelog.d/1-api-changes/WPB-10308 b/changelog.d/1-api-changes/WPB-10308 new file mode 100644 index 00000000000..d9ebca156ec --- /dev/null +++ b/changelog.d/1-api-changes/WPB-10308 @@ -0,0 +1 @@ +New endpoint `GET /events` for consuming events is added diff --git a/changelog.d/5-internal/WPB-10308 b/changelog.d/5-internal/WPB-10308 new file mode 100644 index 00000000000..6318426a3a7 --- /dev/null +++ b/changelog.d/5-internal/WPB-10308 @@ -0,0 +1,2 @@ +- RabbitMQ queues have been introduced for client notifications +- New internal endpoint `POST /i/users/:uid/clients/:cid/consumable-notifications` is added From 593f5f29d5d243cb2bddff4052d8097a71e38cf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 22 Oct 2024 16:40:45 +0200 Subject: [PATCH 88/93] Move around routing key helper functions --- libs/wire-api/src/Wire/API/Notification.hs | 10 +++++++++- services/gundeck/src/Gundeck/Client.hs | 9 ++------- services/gundeck/src/Gundeck/Push.hs | 3 +-- 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index d4c0e9fefd0..cafb68bfacf 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -39,6 +39,8 @@ module Wire.API.Notification userNotificationDlxName, userNotificationDlqName, clientNotificationQueueName, + userRoutingKey, + clientRoutingKey, ) where @@ -188,4 +190,10 @@ userNotificationDlqName = "dead-user-notifications" clientNotificationQueueName :: UserId -> ClientId -> Text clientNotificationQueueName uid cid = - "user-notifications." <> idToText uid <> "." <> clientToText cid + "user-notifications." <> clientRoutingKey uid cid + +userRoutingKey :: UserId -> Text +userRoutingKey = idToText + +clientRoutingKey :: UserId -> ClientId -> Text +clientRoutingKey uid cid = userRoutingKey uid <> "." <> clientToText cid diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index a0a0a734111..4f1624a9c8c 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -49,11 +49,6 @@ setupConsumableNotifications :: setupConsumableNotifications chan uid cid = do let qName = clientNotificationQueueName uid cid void $ declareQueue chan newQueue {queueName = qName} - for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName + for_ [userRoutingKey uid, clientRoutingKey uid cid] $ + bindQueue chan qName userNotificationExchangeName pure qName - -userRoutingKey :: UserId -> Text -userRoutingKey = idToText - -clientRoutingKey :: UserId -> ClientId -> Text -clientRoutingKey uid cid = idToText uid <> "." <> clientToText cid diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 8f36118caea..2fd0a927790 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -52,7 +52,6 @@ import Data.UUID qualified as UUID import Gundeck.Aws (endpointUsers) import Gundeck.Aws qualified as Aws import Gundeck.Aws.Arn -import Gundeck.Client import Gundeck.Env import Gundeck.Monad import Gundeck.Notification.Data qualified as Data @@ -74,7 +73,7 @@ import System.Logger.Class qualified as Log import UnliftIO (pooledMapConcurrentlyN) import Util.Options import Wire.API.Internal.Notification -import Wire.API.Notification (userNotificationExchangeName) +import Wire.API.Notification import Wire.API.Presence (Presence (..)) import Wire.API.Presence qualified as Presence import Wire.API.Push.Token qualified as Public From c465c928e9367d6e13aa037061411dd2f8e6b2b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 22 Oct 2024 16:52:16 +0200 Subject: [PATCH 89/93] Remove commented out code --- services/gundeck/src/Gundeck/Push.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 2fd0a927790..994a8987eff 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -242,8 +242,6 @@ pushAll pushes = do pushAllLegacy :: (MonadPushAll m, MonadNativeTargets m, MonadMapAsync m) => [Push] -> m () pushAllLegacy pushes = do newNotifications <- mapM mkNewNotification pushes - -- let rs = concatMap (toList . (.nnRecipients)) newNotifications - -- (capableClients, incapableClients) :: ([Recipient], [Recipient]) <- splitClients rs -- persist push request let cassandraTargets :: [CassandraTargets] cassandraTargets = map mkCassandraTargets newNotifications From bb5179f29809718e5dc307c89086926e2fdd9b2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 23 Oct 2024 09:33:12 +0200 Subject: [PATCH 90/93] Hi CI From f86217f74b18d0054ddc1c011e90daba03bf2048 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 12 Nov 2024 09:14:39 +0100 Subject: [PATCH 91/93] Hi CI From 61bacf2bda550b2089d956caa749c1e39bf1e61b Mon Sep 17 00:00:00 2001 From: Igor Ranieri <54423+elland@users.noreply.github.com> Date: Tue, 12 Nov 2024 10:33:46 +0100 Subject: [PATCH 92/93] Detect and flag missed notifications from RabbitMQ (#4317) --- Makefile | 4 +- cassandra-schema.cql | 20 + .../templates/configmap.yaml | 6 + charts/background-worker/values.yaml | 2 + charts/cannon/templates/configmap.yaml | 37 +- charts/cannon/values.yaml | 29 ++ charts/gundeck/templates/configmap.yaml | 12 + charts/gundeck/templates/deployment.yaml | 19 + charts/gundeck/templates/secret.yaml | 2 + .../templates/tests/gundeck-integration.yaml | 14 + charts/gundeck/values.yaml | 7 + .../templates/integration-integration.yaml | 3 + hack/helm_vars/wire-server/values.yaml.gotmpl | 41 +- hack/helmfile.yaml | 2 +- integration/test/API/GalleyInternal.hs | 7 - integration/test/MLS/Util.hs | 3 - integration/test/Test/Events.hs | 371 ++++++++++-------- integration/test/Testlib/Types.hs | 5 - libs/extended/src/Network/AMQP/Extended.hs | 36 +- libs/jwt-tools/src/Data/Jwt/Tools.hs | 9 - libs/types-common/src/Data/Mailbox.hs | 3 +- .../src/Network/Wai/Utilities/Server.hs | 2 +- .../src/Wire/API/Event/WebSocketProtocol.hs | 27 +- .../wire-subsystems/src/Wire/UserSubsystem.hs | 8 - .../background-worker/background-worker.cabal | 7 + .../background-worker.integration.yaml | 6 + services/background-worker/default.nix | 10 + .../BackendDeadUserNotificationWatcher.hs | 132 +++++++ .../src/Wire/BackendNotificationPusher.hs | 7 +- .../src/Wire/BackgroundWorker.hs | 6 + .../src/Wire/BackgroundWorker/Env.hs | 9 +- .../src/Wire/BackgroundWorker/Options.hs | 3 +- .../Wire/BackendNotificationPusherSpec.hs | 2 + .../background-worker/test/Test/Wire/Util.hs | 1 + services/brig/src/Brig/API/Error.hs | 3 - services/brig/src/Brig/API/Public.hs | 2 +- services/brig/src/Brig/API/User.hs | 1 - services/cannon/cannon.cabal | 2 + services/cannon/cannon.integration.yaml | 6 + services/cannon/default.nix | 4 + services/cannon/src/Cannon/Options.hs | 8 +- .../cannon/src/Cannon/RabbitMqConsumerApp.hs | 341 ++++++++++------ services/cannon/src/Cannon/Run.hs | 4 +- services/cannon/src/Cannon/Types.hs | 12 +- services/cannon/src/Cannon/WS.hs | 5 +- services/gundeck/gundeck.cabal | 1 + services/gundeck/src/Gundeck/Client.hs | 22 +- services/gundeck/src/Gundeck/Schema/Run.hs | 4 +- services/gundeck/src/Gundeck/Schema/V12.hs | 33 ++ 49 files changed, 934 insertions(+), 366 deletions(-) create mode 100644 services/background-worker/src/Wire/BackendDeadUserNotificationWatcher.hs create mode 100644 services/gundeck/src/Gundeck/Schema/V12.hs diff --git a/Makefile b/Makefile index 2b174e48b32..b04d44051d6 100644 --- a/Makefile +++ b/Makefile @@ -49,8 +49,8 @@ install: init ./hack/bin/cabal-run-all-tests.sh ./hack/bin/cabal-install-artefacts.sh all -.PHONY: clean-rabbit -clean-rabbit: +.PHONY: rabbit-clean +rabbit-clean: rabbitmqadmin -f pretty_json list queues vhost name \ | jq -r '.[] | "rabbitmqadmin delete queue name=\(.name) --vhost=\(.vhost)"' \ | bash diff --git a/cassandra-schema.cql b/cassandra-schema.cql index 28fad0acf4a..bc454c6fa36 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -1729,6 +1729,26 @@ CREATE TABLE gundeck_test.meta ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE TABLE gundeck_test.missed_notifications ( + user_id uuid, + client_id text, + PRIMARY KEY (user_id, client_id) +) WITH CLUSTERING ORDER BY (client_id ASC) + AND bloom_filter_fp_chance = 0.01 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE gundeck_test.push ( ptoken text, app text, diff --git a/charts/background-worker/templates/configmap.yaml b/charts/background-worker/templates/configmap.yaml index 8840a43764e..25ac5238bd1 100644 --- a/charts/background-worker/templates/configmap.yaml +++ b/charts/background-worker/templates/configmap.yaml @@ -21,6 +21,12 @@ data: host: federator port: 8080 + cassandra: + endpoint: + host: {{ .cassandra.host }} + port: 9042 + keyspace: gundeck + {{- with .rabbitmq }} rabbitmq: host: {{ .host }} diff --git a/charts/background-worker/values.yaml b/charts/background-worker/values.yaml index 8b79f6af6be..1f8c113732e 100644 --- a/charts/background-worker/values.yaml +++ b/charts/background-worker/values.yaml @@ -29,6 +29,8 @@ config: # tlsCaSecretRef: # name: # key: + cassandra: + host: aws-cassandra backendNotificationPusher: pushBackoffMinWait: 10000 # in microseconds, so 10ms diff --git a/charts/cannon/templates/configmap.yaml b/charts/cannon/templates/configmap.yaml index 6537fc0172a..99ffd6f2ede 100644 --- a/charts/cannon/templates/configmap.yaml +++ b/charts/cannon/templates/configmap.yaml @@ -1,25 +1,46 @@ apiVersion: v1 data: + {{- with .Values }} cannon.yaml: | - logFormat: {{ .Values.config.logFormat }} - logLevel: {{ .Values.config.logLevel }} - logNetStrings: {{ .Values.config.logNetStrings }} + logFormat: {{ .config.logFormat }} + logLevel: {{ .config.logLevel }} + logNetStrings: {{ .config.logNetStrings }} cannon: host: 0.0.0.0 - port: {{ .Values.service.externalPort }} + port: {{ .service.externalPort }} externalHostFile: /etc/wire/cannon/externalHost/host.txt gundeck: host: gundeck port: 8080 + cassandra: + endpoint: + host: {{ .config.cassandra.host }} + port: 9042 + keyspace: gundeck + + {{- with .config.rabbitmq }} + rabbitmq: + host: {{ .host }} + port: {{ .port }} + vHost: {{ .vHost }} + enableTls: {{ .enableTls }} + insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} + {{- if .tlsCaSecretRef }} + caCert: /etc/wire/gundeck/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- end }} + {{- end }} + drainOpts: - gracePeriodSeconds: {{ .Values.config.drainOpts.gracePeriodSeconds }} - millisecondsBetweenBatches: {{ .Values.config.drainOpts.millisecondsBetweenBatches }} - minBatchSize: {{ .Values.config.drainOpts.minBatchSize }} + gracePeriodSeconds: {{ .config.drainOpts.gracePeriodSeconds }} + millisecondsBetweenBatches: {{ .config.drainOpts.millisecondsBetweenBatches }} + minBatchSize: {{ .config.drainOpts.minBatchSize }} + + disabledAPIVersions: {{ toJson .config.disabledAPIVersions }} + {{- end }} - disabledAPIVersions: {{ toJson .Values.config.disabledAPIVersions }} kind: ConfigMap metadata: diff --git a/charts/cannon/values.yaml b/charts/cannon/values.yaml index 350ffebc50a..93041914a22 100644 --- a/charts/cannon/values.yaml +++ b/charts/cannon/values.yaml @@ -11,6 +11,35 @@ config: logLevel: Info logFormat: StructuredJSON logNetStrings: false + rabbitmq: + host: rabbitmq + port: 5672 + vHost: / + enableTls: false + insecureSkipVerifyTls: false + cassandra: + host: aws-cassandra + # To enable TLS provide a CA: + # tlsCa: + # + # Or refer to an existing secret (containing the CA): + # tlsCaSecretRef: + # name: + # key: + + redis: + host: redis-ephemeral-master + port: 6379 + connectionMode: "master" # master | cluster + enableTls: false + insecureSkipVerifyTls: false + # To configure custom TLS CA, please provide one of these: + # tlsCa: + # + # Or refer to an existing secret (containing the CA): + # tlsCaSecretRef: + # name: + # key: # See also the section 'Controlling the speed of websocket draining during # cannon pod replacement' in docs/how-to/install/configuration-options.rst diff --git a/charts/gundeck/templates/configmap.yaml b/charts/gundeck/templates/configmap.yaml index cf7c37e1a7c..d067c6508a0 100644 --- a/charts/gundeck/templates/configmap.yaml +++ b/charts/gundeck/templates/configmap.yaml @@ -29,6 +29,18 @@ data: tlsCa: /etc/wire/gundeck/cassandra/{{- (include "tlsSecretRef" . | fromYaml).key }} {{- end }} + {{- with .rabbitmq }} + rabbitmq: + host: {{ .host }} + port: {{ .port }} + vHost: {{ .vHost }} + enableTls: {{ .enableTls }} + insecureSkipVerifyTls: {{ .insecureSkipVerifyTls }} + {{- if .tlsCaSecretRef }} + caCert: /etc/wire/gundeck/rabbitmq-ca/{{ .tlsCaSecretRef.key }} + {{- end }} + {{- end }} + redis: host: {{ .redis.host }} port: {{ .redis.port }} diff --git a/charts/gundeck/templates/deployment.yaml b/charts/gundeck/templates/deployment.yaml index ee67ba1ba43..a6a3c320a3e 100644 --- a/charts/gundeck/templates/deployment.yaml +++ b/charts/gundeck/templates/deployment.yaml @@ -39,6 +39,11 @@ spec: - name: "gundeck-config" configMap: name: "gundeck" + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} {{- if eq (include "useCassandraTLS" .Values.config) "true" }} - name: "gundeck-cassandra" secret: @@ -77,7 +82,21 @@ spec: - name: "additional-redis-ca" mountPath: "/etc/wire/gundeck/additional-redis-ca/" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/gundeck/rabbitmq-ca/" + {{- end }} env: + - name: RABBITMQ_USERNAME + valueFrom: + secretKeyRef: + name: gundeck + key: rabbitmqUsername + - name: RABBITMQ_PASSWORD + valueFrom: + secretKeyRef: + name: gundeck + key: rabbitmqPassword {{- if hasKey .Values.secrets "awsKeyId" }} - name: AWS_ACCESS_KEY_ID valueFrom: diff --git a/charts/gundeck/templates/secret.yaml b/charts/gundeck/templates/secret.yaml index eae9c4ab33d..67c61afc220 100644 --- a/charts/gundeck/templates/secret.yaml +++ b/charts/gundeck/templates/secret.yaml @@ -11,6 +11,8 @@ metadata: type: Opaque data: {{- with .Values.secrets }} + rabbitmqUsername: {{ .rabbitmq.username | b64enc | quote }} + rabbitmqPassword: {{ .rabbitmq.password | b64enc | quote }} {{- if hasKey . "awsKeyId" }} awsKeyId: {{ .awsKeyId | b64enc | quote }} {{- end }} diff --git a/charts/gundeck/templates/tests/gundeck-integration.yaml b/charts/gundeck/templates/tests/gundeck-integration.yaml index 9aa7b56347d..a2aa75e52cd 100644 --- a/charts/gundeck/templates/tests/gundeck-integration.yaml +++ b/charts/gundeck/templates/tests/gundeck-integration.yaml @@ -23,6 +23,11 @@ spec: secret: secretName: {{ include "redisTlsSecretName" .Values.config }} {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + secret: + secretName: {{ .Values.config.rabbitmq.tlsCaSecretRef.name }} + {{- end }} containers: - name: integration # TODO: When deployed to staging (or real AWS env), _all_ tests should be run @@ -72,6 +77,10 @@ spec: - name: "redis-ca" mountPath: "/etc/wire/gundeck/redis-ca/" {{- end }} + {{- if .Values.config.rabbitmq.tlsCaSecretRef }} + - name: "rabbitmq-ca" + mountPath: "/etc/wire/gundeck/rabbitmq-ca/" + {{- end }} env: # these dummy values are necessary for Amazonka's "Discover" - name: AWS_ACCESS_KEY_ID @@ -82,6 +91,11 @@ spec: value: "eu-west-1" - name: TEST_XML value: /tmp/result.xml + # RabbitMQ needs dummy credentials for the tests to run + - name: RABBITMQ_USERNAME + value: "guest" + - name: RABBITMQ_PASSWORD + value: "guest" {{- if hasKey .Values.secrets "redisUsername" }} - name: REDIS_USERNAME valueFrom: diff --git a/charts/gundeck/values.yaml b/charts/gundeck/values.yaml index 9749dd94be8..e5500c02db5 100644 --- a/charts/gundeck/values.yaml +++ b/charts/gundeck/values.yaml @@ -18,6 +18,13 @@ config: logLevel: Info logFormat: StructuredJSON logNetStrings: false + rabbitmq: + host: rabbitmq + port: 5672 + adminPort: 15672 + vHost: / + enableTls: false + insecureSkipVerifyTls: false cassandra: host: aws-cassandra # To enable TLS provide a CA: diff --git a/charts/integration/templates/integration-integration.yaml b/charts/integration/templates/integration-integration.yaml index 3fe4284dc5b..701c8fec634 100644 --- a/charts/integration/templates/integration-integration.yaml +++ b/charts/integration/templates/integration-integration.yaml @@ -261,6 +261,9 @@ spec: - name: rabbitmq-ca mountPath: /etc/wire/background-worker/rabbitmq-ca + - name: rabbitmq-ca + mountPath: /etc/wire/gundeck/rabbitmq-ca + {{- if eq (include "useCassandraTLS" .Values.config) "true" }} - name: "integration-cassandra" mountPath: "/certs" diff --git a/hack/helm_vars/wire-server/values.yaml.gotmpl b/hack/helm_vars/wire-server/values.yaml.gotmpl index e7f72583f39..8bd68830837 100644 --- a/hack/helm_vars/wire-server/values.yaml.gotmpl +++ b/hack/helm_vars/wire-server/values.yaml.gotmpl @@ -80,7 +80,7 @@ brig: enableTls: true insecureSkipVerifyTls: false tlsCaSecretRef: - name: rabbitmq-certificate + name: "rabbitmq-certificate" key: "ca.crt" authSettings: userTokenTimeout: 120 @@ -205,7 +205,23 @@ cannon: memory: 512Mi drainTimeout: 0 config: + cassandra: + host: {{ .Values.cassandraHost }} + replicaCount: 1 disabledAPIVersions: [] + rabbitmq: + port: 5671 + adminPort: 15671 + enableTls: true + insecureSkipVerifyTls: false + tlsCaSecretRef: + name: "rabbitmq-certificate" + key: "ca.crt" + secrets: + rabbitmq: + username: {{ .Values.rabbitmqUsername }} + password: {{ .Values.rabbitmqPassword }} + cargohold: replicaCount: 1 imagePullPolicy: {{ .Values.imagePullPolicy }} @@ -252,7 +268,7 @@ galley: enableTls: true insecureSkipVerifyTls: false tlsCaSecretRef: - name: rabbitmq-certificate + name: "rabbitmq-certificate" key: "ca.crt" enableFederation: true # keep in sync with brig.config.enableFederation, cargohold.config.enableFederation and tags.federator! settings: @@ -373,6 +389,14 @@ gundeck: name: "cassandra-jks-keystore" key: "ca.crt" {{- end }} + rabbitmq: + port: 5671 + adminPort: 15671 + enableTls: true + insecureSkipVerifyTls: false + tlsCaSecretRef: + name: "rabbitmq-certificate" + key: "ca.crt" redis: host: redis-ephemeral-master connectionMode: master @@ -395,6 +419,9 @@ gundeck: awsKeyId: dummykey awsSecretKey: dummysecret redisPassword: very-secure-redis-master-password + rabbitmq: + username: {{ .Values.rabbitmqUsername }} + password: {{ .Values.rabbitmqPassword }} tests: {{- if .Values.uploadXml }} config: @@ -518,13 +545,21 @@ background-worker: pushBackoffMinWait: 1000 # 1ms pushBackoffMaxWait: 500000 # 0.5s remotesRefreshInterval: 1000000 # 1s + cassandra: + host: {{ .Values.cassandraHost }} + replicaCount: 1 + {{- if .Values.useK8ssandraSSL.enabled }} + tlsCaSecretRef: + name: "cassandra-jks-keystore" + key: "ca.crt" + {{- end }} rabbitmq: port: 5671 adminPort: 15671 enableTls: true insecureSkipVerifyTls: false tlsCaSecretRef: - name: rabbitmq-certificate + name: "rabbitmq-certificate" key: "ca.crt" secrets: rabbitmq: diff --git a/hack/helmfile.yaml b/hack/helmfile.yaml index 3581c373a78..447b980777e 100644 --- a/hack/helmfile.yaml +++ b/hack/helmfile.yaml @@ -1,5 +1,5 @@ --- -# This helfile is used for the setup of two ephemeral backends on kubernetes +# This helmfile is used for the setup of two ephemeral backends on kubernetes # during integration testing (including federation integration tests spanning # over 2 backends) # This helmfile is used via the './hack/bin/integration-setup-federation.sh' via diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index de6f5c21c47..bb8a471ce36 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -114,13 +114,6 @@ patchTeamFeatureConfig domain team featureName payload = do req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", fn] submit "PATCH" $ req & addJSON p --- https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/post_i_features_multi_teams_searchVisibilityInbound -getFeatureStatusMulti :: (HasCallStack, MakesValue domain, MakesValue featureName) => domain -> featureName -> [String] -> App Response -getFeatureStatusMulti domain featureName tids = do - fn <- asString featureName - req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "features-multi-teams", fn] - submit "POST" $ req & addJSONObject ["teams" .= tids] - patchTeamFeature :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> Value -> App Response patchTeamFeature domain team featureName payload = do tid <- asString team diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index ae3d748f04d..e70fa74d259 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -835,9 +835,6 @@ createApplicationMessage convId cid messageContent = do groupInfo = Nothing } -setMLSCiphersuite :: ConvId -> Ciphersuite -> App () -setMLSCiphersuite convId suite = modifyMLSState $ \mls -> mls {convs = Map.adjust (\conv -> conv {ciphersuite = suite}) convId mls.convs} - leaveConv :: (HasCallStack) => ConvId -> diff --git a/integration/test/Test/Events.hs b/integration/test/Test/Events.hs index 267e84800c2..29f6fd4f945 100644 --- a/integration/test/Test/Events.hs +++ b/integration/test/Test/Events.hs @@ -17,57 +17,60 @@ import Testlib.Prelude hiding (assertNoEvent) import Testlib.Printing import UnliftIO hiding (handle) +-- FUTUREWORK: Investigate why these tests are failing without +-- `withModifiedBackend`; No events are received otherwise. testConsumeEventsOneWebSocket :: (HasCallStack) => App () testConsumeEventsOneWebSocket = do - alice <- randomUser OwnDomain def + withModifiedBackend def \domain -> do + alice <- randomUser domain def - lastNotifResp <- - retrying - (constantDelay 10_000 <> limitRetries 10) - (\_ resp -> pure $ resp.status == 404) - (\_ -> getLastNotification alice def) - lastNotifId <- lastNotifResp.json %. "id" & asString + lastNotifResp <- + retrying + (constantDelay 10_000 <> limitRetries 10) + (\_ resp -> pure $ resp.status == 404) + (\_ -> getLastNotification alice def) + lastNotifId <- lastNotifResp.json %. "id" & asString - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "type" `shouldMatch` "event" - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId - e %. "data.delivery_tag" - assertNoEvent eventsChan + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTag <- assertEvent eventsChan $ \e -> do + e %. "type" `shouldMatch` "event" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" + assertNoEvent eventsChan - sendAck ackChan deliveryTag False - assertNoEvent eventsChan + sendAck ackChan deliveryTag False + assertNoEvent eventsChan - handle <- randomHandle - putHandle alice handle >>= assertSuccess + handle <- randomHandle + putHandle alice handle >>= assertSuccess - assertEvent eventsChan $ \e -> do - e %. "type" `shouldMatch` "event" - e %. "data.event.payload.0.type" `shouldMatch` "user.update" - e %. "data.event.payload.0.user.handle" `shouldMatch` handle + assertEvent eventsChan $ \e -> do + e %. "type" `shouldMatch` "event" + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle - -- No new notifications should be stored in Cassandra as the user doesn't have - -- any legacy clients - getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - shouldBeEmpty $ resp.json %. "notifications" + -- No new notifications should be stored in Cassandra as the user doesn't have + -- any legacy clients + getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + shouldBeEmpty $ resp.json %. "notifications" testConsumeEventsForDifferentUsers :: (HasCallStack) => App () testConsumeEventsForDifferentUsers = do - alice <- randomUser OwnDomain def - bob <- randomUser OwnDomain def + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def + bob <- randomUser domain def - aliceClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - aliceClientId <- objId aliceClient + aliceClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + aliceClientId <- objId aliceClient - bobClient <- addClient bob def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - bobClientId <- objId bobClient + bobClient <- addClient bob def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + bobClientId <- objId bobClient - addUsersToFailureContext [("alice", alice), ("bob", bob)] $ do withEventsWebSockets [(alice, aliceClientId), (bob, bobClientId)] $ \[(aliceEventsChan, aliceAckChan), (bobEventsChan, bobAckChan)] -> do assertClientAdd aliceClientId aliceEventsChan aliceAckChan assertClientAdd bobClientId bobEventsChan bobAckChan @@ -83,168 +86,223 @@ testConsumeEventsForDifferentUsers = do testConsumeEventsWhileHavingLegacyClients :: (HasCallStack) => App () testConsumeEventsWhileHavingLegacyClients = do - alice <- randomUser OwnDomain def + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def - -- Even if alice has no clients, the notifications should still be persisted - -- in Cassandra. This choice is kinda arbitrary as these notifications - -- probably don't mean much, however, it ensures backwards compatibility. - lastNotifId <- - awaitNotification alice noValue (const $ pure True) >>= \notif -> do - notif %. "payload.0.type" `shouldMatch` "user.activate" - -- There is only one notification (at the time of writing), so we assume - -- it to be the last one. - notif %. "id" & asString + -- Even if alice has no clients, the notifications should still be persisted + -- in Cassandra. This choice is kinda arbitrary as these notifications + -- probably don't mean much, however, it ensures backwards compatibility. + lastNotifId <- + awaitNotification alice noValue (const $ pure True) >>= \notif -> do + notif %. "payload.0.type" `shouldMatch` "user.activate" + -- There is only one notification (at the time of writing), so we assume + -- it to be the last one. + notif %. "id" & asString - oldClient <- addClient alice def {acapabilities = Just []} >>= getJSON 201 + oldClient <- addClient alice def {acapabilities = Just []} >>= getJSON 201 - withWebSocket (alice, "anything-but-conn", oldClient %. "id") $ \oldWS -> do - newClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - newClientId <- newClient %. "id" & asString + withWebSocket (alice, "anything-but-conn", oldClient %. "id") $ \oldWS -> do + newClient <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + newClientId <- newClient %. "id" & asString - oldNotif <- awaitMatch isUserClientAddNotif oldWS - oldNotif %. "payload.0.client.id" `shouldMatch` newClientId + oldNotif <- awaitMatch isUserClientAddNotif oldWS + oldNotif %. "payload.0.client.id" `shouldMatch` newClientId - withEventsWebSocket alice newClientId $ \eventsChan _ -> - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` newClientId + withEventsWebSocket alice newClientId $ \eventsChan _ -> + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` newClientId - -- All notifs are also in Cassandra because of the legacy client - getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "notifications.0.payload.0.type" `shouldMatch` "user.client-add" - resp.json %. "notifications.1.payload.0.type" `shouldMatch` "user.client-add" + -- All notifs are also in Cassandra because of the legacy client + getNotifications alice def {since = Just lastNotifId} `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "notifications.0.payload.0.type" `shouldMatch` "user.client-add" + resp.json %. "notifications.1.payload.0.type" `shouldMatch` "user.client-add" testConsumeEventsAcks :: (HasCallStack) => App () testConsumeEventsAcks = do - alice <- randomUser OwnDomain def - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client - - withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId - - -- without ack, we receive the same event again - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId - e %. "data.delivery_tag" - sendAck ackChan deliveryTag False - - withEventsWebSocket alice clientId $ \eventsChan _ -> do - assertNoEvent eventsChan + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + + -- without ack, we receive the same event again + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTag <- assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" + sendAck ackChan deliveryTag False + + withEventsWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan testConsumeEventsMultipleAcks :: (HasCallStack) => App () testConsumeEventsMultipleAcks = do - alice <- randomUser OwnDomain def - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client - handle <- randomHandle - putHandle alice handle >>= assertSuccess + handle <- randomHandle + putHandle alice handle >>= assertSuccess - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId - deliveryTag <- assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.update" - e %. "data.event.payload.0.user.handle" `shouldMatch` handle - e %. "data.delivery_tag" + deliveryTag <- assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + e %. "data.delivery_tag" - sendAck ackChan deliveryTag True + sendAck ackChan deliveryTag True - withEventsWebSocket alice clientId $ \eventsChan _ -> do - assertNoEvent eventsChan + withEventsWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan testConsumeEventsAckNewEventWithoutAckingOldOne :: (HasCallStack) => App () testConsumeEventsAckNewEventWithoutAckingOldOne = do - alice <- randomUser OwnDomain def - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client - handle <- randomHandle - putHandle alice handle >>= assertSuccess + handle <- randomHandle + putHandle alice handle >>= assertSuccess - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId - deliveryTagHandleAdd <- assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.update" - e %. "data.event.payload.0.user.handle" `shouldMatch` handle - e %. "data.delivery_tag" + deliveryTagHandleAdd <- assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + e %. "data.delivery_tag" - -- Only ack the handle add delivery tag - sendAck ackChan deliveryTagHandleAdd False + -- Only ack the handle add delivery tag + sendAck ackChan deliveryTagHandleAdd False - -- Expect client-add event to be delivered again. - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - deliveryTagClientAdd <- assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" - e %. "data.event.payload.0.client.id" `shouldMatch` clientId - e %. "data.delivery_tag" + -- Expect client-add event to be delivered again. + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + deliveryTagClientAdd <- assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + e %. "data.delivery_tag" - sendAck ackChan deliveryTagClientAdd False + sendAck ackChan deliveryTagClientAdd False - withEventsWebSocket alice clientId $ \eventsChan _ -> do - assertNoEvent eventsChan + withEventsWebSocket alice clientId $ \eventsChan _ -> do + assertNoEvent eventsChan -testEventExpiration :: (HasCallStack) => App () -testEventExpiration = do - let notifTTL = 2 # Second +testEventsDeadLettered :: (HasCallStack) => App () +testEventsDeadLettered = do + let notifTTL = 1 # Second withModifiedBackend (def {gundeckCfg = setField "settings.notificationTTL" (notifTTL #> Second)}) $ \domain -> do alice <- randomUser domain def + + -- This generates an event client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 clientId <- objId client - Timeout.threadDelay (notifTTL + 1 # Second) + -- We expire the add client event by waiting it out + Timeout.threadDelay (notifTTL + 500 # MilliSecond) + + -- Generate a second event + handle1 <- randomHandle + putHandle alice handle1 >>= assertSuccess + + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "type" `shouldMatch` "notifications.missed" + + -- Until we ack the full sync, we can't get new events + ackFullSync ackChan + + -- withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + -- Now we can see the next event + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle1 + ackEvent ackChan e + + -- We've consumed the whole queue. + assertNoEvent eventsChan + +testTransientEventsDoNotTriggerDeadLetters :: (HasCallStack) => App () +testTransientEventsDoNotTriggerDeadLetters = do + let notifTTL = 1 # Second + withModifiedBackend (def {gundeckCfg = setField "settings.notificationTTL" (notifTTL #> Second)}) $ \domain -> do + alice <- randomUser domain def + -- Creates a non-transient event + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client + + -- consume it + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "type" `shouldMatch` "event" + e %. "data.event.payload.0.type" `shouldMatch` "user.client-add" + e %. "data.event.payload.0.client.id" `shouldMatch` clientId + deliveryTag <- e %. "data.delivery_tag" + sendAck ackChan deliveryTag False + + -- Self conv ID is same as user's ID, we'll use this to send typing + -- indicators, so we don't have to create another conv. + selfConvId <- objQidObject alice + -- Typing status is transient, currently no one is listening. + sendTypingStatus alice selfConvId "started" >>= assertSuccess + withEventsWebSocket alice clientId $ \eventsChan _ackChan -> do assertNoEvent eventsChan testTransientEvents :: (HasCallStack) => App () testTransientEvents = do - alice <- randomUser OwnDomain def - client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 - clientId <- objId client + withModifiedBackend def $ \domain -> do + alice <- randomUser domain def + client <- addClient alice def {acapabilities = Just ["consumable-notifications"]} >>= getJSON 201 + clientId <- objId client - -- Self conv ID is same as user's ID, we'll use this to send typing - -- indicators, so we don't have to create another conv. - selfConvId <- objQidObject alice + -- Self conv ID is same as user's ID, we'll use this to send typing + -- indicators, so we don't have to create another conv. + selfConvId <- objQidObject alice - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - consumeAllEvents eventsChan ackChan - sendTypingStatus alice selfConvId "started" >>= assertSuccess - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "conversation.typing" - e %. "data.event.payload.0.qualified_conversation" `shouldMatch` selfConvId - deliveryTag <- e %. "data.delivery_tag" - sendAck ackChan deliveryTag False + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + consumeAllEvents eventsChan ackChan + sendTypingStatus alice selfConvId "started" >>= assertSuccess + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "conversation.typing" + e %. "data.event.payload.0.qualified_conversation" `shouldMatch` selfConvId + deliveryTag <- e %. "data.delivery_tag" + sendAck ackChan deliveryTag False - handle1 <- randomHandle - putHandle alice handle1 >>= assertSuccess + handle1 <- randomHandle + putHandle alice handle1 >>= assertSuccess - sendTypingStatus alice selfConvId "stopped" >>= assertSuccess + sendTypingStatus alice selfConvId "stopped" >>= assertSuccess - handle2 <- randomHandle - putHandle alice handle2 >>= assertSuccess + handle2 <- randomHandle + putHandle alice handle2 >>= assertSuccess - -- We shouldn't see the stopped typing status because we were not connected to - -- the websocket when it was sent. The other events should still show up in - -- order. - withEventsWebSocket alice clientId $ \eventsChan ackChan -> do - for_ [handle1, handle2] $ \handle -> - assertEvent eventsChan $ \e -> do - e %. "data.event.payload.0.type" `shouldMatch` "user.update" - e %. "data.event.payload.0.user.handle" `shouldMatch` handle - ackEvent ackChan e + -- We shouldn't see the stopped typing status because we were not connected to + -- the websocket when it was sent. The other events should still show up in + -- order. + withEventsWebSocket alice clientId $ \eventsChan ackChan -> do + for_ [handle1, handle2] $ \handle -> + assertEvent eventsChan $ \e -> do + e %. "data.event.payload.0.type" `shouldMatch` "user.update" + e %. "data.event.payload.0.user.handle" `shouldMatch` handle + ackEvent ackChan e - assertNoEvent eventsChan + assertNoEvent eventsChan ---------------------------------------------------------------------- -- helpers @@ -291,6 +349,11 @@ withEventsWebSocket uid cid k = do sendMsg :: (HasCallStack) => TChan Value -> Value -> App () sendMsg eventsChan msg = liftIO $ atomically $ writeTChan eventsChan msg +ackFullSync :: (HasCallStack) => TChan Value -> App () +ackFullSync ackChan = do + sendMsg ackChan + $ object ["type" .= "ack_full_sync"] + ackEvent :: (HasCallStack) => TChan Value -> Value -> App () ackEvent ackChan event = do deliveryTag <- event %. "data.delivery_tag" @@ -311,7 +374,7 @@ sendAck ackChan deliveryTag multiple = do assertEvent :: (HasCallStack) => TChan Value -> ((HasCallStack) => Value -> App a) -> App a assertEvent eventsChan expectations = do timeout 10_000_000 (atomically (readTChan eventsChan)) >>= \case - Nothing -> assertFailure "No event received for 1s" + Nothing -> assertFailure "No event received for 10s" Just e -> do pretty <- prettyJSON e addFailureContext ("event:\n" <> pretty) diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index 0f91d48c595..f7f20c36782 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -379,11 +379,6 @@ getMLSState = do ref <- asks (.mls) liftIO $ readIORef ref -setMLSState :: MLSState -> App () -setMLSState s = do - ref <- asks (.mls) - liftIO $ writeIORef ref s - modifyMLSState :: (MLSState -> MLSState) -> App () modifyMLSState f = do ref <- asks (.mls) diff --git a/libs/extended/src/Network/AMQP/Extended.hs b/libs/extended/src/Network/AMQP/Extended.hs index 055cdd57154..4aa48aefc5b 100644 --- a/libs/extended/src/Network/AMQP/Extended.hs +++ b/libs/extended/src/Network/AMQP/Extended.hs @@ -10,6 +10,7 @@ module Network.AMQP.Extended mkRabbitMqChannelMVar, demoteOpts, RabbitMqTlsOpts (..), + mkConnectionOpts, ) where @@ -155,7 +156,6 @@ withConnection :: (Q.Connection -> m a) -> m a withConnection l AmqpEndpoint {..} k = do - (username, password) <- liftIO $ readCredsFromEnv -- Jittered exponential backoff with 1ms as starting delay and 1s as total -- wait time. let policy = limitRetriesByCumulativeDelay 1_000_000 $ fullJitterBackoff 1000 @@ -173,18 +173,23 @@ withConnection l AmqpEndpoint {..} k = do ) ( const $ do Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") - mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls - liftIO $ - Q.openConnection'' $ - Q.defaultConnectionOpts - { Q.coServers = [(host, fromIntegral port)], - Q.coVHost = vHost, - Q.coAuth = [Q.plain username password], - Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings - } + connOpts <- mkConnectionOpts AmqpEndpoint {..} + liftIO $ Q.openConnection'' connOpts ) bracket getConn (liftIO . Q.closeConnection) k +mkConnectionOpts :: (MonadIO m) => AmqpEndpoint -> m Q.ConnectionOpts +mkConnectionOpts AmqpEndpoint {..} = do + mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls + (username, password) <- liftIO $ readCredsFromEnv + pure + Q.defaultConnectionOpts + { Q.coServers = [(host, fromIntegral port)], + Q.coVHost = vHost, + Q.coAuth = [Q.plain username password], + Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings + } + -- | Connects with RabbitMQ and opens a channel. If the channel is closed for -- some reasons, reopens the channel. If the connection is closed for some -- reasons, keeps retrying to connect until it works. @@ -218,15 +223,8 @@ openConnectionWithRetries l AmqpEndpoint {..} hooks = do ) ( const $ do Log.info l $ Log.msg (Log.val "Trying to connect to RabbitMQ") - mTlsSettings <- traverse (liftIO . (mkTLSSettings host)) tls - liftIO $ - Q.openConnection'' $ - Q.defaultConnectionOpts - { Q.coServers = [(host, fromIntegral port)], - Q.coVHost = vHost, - Q.coAuth = [Q.plain username password], - Q.coTLSSettings = fmap Q.TLSCustom mTlsSettings - } + connOpts <- mkConnectionOpts AmqpEndpoint {..} + liftIO $ Q.openConnection'' connOpts ) bracket getConn (liftIO . Q.closeConnection) $ \conn -> do liftBaseWith $ \runInIO -> diff --git a/libs/jwt-tools/src/Data/Jwt/Tools.hs b/libs/jwt-tools/src/Data/Jwt/Tools.hs index e9c3ce549de..777485f6426 100644 --- a/libs/jwt-tools/src/Data/Jwt/Tools.hs +++ b/libs/jwt-tools/src/Data/Jwt/Tools.hs @@ -167,15 +167,6 @@ generateDpopToken dpopProof uid cid handle displayName tid domain nonce uri meth methodCStr <- liftIO $ newCString $ UTF8.toString $ methodToBS method backendPubkeyBundleCStr <- toCStr backendPubkeyBundle - -- log all variable inputs (can comment in if need to generate new test data) - -- traceM $ "proof = Proof " <> show (_unProof dpopProof) - -- traceM $ "uid = UserId " <> show (_unUserId uid) - -- traceM $ "nonce = Nonce " <> show (_unNonce nonce) - -- traceM $ "expires = ExpiryEpoch " <> show (_unExpiryEpoch maxExpiration) - -- traceM $ "handle = Handle " <> show (_unHandle handle) - -- traceM $ "displayName = DisplayName " <> show (_unDisplayName displayName) - -- traceM $ "tid = TeamId " <> show (_unTeamId tid) - let before = generateDpopAccessTokenFfi dpopProofCStr diff --git a/libs/types-common/src/Data/Mailbox.hs b/libs/types-common/src/Data/Mailbox.hs index c9889d051f4..1772284d932 100644 --- a/libs/types-common/src/Data/Mailbox.hs +++ b/libs/types-common/src/Data/Mailbox.hs @@ -97,8 +97,7 @@ obsNoWsCtl = do || (c == 127) ) -obsCtextParser, obsQtextParser :: Parser Char -obsCtextParser = obsNoWsCtl +obsQtextParser :: Parser Char obsQtextParser = obsNoWsCtl quotedPairParser :: Parser Char diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index fea394e5af9..b51ade2c18b 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -348,7 +348,7 @@ rethrow5xx getRequestId logger app req k = app req k' k' resp@WaiInt.ResponseRaw {} = do -- See Note [Raw Response] let logMsg = - field "canoncalpath" (show $ pathInfo req) + field "canonicalpath" (show $ pathInfo req) . field "rawpath" (rawPathInfo req) . field "request" (fromMaybe defRequestId $ getRequestId req) . msg (val "ResponseRaw - cannot collect metrics or log info on errors") diff --git a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs index cb047c617e2..4a9f9d5b7fe 100644 --- a/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs +++ b/libs/wire-api/src/Wire/API/Event/WebSocketProtocol.hs @@ -47,6 +47,7 @@ instance ToSchema EventData where data MessageServerToClient = EventMessage EventData + | EventFullSync deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform MessageServerToClient) @@ -54,6 +55,7 @@ makePrisms ''MessageServerToClient data MessageClientToServer = AckMessage AckData + | AckFullSync deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform MessageClientToServer) @@ -63,12 +65,16 @@ makePrisms ''MessageClientToServer -- ServerToClient -- | Local type, only needed for writing the ToSchema instance for 'MessageServerToClient'. -data MessageTypeServerToClient = MsgTypeEvent +data MessageTypeServerToClient = MsgTypeEventMessage | MsgTypeEventFullSync deriving (Eq, Enum, Bounded) msgTypeSchemaServerToClient :: ValueSchema NamedSwaggerDoc MessageTypeServerToClient msgTypeSchemaServerToClient = - enum @Text "MessageTypeServerToClient" $ mconcat $ [element "event" MsgTypeEvent] + enum @Text "MessageTypeServerToClient" $ + mconcat $ + [ element "event" MsgTypeEventMessage, + element "notifications.missed" MsgTypeEventFullSync + ] instance ToSchema MessageServerToClient where schema = @@ -76,14 +82,16 @@ instance ToSchema MessageServerToClient where fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaServerToClient) (snd .= untaggedSchema) where toTagged :: MessageServerToClient -> (MessageTypeServerToClient, MessageServerToClient) - toTagged d@(EventMessage _) = (MsgTypeEvent, d) + toTagged d@(EventMessage _) = (MsgTypeEventMessage, d) + toTagged d@EventFullSync = (MsgTypeEventFullSync, d) fromTagged :: (MessageTypeServerToClient, MessageServerToClient) -> MessageServerToClient fromTagged = snd untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeServerToClient) [A.Pair] (MessageServerToClient) (MessageServerToClient) untaggedSchema = dispatch $ \case - MsgTypeEvent -> tag _EventMessage (id .= field "data" schema) + MsgTypeEventMessage -> tag _EventMessage (field "data" schema) + MsgTypeEventFullSync -> tag _EventFullSync (pure ()) deriving via Schema MessageServerToClient instance FromJSON MessageServerToClient @@ -93,14 +101,15 @@ deriving via Schema MessageServerToClient instance ToJSON MessageServerToClient -- ClientToServer -- | Local type, only needed for writing the ToSchema instance for 'MessageClientToServer'. -data MessageTypeClientToServer = MsgTypeAck +data MessageTypeClientToServer = MsgTypeAckMessage | MsgTypeAckFullSync deriving (Eq, Enum, Bounded) msgTypeSchemaClientToServer :: ValueSchema NamedSwaggerDoc MessageTypeClientToServer msgTypeSchemaClientToServer = enum @Text "MessageTypeClientToServer" $ mconcat $ - [ element "ack" MsgTypeAck + [ element "ack" MsgTypeAckMessage, + element "ack_full_sync" MsgTypeAckFullSync ] instance ToSchema MessageClientToServer where @@ -109,14 +118,16 @@ instance ToSchema MessageClientToServer where fromTagged <$> toTagged .= bind (fst .= field "type" msgTypeSchemaClientToServer) (snd .= untaggedSchema) where toTagged :: MessageClientToServer -> (MessageTypeClientToServer, MessageClientToServer) - toTagged d@(AckMessage _) = (MsgTypeAck, d) + toTagged d@(AckMessage _) = (MsgTypeAckMessage, d) + toTagged d@AckFullSync = (MsgTypeAckFullSync, d) fromTagged :: (MessageTypeClientToServer, MessageClientToServer) -> MessageClientToServer fromTagged = snd untaggedSchema :: SchemaP SwaggerDoc (A.Object, MessageTypeClientToServer) [A.Pair] MessageClientToServer MessageClientToServer untaggedSchema = dispatch $ \case - MsgTypeAck -> tag _AckMessage (id .= field "data" schema) + MsgTypeAckMessage -> tag _AckMessage (field "data" schema) + MsgTypeAckFullSync -> tag _AckFullSync (pure ()) deriving via Schema MessageClientToServer instance FromJSON MessageClientToServer diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index abe7db12694..aa36224b864 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -171,14 +171,6 @@ data CheckHandleResp makeSem ''UserSubsystem -removeEmail :: - ( Member UserSubsystem r, - Member (Error UserSubsystemError) r - ) => - Local UserId -> - Sem r () -removeEmail = removeEmailEither >=> fromEither - getUserProfile :: (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) getUserProfile luid targetUser = listToMaybe <$> getUserProfiles luid [targetUser] diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 387971a5fc0..795ade421a5 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -12,6 +12,7 @@ build-type: Simple library -- cabal-fmt: expand src exposed-modules: + Wire.BackendDeadUserNotificationWatcher Wire.BackendNotificationPusher Wire.BackgroundWorker Wire.BackgroundWorker.Env @@ -29,7 +30,11 @@ library build-depends: aeson , amqp + , async , base + , bytestring + , bytestring-conversion + , cassandra-util , containers , exceptions , extended @@ -37,6 +42,7 @@ library , http-client , http2-manager , imports + , kan-extensions , metrics-wai , monad-control , prometheus-client @@ -45,6 +51,7 @@ library , servant-server , text , tinylog + , transformers , transformers-base , types-common , unliftio diff --git a/services/background-worker/background-worker.integration.yaml b/services/background-worker/background-worker.integration.yaml index c23798e63ed..9102981507b 100644 --- a/services/background-worker/background-worker.integration.yaml +++ b/services/background-worker/background-worker.integration.yaml @@ -8,6 +8,12 @@ federatorInternal: host: 127.0.0.1 port: 8097 +cassandra: + endpoint: + host: 127.0.0.1 + port: 9042 + keyspace: gundeck_test + rabbitmq: host: 127.0.0.1 port: 5671 diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 6ccf66f8ac7..7e04820200e 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -5,8 +5,11 @@ { mkDerivation , aeson , amqp +, async , base , bytestring +, bytestring-conversion +, cassandra-util , containers , data-default , exceptions @@ -20,6 +23,7 @@ , http-types , http2-manager , imports +, kan-extensions , lib , metrics-wai , monad-control @@ -51,7 +55,11 @@ mkDerivation { libraryHaskellDepends = [ aeson amqp + async base + bytestring + bytestring-conversion + cassandra-util containers exceptions extended @@ -59,6 +67,7 @@ mkDerivation { http-client http2-manager imports + kan-extensions metrics-wai monad-control prometheus-client @@ -67,6 +76,7 @@ mkDerivation { servant-server text tinylog + transformers transformers-base types-common unliftio diff --git a/services/background-worker/src/Wire/BackendDeadUserNotificationWatcher.hs b/services/background-worker/src/Wire/BackendDeadUserNotificationWatcher.hs new file mode 100644 index 00000000000..ad8c3c38254 --- /dev/null +++ b/services/background-worker/src/Wire/BackendDeadUserNotificationWatcher.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} + +module Wire.BackendDeadUserNotificationWatcher where + +import Cassandra +import Control.Concurrent (putMVar) +import Control.Monad.Codensity +import Control.Monad.Trans.Maybe +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Conversion +import Data.Id +import Data.Map qualified as Map +import Imports hiding (putMVar) +import Network.AMQP qualified as Q +import Network.AMQP.Extended +import Network.AMQP.Lifted qualified as QL +import Network.AMQP.Types +import System.Logger qualified as Log +import UnliftIO hiding (bracket, putMVar) +import UnliftIO.Exception (bracket) +import Wire.API.Notification +import Wire.BackgroundWorker.Env + +getLastDeathQueue :: Maybe FieldTable -> Maybe ByteString +getLastDeathQueue (Just (FieldTable headers)) = do + case Map.lookup "x-last-death-queue" headers of + Just (FVString str) -> pure str + _ -> Nothing +getLastDeathQueue Nothing = Nothing + +-- FUTUREWORK: what happens if messages expire _after_ we checked against cassandra here? +-- Should we have an async notification terminate this? +startConsumer :: Q.Channel -> AppT IO Q.ConsumerTag +startConsumer chan = do + env <- ask + markAsWorking BackendDeadUserNoticationWatcher + + cassandra <- asks (.cassandra) + + void . lift $ Q.declareQueue chan Q.newQueue {Q.queueName = userNotificationDlqName} + QL.consumeMsgs chan userNotificationDlqName Q.Ack $ \(msg, envelope) -> + if (msg.msgDeliveryMode == Just Q.NonPersistent) + then do + -- ignore transient messages, ack it so they don't clog the queue + lift $ Q.ackEnv envelope + else do + -- forward non-transient messages to the respective client + let dat = getLastDeathQueue msg.msgHeaders + let vals = fmap (BS.split '.') dat + case vals of + Nothing -> logHeaderError env msg.msgHeaders + Just ["user-notifications", uidBS, cidBS] -> do + m <- runMaybeT $ do + uid <- hoistMaybe $ fromByteString uidBS + cid <- hoistMaybe $ fromByteString cidBS + pure (uid, cid) + (uid, cid) <- maybe (logParseError env dat) pure m + markAsNeedsFullSync cassandra uid cid + lift $ Q.ackEnv envelope + _ -> void $ logParseError env dat + where + logHeaderError env headers = do + Log.err + env.logger + ( Log.msg (Log.val "Could not find x-last-death-queue in headers") + . Log.field "error_configuring_dead_letter_exchange" (show headers) + ) + error "Could not find x-last-death-queue in headers" + logParseError env dat = do + Log.err env.logger $ + Log.msg (Log.val "Could not parse msgHeaders into uid/cid for dead letter exchange message") + . Log.field "error_parsing_message" (show dat) + error "Could not parse msgHeaders into uid/cid for dead letter exchange message" + +markAsNeedsFullSync :: ClientState -> UserId -> ClientId -> AppT IO () +markAsNeedsFullSync cassandra uid cid = do + runClient cassandra do + retry x1 $ write missedNotifications (params LocalQuorum (uid, cid)) + where + missedNotifications :: PrepQuery W (UserId, ClientId) () + missedNotifications = + [sql| + INSERT INTO missed_notifications (user_id, client_id) + VALUES (?, ?) + |] + +startWorker :: + AmqpEndpoint -> + AppT IO (Async ()) +startWorker amqp = do + env <- ask + mVar <- newEmptyMVar + connOpts <- mkConnectionOpts amqp + + -- This function will open a connection to rabbitmq and start the consumer. + -- We use an mvar to signal when the connection is closed so we can re-open it. + -- If the empty mvar is filled, we know the connection itself was closed and we need to re-open it. + -- If the mvar is filled with a connection, we know the connection itself is fine, + -- so we only need to re-open the channel + let openConnection connM = do + mConn <- lowerCodensity $ do + conn <- case connM of + Nothing -> do + -- Open the rabbit mq connection + conn <- Codensity $ bracket (liftIO $ Q.openConnection'' connOpts) (liftIO . Q.closeConnection) + -- We need to recover from connection closed by restarting it + liftIO $ Q.addConnectionClosedHandler conn True do + Log.err env.logger $ + Log.msg (Log.val "BackendDeadUserNoticationWatcher: Connection closed.") + putMVar mVar Nothing + runAppT env $ markAsNotWorking BackendDeadUserNoticationWatcher + pure conn + Just conn -> pure conn + + -- After starting the connection, open the channel + chan <- Codensity $ bracket (liftIO $ Q.openChannel conn) (liftIO . Q.closeChannel) + + -- If the channel stops, we need to re-open + liftIO $ Q.addChannelExceptionHandler chan $ \e -> do + Log.err env.logger $ + Log.msg (Log.val "BackendDeadUserNoticationWatcher: Caught exception in RabbitMQ channel.") + . Log.field "exception" (displayException e) + runAppT env $ markAsNotWorking BackendDeadUserNoticationWatcher + putMVar mVar (Just conn) + + -- Set up the consumer + void $ Codensity $ bracket (startConsumer chan) (liftIO . Q.cancelConsumer chan) + lift $ takeMVar mVar + openConnection mConn + + async (openConnection Nothing) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 6a6cf2f7f62..f055ed0b492 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -71,7 +71,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do -- does cause problems when trying to deregister consumers from the channel. This is because -- the internal mechanism to remove a consumer goes via the same notification handling code -- as messages from the Rabbit server. If the thread is tied up in the recovery code we - -- can't cancel the consumer, and the calling code will block until the cancelation message + -- can't cancel the consumer, and the calling code will block until the cancellation message -- can be processed. -- Luckily, we can async this loop and carry on as usual due to how we have the channel setup. async $ @@ -92,7 +92,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do Left eBN -> do Log.err $ Log.msg - ( Log.val "Cannot parse a queued message as s notification " + ( Log.val "Cannot parse a queued message as a notification " <> "nor as a bundle; the message will be ignored" ) . Log.field "domain" (domainText targetDomain) @@ -201,9 +201,9 @@ pairedMaximumOn f = maximumBy (compare `on` snd) . map (id &&& f) -- Consumers is passed in explicitly so that cleanup code has a reference to the consumer tags. startPusher :: RabbitMqAdmin.AdminAPI (Servant.AsClientT IO) -> IORef (Map Domain (Q.ConsumerTag, MVar ())) -> Q.Channel -> AppT IO () startPusher adminClient consumersRef chan = do + markAsWorking BackendNotificationPusher -- This ensures that we receive notifications 1 by 1 which ensures they are -- delivered in order. - markAsWorking BackendNotificationPusher lift $ Q.qos chan 0 1 False -- Make sure threads aren't dangling if/when this async thread is killed let cleanup :: (Exception e, MonadThrow m, MonadIO m) => e -> m () @@ -291,6 +291,7 @@ getRemoteDomains adminClient = do . Log.field "queue" ("backend-notifications." <> d) . Log.field "error" e +-- FUTUREWORK: rework this in the vein of DeadLetterWatcher startWorker :: AmqpEndpoint -> AppT IO (IORef (Maybe Q.Channel), IORef (Map Domain (Q.ConsumerTag, MVar ()))) startWorker rabbitmqOpts = do env <- ask diff --git a/services/background-worker/src/Wire/BackgroundWorker.hs b/services/background-worker/src/Wire/BackgroundWorker.hs index 17b45f71ecd..d71ca7658e6 100644 --- a/services/background-worker/src/Wire/BackgroundWorker.hs +++ b/services/background-worker/src/Wire/BackgroundWorker.hs @@ -2,6 +2,7 @@ module Wire.BackgroundWorker where +import Control.Concurrent.Async (cancel) import Data.Domain import Data.Map.Strict qualified as Map import Data.Metrics.Servant qualified as Metrics @@ -14,6 +15,7 @@ import Servant import Servant.Server.Generic import System.Logger qualified as Log import Util.Options +import Wire.BackendDeadUserNotificationWatcher qualified as DeadUserNotificationWatcher import Wire.BackendNotificationPusher qualified as BackendNotificationPusher import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Health qualified as Health @@ -24,10 +26,14 @@ run opts = do env <- mkEnv opts let amqpEP = either id demoteOpts opts.rabbitmq.unRabbitMqOpts (notifChanRef, notifConsumersRef) <- runAppT env $ BackendNotificationPusher.startWorker amqpEP + deadWatcherAsync <- runAppT env $ DeadUserNotificationWatcher.startWorker amqpEP let -- cleanup will run in a new thread when the signal is caught, so we need to use IORefs and -- specific exception types to message threads to clean up l = logger env cleanup = do + -- cancel the dead letter watcher + cancel deadWatcherAsync + -- Notification pusher thread Log.info l $ Log.msg (Log.val "Cancelling the notification pusher thread") readIORef notifChanRef >>= traverse_ \chan -> do diff --git a/services/background-worker/src/Wire/BackgroundWorker/Env.hs b/services/background-worker/src/Wire/BackgroundWorker/Env.hs index dcf89d56d41..1df7805d476 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Env.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Env.hs @@ -3,6 +3,8 @@ module Wire.BackgroundWorker.Env where +import Cassandra (ClientState) +import Cassandra.Util (defInitCassandra) import Control.Monad.Base import Control.Monad.Catch import Control.Monad.Trans.Control @@ -27,6 +29,7 @@ type IsWorking = Bool -- | Eventually this will be a sum type of all the types of workers data Worker = BackendNotificationPusher + | BackendDeadUserNoticationWatcher deriving (Show, Eq, Ord) data Env = Env @@ -39,7 +42,8 @@ data Env = Env defederationTimeout :: ResponseTimeout, backendNotificationMetrics :: BackendNotificationMetrics, backendNotificationsConfig :: BackendNotificationsConfig, - statuses :: IORef (Map Worker IsWorking) + statuses :: IORef (Map Worker IsWorking), + cassandra :: ClientState } data BackendNotificationMetrics = BackendNotificationMetrics @@ -57,8 +61,9 @@ mkBackendNotificationMetrics = mkEnv :: Opts -> IO Env mkEnv opts = do - http2Manager <- initHttp2Manager logger <- Log.mkLogger opts.logLevel Nothing opts.logFormat + cassandra <- defInitCassandra opts.cassandra logger + http2Manager <- initHttp2Manager httpManager <- newManager defaultManagerSettings let federatorInternal = opts.federatorInternal defederationTimeout = diff --git a/services/background-worker/src/Wire/BackgroundWorker/Options.hs b/services/background-worker/src/Wire/BackgroundWorker/Options.hs index cdbeb1e5024..f9055d89e0b 100644 --- a/services/background-worker/src/Wire/BackgroundWorker/Options.hs +++ b/services/background-worker/src/Wire/BackgroundWorker/Options.hs @@ -14,7 +14,8 @@ data Opts = Opts rabbitmq :: !RabbitMqOpts, -- | Seconds, Nothing for no timeout defederationTimeout :: Maybe Int, - backendNotificationPusher :: BackendNotificationsConfig + backendNotificationPusher :: BackendNotificationsConfig, + cassandra :: CassandraOpts } deriving (Show, Generic) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 416a2653f82..72e1a17840f 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -267,6 +267,7 @@ spec = do ] logger <- Logger.new Logger.defSettings httpManager <- newManager defaultManagerSettings + let cassandra = undefined let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined statuses = undefined @@ -283,6 +284,7 @@ spec = do it "should retry fetching domains if a request fails" $ do mockAdmin <- newMockRabbitMqAdmin True ["backend-notifications.foo.example"] logger <- Logger.new Logger.defSettings + let cassandra = undefined httpManager <- newManager defaultManagerSettings let federatorInternal = Endpoint "localhost" 8097 http2Manager = undefined diff --git a/services/background-worker/test/Test/Wire/Util.hs b/services/background-worker/test/Test/Wire/Util.hs index 57ccf6bf0e1..fb06a79f686 100644 --- a/services/background-worker/test/Test/Wire/Util.hs +++ b/services/background-worker/test/Test/Wire/Util.hs @@ -14,6 +14,7 @@ testEnv :: IO Env testEnv = do http2Manager <- initHttp2Manager logger <- Logger.new Logger.defSettings + let cassandra = undefined statuses <- newIORef mempty backendNotificationMetrics <- mkBackendNotificationMetrics httpManager <- newManager defaultManagerSettings diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index 289639b0c40..bde50f54b41 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -303,9 +303,6 @@ insufficientTeamPermissions = errorToWai @'E.InsufficientTeamPermissions noBindingTeam :: Wai.Error noBindingTeam = Wai.mkError status403 "no-binding-team" "Operation allowed only on binding teams" -propertyManagedByScim :: LText -> Wai.Error -propertyManagedByScim prop = Wai.mkError status403 "managed-by-scim" $ "Updating \"" <> prop <> "\" is not allowed, because it is managed by SCIM" - sameBindingTeamUsers :: Wai.Error sameBindingTeamUsers = Wai.mkError status403 "same-binding-team-users" "Operation not allowed to binding team users." diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index de67c6e1531..3a46223946a 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -173,7 +173,7 @@ import Wire.UserKeyStore import Wire.UserSearch.Types import Wire.UserStore (UserStore) import Wire.UserStore qualified as UserStore -import Wire.UserSubsystem hiding (checkHandle, checkHandles, removeEmail, requestEmailChange) +import Wire.UserSubsystem hiding (checkHandle, checkHandles, requestEmailChange) import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error import Wire.UserSubsystem.UserSubsystemConfig diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 223de6c1fac..513a1075723 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -34,7 +34,6 @@ module Brig.API.User Data.lookupName, Data.lookupUser, Data.lookupRichInfoMultiUsers, - removeEmail, revokeIdentity, deleteUserNoVerify, deleteUsersNoVerify, diff --git a/services/cannon/cannon.cabal b/services/cannon/cannon.cabal index 8e3988ec1a8..4091540a846 100644 --- a/services/cannon/cannon.cabal +++ b/services/cannon/cannon.cabal @@ -87,6 +87,7 @@ library , bilge >=0.12 , bytestring >=0.10 , bytestring-conversion >=0.2 + , cassandra-util , conduit >=1.3.4.2 , data-timeout >=0.3 , exceptions >=0.6 @@ -97,6 +98,7 @@ library , hs-opentelemetry-sdk , http-types >=0.8 , imports + , kan-extensions , lens >=4.4 , lens-family-core >=1.1 , metrics-wai >=0.4 diff --git a/services/cannon/cannon.integration.yaml b/services/cannon/cannon.integration.yaml index 7af22a70b8b..9aeca3249f5 100644 --- a/services/cannon/cannon.integration.yaml +++ b/services/cannon/cannon.integration.yaml @@ -12,6 +12,12 @@ cannon: externalHost: 127.0.0.1 #externalHostFile: /etc/wire/cannon/cannon-host.txt +cassandra: + endpoint: + host: 127.0.0.1 + port: 9042 + keyspace: gundeck_test + gundeck: host: 127.0.0.1 port: 8086 diff --git a/services/cannon/default.nix b/services/cannon/default.nix index 3c1da8fca8f..80ad8b8e3ca 100644 --- a/services/cannon/default.nix +++ b/services/cannon/default.nix @@ -11,6 +11,7 @@ , bilge , bytestring , bytestring-conversion +, cassandra-util , conduit , criterion , data-timeout @@ -23,6 +24,7 @@ , hs-opentelemetry-sdk , http-types , imports +, kan-extensions , lens , lens-family-core , lib @@ -69,6 +71,7 @@ mkDerivation { bilge bytestring bytestring-conversion + cassandra-util conduit data-timeout exceptions @@ -79,6 +82,7 @@ mkDerivation { hs-opentelemetry-sdk http-types imports + kan-extensions lens lens-family-core metrics-wai diff --git a/services/cannon/src/Cannon/Options.hs b/services/cannon/src/Cannon/Options.hs index b03b6f68e98..39d0848d2b5 100644 --- a/services/cannon/src/Cannon/Options.hs +++ b/services/cannon/src/Cannon/Options.hs @@ -31,6 +31,7 @@ module Cannon.Options logFormat, drainOpts, rabbitmq, + cassandraOpts, Opts, gracePeriodSeconds, millisecondsBetweenBatches, @@ -40,6 +41,7 @@ module Cannon.Options ) where +import Cassandra.Options (CassandraOpts) import Control.Lens (makeFields) import Data.Aeson import Data.Aeson.APIFieldJsonTH @@ -95,9 +97,10 @@ data Opts = Opts _optsLogNetStrings :: !(Maybe (Last Bool)), _optsLogFormat :: !(Maybe (Last LogFormat)), _optsDrainOpts :: DrainOpts, - _optsDisabledAPIVersions :: !(Set VersionExp) + _optsDisabledAPIVersions :: !(Set VersionExp), + _optsCassandraOpts :: !CassandraOpts } - deriving (Eq, Show, Generic) + deriving (Show, Generic) makeFields ''Opts @@ -112,3 +115,4 @@ instance FromJSON Opts where <*> o .:? "logFormat" <*> o .: "drainOpts" <*> o .: "disabledAPIVersions" + <*> o .: "cassandra" diff --git a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs index 7d0ad849a2b..34af8c0530e 100644 --- a/services/cannon/src/Cannon/RabbitMqConsumerApp.hs +++ b/services/cannon/src/Cannon/RabbitMqConsumerApp.hs @@ -3,13 +3,15 @@ module Cannon.RabbitMqConsumerApp where import Cannon.App (rejectOnError) -import Cannon.WS -import Control.Concurrent.Async (race) -import Control.Exception (Handler (..), bracket, catch, catches, throwIO) +import Cannon.WS hiding (env) +import Cassandra as C +import Control.Concurrent.Async +import Control.Exception (Handler (..), bracket, catch, catches, throwIO, try) +import Control.Monad.Codensity import Data.Aeson import Data.Id import Imports -import Network.AMQP qualified as Amqp +import Network.AMQP qualified as Q import Network.AMQP.Extended (withConnection) import Network.WebSockets import Network.WebSockets qualified as WS @@ -19,124 +21,239 @@ import Wire.API.Notification rabbitMQWebSocketApp :: UserId -> ClientId -> Env -> ServerApp rabbitMQWebSocketApp uid cid e pendingConn = do - wsConn <- liftIO (acceptRequest pendingConn `catch` rejectOnError pendingConn) - -- FUTUREWORK: Pool connections: https://wearezeta.atlassian.net/browse/WPB-11491 - withConnection e.logg e.rabbitmq $ \conn -> do - bracket (Amqp.openChannel conn) (Amqp.closeChannel) $ \chan -> do - closeWS <- newEmptyMVar - bracket (startWsSender wsConn chan closeWS) (Amqp.cancelConsumer chan) $ \_ -> do - wsReceiverLoop wsConn chan closeWS + wsVar <- newEmptyMVar + msgVar <- newEmptyMVar + + bracket (openWebSocket wsVar) closeWebSocket $ \(wsConn, _) -> + ( do + sendFullSyncMessageIfNeeded wsVar wsConn uid cid e + sendNotifications wsConn msgVar wsVar + ) + `catches` [ handleClientMisbehaving wsConn, + handleWebSocketExceptions wsConn + ] where logClient = Log.field "user" (idToText uid) . Log.field "client" (clientToText cid) - pushEventsToWS :: WS.Connection -> (Amqp.Message, Amqp.Envelope) -> IO () - pushEventsToWS wsConn (msg, envelope) = - case eitherDecode @(QueuedNotification) msg.msgBody of - Left err -> do - Log.err e.logg $ - Log.msg (Log.val "failed to decode event from the queue as a JSON") - . logClient - . Log.field "parse_error" err - -- This message cannot be parsed, make sure it doesn't requeue. There - -- is no need to throw an error and kill the websocket as this is - -- probably caused by a bug or someone messing with RabbitMQ. - -- - -- The bug case is slightly dangerous as it could drop a lot of events - -- en masse, if at some point we decide that Events should not be - -- pushed as JSONs, hopefully we think of the parsing side if/when - -- that happens. - Amqp.rejectEnv envelope False - Right event -> do - Log.debug e.logg $ Log.msg (Log.val "got event") . logClient . Log.field "event" (encode event) - WS.sendBinaryData wsConn - . encode - . EventMessage - $ EventData {deliveryTag = envelope.envDeliveryTag, ..} - - startWsSender :: Connection -> Amqp.Channel -> MVar () -> IO Amqp.ConsumerTag - startWsSender wsConn chan closeWS = do - let handleException :: (Exception e) => e -> IO () - handleException err = do - Log.err e.logg $ - Log.msg (Log.val "Pushing to WS failed, closing connection") - . Log.field "error" (displayException err) + openWebSocket wsVar = do + wsConn <- + acceptRequest pendingConn + `catch` rejectOnError pendingConn + -- start a reader thread for client messages + -- this needs to run asynchronously in order to promptly react to + -- client-side connection termination + a <- async $ forever $ do + catch + ( do + msg <- getClientMessage wsConn + putMVar wsVar (Right msg) + ) + $ \err -> putMVar wsVar (Left err) + pure (wsConn, a) + + -- this is only needed in case of asynchronous exceptions + closeWebSocket (wsConn, a) = do + cancel a + logCloseWebsocket + -- ignore any exceptions when sending the close message + void . try @SomeException $ WS.sendClose wsConn ("" :: ByteString) + + -- Create a rabbitmq consumer that receives messages and saves them into an MVar + createConsumer :: + Q.Channel -> + MVar (Either Q.AMQPException EventData) -> + IO Q.ConsumerTag + createConsumer chan msgVar = do + Q.consumeMsgs chan (clientNotificationQueueName uid cid) Q.Ack $ + \(msg, envelope) -> case eitherDecode @QueuedNotification msg.msgBody of + Left err -> do + logParseError err + -- This message cannot be parsed, make sure it doesn't requeue. There + -- is no need to throw an error and kill the websocket as this is + -- probably caused by a bug or someone messing with RabbitMQ. + -- + -- The bug case is slightly dangerous as it could drop a lot of events + -- en masse, if at some point we decide that Events should not be + -- pushed as JSONs, hopefully we think of the parsing side if/when + -- that happens. + Q.rejectEnv envelope False + Right notif -> + putMVar msgVar . Right $ + EventData notif envelope.envDeliveryTag + + handleWebSocketExceptions wsConn = + Handler $ + \(err :: WS.ConnectionException) -> do + case err of + CloseRequest code reason -> + Log.debug e.logg $ + Log.msg (Log.val "Client requested to close connection") + . Log.field "status_code" code + . Log.field "reason" reason + . logClient + ConnectionClosed -> + Log.info e.logg $ + Log.msg (Log.val "Client closed tcp connection abruptly") + . logClient + _ -> do + Log.info e.logg $ + Log.msg (Log.val "Failed to receive message, closing websocket") + . Log.field "error" (displayException err) + . logClient + WS.sendCloseCode wsConn 1003 ("websocket-failure" :: ByteString) + + handleClientMisbehaving wsConn = + Handler $ \(err :: WebSocketServerError) -> do + case err of + FailedToParseClientMessage _ -> do + Log.info e.logg $ + Log.msg (Log.val "Failed to parse received message, closing websocket") . logClient - void $ tryPutMVar closeWS () - throwIO err - - exceptionHandlers = - [ Handler $ handleException @SomeException, - Handler $ handleException @SomeAsyncException - ] - - qName = clientNotificationQueueName uid cid - - Amqp.consumeMsgs chan qName Amqp.Ack $ \msgWithEnv -> - pushEventsToWS wsConn msgWithEnv `catches` exceptionHandlers - - wsReceiverLoop :: Connection -> Amqp.Channel -> MVar () -> IO () - wsReceiverLoop wsConn chan closeWS = do - let loop = do - -- no timeout necessary here, we want to keep running forever. - eitherData <- race (takeMVar closeWS) (WS.receiveData wsConn) - case eitherData of - Left _closeWS -> do - Log.debug e.logg $ - Log.msg (Log.val "Closing the websocket") - . logClient - WS.sendClose wsConn ("" :: ByteString) - Right dat -> case eitherDecode @MessageClientToServer dat of - Left err -> do - Log.info e.logg $ - Log.msg (Log.val "Failed to parse received message, closing websocket") - . logClient - WS.sendCloseCode wsConn 1003 ("failed-to-parse" :: ByteString) - throwIO $ FailedToParseClientMessage err - Right (AckMessage ackData) -> do - Log.debug e.logg $ - Log.msg (Log.val "Received ACK") - . Log.field "delivery_tag" ackData.deliveryTag - . Log.field "multiple" ackData.multiple - . logClient - void $ Amqp.ackMsg chan ackData.deliveryTag ackData.multiple - loop - - handleConnectionClosed :: ConnectionException -> IO () - handleConnectionClosed connException = do - case connException of - CloseRequest code reason -> - Log.debug e.logg $ - Log.msg (Log.val "Client requested to close connection") - . Log.field "status_code" code - . Log.field "reason" reason - . logClient - ConnectionClosed -> - Log.info e.logg $ - Log.msg (Log.val "Client closed tcp connection abruptly") - . logClient - _ -> do - Log.info e.logg $ - Log.msg (Log.val "Failed to receive message, closing websocket") - . Log.field "error" (displayException connException) - . logClient - WS.send wsConn (WS.ControlMessage $ WS.Close 1003 "failed-to-parse") - handleException :: (Exception e) => e -> IO () - handleException err = do - Log.err e.logg $ - Log.msg (Log.val "Unexpected exception in receive loop") - . Log.field "error" (displayException err) + WS.sendCloseCode wsConn 1003 ("failed-to-parse" :: ByteString) + UnexpectedAck -> do + Log.info e.logg $ + Log.msg (Log.val "Client sent unexpected ack message") . logClient - throwIO err - loop - `catches` [ Handler $ handleConnectionClosed, - Handler $ handleException @SomeException, - Handler $ handleException @SomeAsyncException - ] + WS.sendCloseCode wsConn 1003 ("unexpected-ack" :: ByteString) + sendNotifications :: + WS.Connection -> + MVar (Either Q.AMQPException EventData) -> + MVar (Either ConnectionException MessageClientToServer) -> + IO () + sendNotifications wsConn msgVar wsVar = lowerCodensity $ do + -- create rabbitmq connection + conn <- Codensity $ withConnection e.logg e.rabbitmq + + -- create rabbitmq channel + amqpChan <- Codensity $ bracket (Q.openChannel conn) Q.closeChannel + + -- propagate rabbitmq connection failure + lift $ Q.addConnectionClosedHandler conn True $ do + putMVar msgVar $ + Left (Q.ConnectionClosedException Q.Normal "") + + -- register consumer that pushes rabbitmq messages into msgVar + void $ + Codensity $ + bracket + (createConsumer amqpChan msgVar) + (Q.cancelConsumer amqpChan) + + -- get data from msgVar and push to client + let consumeRabbitMq = forever $ do + eventData' <- takeMVar msgVar + either throwIO pure eventData' >>= \eventData -> do + logEvent eventData.event + catch (WS.sendBinaryData wsConn (encode (EventMessage eventData))) $ + \(err :: SomeException) -> do + logSendFailure err + throwIO err + + -- get ack from wsVar and forward to rabbitmq + let consumeWebsocket = forever $ do + v <- takeMVar wsVar + either throwIO pure v >>= \case + AckFullSync -> throwIO UnexpectedAck + AckMessage ackData -> do + logAckReceived ackData + void $ Q.ackMsg amqpChan ackData.deliveryTag ackData.multiple + + -- run both loops concurrently, so that + -- - notifications are delivered without having to wait for acks + -- - exceptions on either side do not cause a deadlock + lift $ concurrently_ consumeRabbitMq consumeWebsocket + + logParseError :: String -> IO () + logParseError err = + Log.err e.logg $ + Log.msg (Log.val "failed to decode event from the queue as a JSON") + . logClient + . Log.field "parse_error" err + + logEvent :: QueuedNotification -> IO () + logEvent event = + Log.debug e.logg $ + Log.msg (Log.val "got event") + . logClient + . Log.field "event" (encode event) + + logSendFailure :: SomeException -> IO () + logSendFailure err = + Log.err e.logg $ + Log.msg (Log.val "Pushing to WS failed, closing connection") + . Log.field "error" (displayException err) + . logClient + + logAckReceived :: AckData -> IO () + logAckReceived ackData = + Log.debug e.logg $ + Log.msg (Log.val "Received ACK") + . Log.field "delivery_tag" ackData.deliveryTag + . Log.field "multiple" ackData.multiple + . logClient + + logCloseWebsocket :: IO () + logCloseWebsocket = + Log.debug e.logg $ + Log.msg (Log.val "Closing the websocket") + . logClient + +-- | Check if client has missed messages. If so, send a full synchronisation +-- message and wait for the corresponding ack. +sendFullSyncMessageIfNeeded :: + MVar (Either ConnectionException MessageClientToServer) -> + WS.Connection -> + UserId -> + ClientId -> + Env -> + IO () +sendFullSyncMessageIfNeeded wsVar wsConn uid cid env = do + row <- C.runClient env.cassandra do + retry x5 $ query1 q (params LocalQuorum (uid, cid)) + for_ row $ \_ -> sendFullSyncMessage uid cid wsVar wsConn env + where + q :: PrepQuery R (UserId, ClientId) (Identity (Maybe UserId)) + q = + [sql| SELECT user_id FROM missed_notifications + WHERE user_id = ? and client_id = ? + |] + +sendFullSyncMessage :: + UserId -> + ClientId -> + MVar (Either ConnectionException MessageClientToServer) -> + WS.Connection -> + Env -> + IO () +sendFullSyncMessage uid cid wsVar wsConn env = do + let event = encode EventFullSync + WS.sendBinaryData wsConn event + res <- takeMVar wsVar >>= either throwIO pure + case res of + AckMessage _ -> throwIO UnexpectedAck + AckFullSync -> + C.runClient env.cassandra do + retry x1 $ write delete (params LocalQuorum (uid, cid)) + where + delete :: PrepQuery W (UserId, ClientId) () + delete = + [sql| + DELETE FROM missed_notifications + WHERE user_id = ? and client_id = ? + |] + +getClientMessage :: WS.Connection -> IO MessageClientToServer +getClientMessage wsConn = do + msg <- WS.receiveData wsConn + case eitherDecode msg of + Left err -> throwIO (FailedToParseClientMessage err) + Right m -> pure m data WebSocketServerError = FailedToParseClientMessage String + | UnexpectedAck deriving (Show) instance Exception WebSocketServerError diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs index 4f588c209ab..cfb5806a3ff 100644 --- a/services/cannon/src/Cannon/Run.hs +++ b/services/cannon/src/Cannon/Run.hs @@ -29,6 +29,7 @@ import Cannon.Dict qualified as D import Cannon.Options import Cannon.Types (Cannon, applog, clients, env, mkEnv, runCannon, runCannonToServant) import Cannon.WS hiding (drainOpts, env) +import Cassandra.Util (defInitCassandra) import Control.Concurrent import Control.Concurrent.Async qualified as Async import Control.Exception qualified as E @@ -72,8 +73,9 @@ run o = withTracer \tracer -> do error "drainOpts.gracePeriodSeconds must not be set to 0." ext <- loadExternal g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) (o ^. logFormat) + cassandra <- defInitCassandra (o ^. cassandraOpts) g e <- - mkEnv ext o g + mkEnv ext o cassandra g <$> D.empty 128 <*> newManager defaultManagerSettings {managerConnCount = 128} <*> createSystemRandom diff --git a/services/cannon/src/Cannon/Types.hs b/services/cannon/src/Cannon/Types.hs index e1da89a70af..c37f2d9f68c 100644 --- a/services/cannon/src/Cannon/Types.hs +++ b/services/cannon/src/Cannon/Types.hs @@ -18,11 +18,7 @@ -- with this program. If not, see . module Cannon.Types - ( Env, - opts, - applog, - dict, - env, + ( Env (..), Cannon, mapConcurrentlyCannon, mkEnv, @@ -39,6 +35,7 @@ import Cannon.Dict (Dict) import Cannon.Options import Cannon.WS (Clock, Key, Websocket) import Cannon.WS qualified as WS +import Cassandra (ClientState) import Control.Concurrent.Async (mapConcurrently) import Control.Lens ((^.)) import Control.Monad.Catch @@ -95,6 +92,7 @@ instance HasRequestId Cannon where mkEnv :: ByteString -> Opts -> + ClientState -> Logger -> Dict Key Websocket -> Manager -> @@ -102,9 +100,9 @@ mkEnv :: Clock -> AmqpEndpoint -> Env -mkEnv external o l d p g t rabbitmqOpts = +mkEnv external o cs l d p g t rabbitmqOpts = Env o l d (RequestId defRequestId) $ - WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) rabbitmqOpts + WS.env external (o ^. cannon . port) (encodeUtf8 $ o ^. gundeck . host) (o ^. gundeck . port) l p d g t (o ^. drainOpts) rabbitmqOpts cs runCannon :: Env -> Cannon a -> IO a runCannon e c = runReaderT (unCannon c) e diff --git a/services/cannon/src/Cannon/WS.hs b/services/cannon/src/Cannon/WS.hs index ae3cfd82bd1..b6be5e5b2ba 100644 --- a/services/cannon/src/Cannon/WS.hs +++ b/services/cannon/src/Cannon/WS.hs @@ -52,6 +52,7 @@ import Bilge.Retry import Cannon.Dict (Dict) import Cannon.Dict qualified as D import Cannon.Options (DrainOpts, gracePeriodSeconds, millisecondsBetweenBatches, minBatchSize) +import Cassandra (ClientState) import Conduit import Control.Concurrent.Timeout import Control.Lens ((^.)) @@ -147,7 +148,8 @@ data Env = Env rand :: !GenIO, clock :: !Clock, drainOpts :: DrainOpts, - rabbitmq :: !AmqpEndpoint + rabbitmq :: !AmqpEndpoint, + cassandra :: ClientState } setRequestId :: RequestId -> Env -> Env @@ -194,6 +196,7 @@ env :: Clock -> DrainOpts -> AmqpEndpoint -> + ClientState -> Env env leh lp gh gp = Env leh lp (Bilge.host gh . Bilge.port gp $ empty) (RequestId defRequestId) diff --git a/services/gundeck/gundeck.cabal b/services/gundeck/gundeck.cabal index b5014de85c1..75b62eccb54 100644 --- a/services/gundeck/gundeck.cabal +++ b/services/gundeck/gundeck.cabal @@ -46,6 +46,7 @@ library Gundeck.Schema.V1 Gundeck.Schema.V10 Gundeck.Schema.V11 + Gundeck.Schema.V12 Gundeck.Schema.V2 Gundeck.Schema.V3 Gundeck.Schema.V4 diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index 4f1624a9c8c..486ab4b63c8 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -19,12 +19,15 @@ module Gundeck.Client where import Control.Lens (view) import Data.Id +import Data.Map qualified as Map +import Data.Text.Encoding (encodeUtf8) import Gundeck.Monad import Gundeck.Notification.Data qualified as Notifications import Gundeck.Push.Data qualified as Push import Gundeck.Push.Native import Imports import Network.AMQP +import Network.AMQP.Types import Wire.API.Notification unregister :: UserId -> ClientId -> Gundeck () @@ -48,7 +51,24 @@ setupConsumableNotifications :: IO Text setupConsumableNotifications chan uid cid = do let qName = clientNotificationQueueName uid cid - void $ declareQueue chan newQueue {queueName = qName} + void $ + declareQueue + chan + newQueue + { queueName = qName, + -- TODO: make this less ugly to read + queueHeaders = + FieldTable $ + Map.fromList + [ ( "x-dead-letter-exchange", + FVString $ + encodeUtf8 userNotificationDlxName + ), + ( "x-dead-letter-routing-key", + FVString $ encodeUtf8 userNotificationDlqName + ) + ] + } for_ [userRoutingKey uid, clientRoutingKey uid cid] $ bindQueue chan qName userNotificationExchangeName pure qName diff --git a/services/gundeck/src/Gundeck/Schema/Run.hs b/services/gundeck/src/Gundeck/Schema/Run.hs index 247f7a69488..34dfebd09df 100644 --- a/services/gundeck/src/Gundeck/Schema/Run.hs +++ b/services/gundeck/src/Gundeck/Schema/Run.hs @@ -23,6 +23,7 @@ import Control.Exception (finally) import Gundeck.Schema.V1 qualified as V1 import Gundeck.Schema.V10 qualified as V10 import Gundeck.Schema.V11 qualified as V11 +import Gundeck.Schema.V12 qualified as V12 import Gundeck.Schema.V2 qualified as V2 import Gundeck.Schema.V3 qualified as V3 import Gundeck.Schema.V4 qualified as V4 @@ -63,5 +64,6 @@ migrations = V8.migration, V9.migration, V10.migration, - V11.migration + V11.migration, + V12.migration ] diff --git a/services/gundeck/src/Gundeck/Schema/V12.hs b/services/gundeck/src/Gundeck/Schema/V12.hs new file mode 100644 index 00000000000..ad2a638f51a --- /dev/null +++ b/services/gundeck/src/Gundeck/Schema/V12.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Gundeck.Schema.V12 (migration) where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 12 "Create table `missed_notifications`" $ do + schema' + [r| + CREATE TABLE missed_notifications ( + user_id uuid, + client_id text, + PRIMARY KEY (user_id, client_id) + ); + |] From 938fea48ff936b0b86d7ad7e10a44634340d860b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 12 Nov 2024 11:09:13 +0100 Subject: [PATCH 93/93] Update a change log to reflect changes from PR #4317 --- changelog.d/1-api-changes/WPB-10308 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/changelog.d/1-api-changes/WPB-10308 b/changelog.d/1-api-changes/WPB-10308 index d9ebca156ec..3f5e043e42a 100644 --- a/changelog.d/1-api-changes/WPB-10308 +++ b/changelog.d/1-api-changes/WPB-10308 @@ -1 +1,3 @@ -New endpoint `GET /events` for consuming events is added +New endpoint `GET /events` for consuming events is added. + +When a client misses notifications because it was offline for too long, it needs to know this information so it can do a full synchronisation. This appears as the first notification in `GET /events` endpoint whenever the system detects this happening. The next acknowledgement of the message makes this notification not appear anymore until the next notification is missed.