From 502fb55846e97c3b34d38d60006847428ba45494 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 18 Jan 2024 16:03:38 +0100 Subject: [PATCH 01/52] Define the version range type This commit does not make any application logic use of it just yet --- .../API/Federation/API/Brig/Notifications.hs | 2 + .../Federation/API/Galley/Notifications.hs | 6 ++ .../API/Federation/HasNotificationEndpoint.hs | 7 +- .../src/Wire/API/Federation/Version.hs | 84 ++++++++++++++++++- 4 files changed, 96 insertions(+), 3 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs index 931febcf4b6..1f7b697dd74 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs @@ -25,6 +25,7 @@ import Imports import Wire.API.Federation.Component import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint +import Wire.API.Federation.Version import Wire.API.Util.Aeson import Wire.Arbitrary @@ -49,6 +50,7 @@ instance IsNotificationTag BrigNotificationTag where instance HasNotificationEndpoint 'OnUserDeletedConnectionsTag where type Payload 'OnUserDeletedConnectionsTag = UserDeletedConnectionsNotification type NotificationPath 'OnUserDeletedConnectionsTag = "on-user-deleted-connections" + versionRange = AllVersions instance ToSchema UserDeletedConnectionsNotification diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index 9f9e1ee589e..b73448c05f4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -34,6 +34,7 @@ import Wire.API.Conversation.Action import Wire.API.Federation.Component import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint +import Wire.API.Federation.Version import Wire.API.MLS.SubConversation import Wire.API.Message import Wire.API.Util.Aeson @@ -53,26 +54,31 @@ instance IsNotificationTag GalleyNotificationTag where instance HasNotificationEndpoint 'OnClientRemovedTag where type Payload 'OnClientRemovedTag = ClientRemovedRequest type NotificationPath 'OnClientRemovedTag = "on-client-removed" + versionRange = AllVersions -- used to notify this backend that a new message has been posted to a -- remote conversation instance HasNotificationEndpoint 'OnMessageSentTag where type Payload 'OnMessageSentTag = RemoteMessage ConvId type NotificationPath 'OnMessageSentTag = "on-message-sent" + versionRange = AllVersions instance HasNotificationEndpoint 'OnMLSMessageSentTag where type Payload 'OnMLSMessageSentTag = RemoteMLSMessage type NotificationPath 'OnMLSMessageSentTag = "on-mls-message-sent" + versionRange = AllVersions -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" + versionRange = AllVersions instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification type NotificationPath 'OnUserDeletedConversationsTag = "on-user-deleted-conversations" + versionRange = AllVersions -- | All the notification endpoints return an 'EmptyResponse'. type GalleyNotificationAPI = diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index c2f5772a255..4de57cfc344 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -27,6 +27,7 @@ import GHC.TypeLits import Imports import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Component +import Wire.API.Federation.Version import Wire.API.RawJson class IsNotificationTag k where @@ -40,6 +41,9 @@ class HasNotificationEndpoint t where -- "on-conversation-updated". type NotificationPath t :: Symbol + -- | The federation API version range this endpoint is supported in. + versionRange :: VersionRange + -- | Convert a federation endpoint to a backend notification to be enqueued to a -- RabbitMQ queue. fedNotifToBackendNotif :: @@ -47,13 +51,14 @@ fedNotifToBackendNotif :: KnownSymbol (NotificationPath tag) => KnownComponent (NotificationComponent k) => ToJSON (Payload tag) => + HasNotificationEndpoint tag => RequestId -> Domain -> Payload tag -> BackendNotification fedNotifToBackendNotif rid ownDomain payload = let p = T.pack . symbolVal $ Proxy @(NotificationPath tag) - b = RawJson . encode $ payload + b = RawJson . encode $ (payload, versionRange @tag) in toNotif p b where toNotif :: Text -> RawJson -> BackendNotification diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index b1e29cf520e..8a51c95b729 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -17,9 +17,20 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.Version where +module Wire.API.Federation.Version + ( Version (..), + V0Sym0, + V1Sym0, + versionInt, + supportedVersions, + VersionInfo (..), + versionInfo, + VersionRange (..), + ) +where -import Control.Lens ((?~)) +import Control.Lens (makePrisms, (?~)) +import Control.Lens.Tuple (_1) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.OpenApi qualified as S import Data.Schema @@ -66,6 +77,75 @@ instance ToSchema VersionInfo where versionInfo :: VersionInfo versionInfo = VersionInfo (toList supportedVersions) +---------------------------------------------------------------------- + +data VersionRangeTag + = VersionRangeTagAll + | VersionRangeTagFrom + | VersionRangeTagUntil + | VersionRangeTagFromUntil + deriving (Eq, Enum, Bounded) + +versionRangeTagSchema :: ValueSchema NamedSwaggerDoc VersionRangeTag +versionRangeTagSchema = + enum @Text "VersionRange Tag" $ + mconcat + [ element "all-versions" VersionRangeTagAll, + element "from" VersionRangeTagFrom, + element "until" VersionRangeTagUntil, + element "from-until" VersionRangeTagFromUntil + ] + +versionPairSchema :: ValueSchema NamedSwaggerDoc (Version, Version) +versionPairSchema = + object "VersionPair" $ + (,) + <$> fst .= field "from" schema + <*> snd .= field "until" schema + +data VersionRange + = AllVersions + | -- | The version in the argument represent an inclusive bound. + FromVersion Version + | -- | The version in the argument represent an exclusive bound. + UntilVersion Version + | -- | The second argument represents an exclusive upper bound. + FromUntilVersion Version Version + +deriving instance Eq VersionRange + +deriving instance Ord VersionRange + +makePrisms ''VersionRange + +instance ToSchema VersionRange where + schema = + object "VersionRange" $ + fromTagged + <$> toTagged + .= bind + (fst .= field "tag" versionRangeTagSchema) + (snd .= fieldOver _1 "value" untaggedSchema) + where + toTagged :: VersionRange -> (VersionRangeTag, VersionRange) + toTagged d@AllVersions = (VersionRangeTagAll, d) + toTagged d@(FromVersion _) = (VersionRangeTagFrom, d) + toTagged d@(UntilVersion _) = (VersionRangeTagUntil, d) + toTagged d@(FromUntilVersion _ _) = (VersionRangeTagFromUntil, d) + + fromTagged :: (VersionRangeTag, VersionRange) -> VersionRange + fromTagged = snd + + untaggedSchema = dispatch $ \case + VersionRangeTagAll -> tag _AllVersions null_ + VersionRangeTagFrom -> tag _FromVersion (unnamed schema) + VersionRangeTagUntil -> tag _UntilVersion (unnamed schema) + VersionRangeTagFromUntil -> tag _FromUntilVersion $ unnamed versionPairSchema + +deriving via Schema VersionRange instance ToJSON VersionRange + +deriving via Schema VersionRange instance FromJSON VersionRange + $(genSingletons [''Version]) $(promoteOrdInstances [''Version]) From 7f2a3162fee3241e5d4b37472e4d1bfebea9dbfd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 18 Jan 2024 16:56:03 +0100 Subject: [PATCH 02/52] Pass the version range to a BackendNotification --- .../src/Wire/API/Federation/BackendNotifications.hs | 6 ++++++ .../src/Wire/API/Federation/HasNotificationEndpoint.hs | 3 ++- libs/wire-api-federation/src/Wire/API/Federation/Version.hs | 2 ++ .../test/Test/Wire/BackendNotificationPusherSpec.hs | 2 ++ 4 files changed, 12 insertions(+), 1 deletion(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index b3cb2546ab4..b3b905dfcd5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -20,6 +20,7 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Error +import Wire.API.Federation.Version import Wire.API.RawJson -- | NOTE: Stored in RabbitMQ, any changes to serialization of this object could cause @@ -33,6 +34,9 @@ data BackendNotification = BackendNotification -- pusher. This also makes development less clunky as we don't have to -- create a sum type here for all types of notifications that could exist. body :: RawJson, + -- | The federation API versions that the 'body' corresponds to. The field + -- is optional so that messages already in the queue are not lost. + bodyVersions :: Maybe VersionRange, requestId :: Maybe RequestId } deriving (Show, Eq) @@ -44,6 +48,7 @@ instance ToJSON BackendNotification where "targetComponent" .= notif.targetComponent, "path" .= notif.path, "body" .= TL.decodeUtf8 notif.body.rawJsonBytes, + "bodyVersions" .= notif.bodyVersions, "requestId" .= notif.requestId ] @@ -54,6 +59,7 @@ instance FromJSON BackendNotification where <*> o .: "targetComponent" <*> o .: "path" <*> (RawJson . TL.encodeUtf8 <$> o .: "body") + <*> o .:? "bodyVersions" <*> o .:? "requestId" type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index 4de57cfc344..4fe5eaf8815 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -58,7 +58,7 @@ fedNotifToBackendNotif :: BackendNotification fedNotifToBackendNotif rid ownDomain payload = let p = T.pack . symbolVal $ Proxy @(NotificationPath tag) - b = RawJson . encode $ (payload, versionRange @tag) + b = RawJson . encode $ payload in toNotif p b where toNotif :: Text -> RawJson -> BackendNotification @@ -68,5 +68,6 @@ fedNotifToBackendNotif rid ownDomain payload = targetComponent = componentVal @(NotificationComponent k), path = path, body = body, + bodyVersions = Just $ versionRange @tag, requestId = Just rid } diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 8a51c95b729..b365df07df2 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -114,6 +114,8 @@ data VersionRange deriving instance Eq VersionRange +deriving instance Show VersionRange + deriving instance Ord VersionRange makePrisms ''VersionRange diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 2a458b6990e..2b2c6052a91 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -64,6 +64,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, + bodyVersions = Nothing, requestId = Just $ RequestId "N/A" } envelope <- newMockEnvelope @@ -131,6 +132,7 @@ spec = do ownDomain = origDomain, path = "/on-user-deleted-connections", body = RawJson $ Aeson.encode notifContent, + bodyVersions = Nothing, requestId = Just $ RequestId "N/A" } envelope <- newMockEnvelope From 721193773b89a2ea2c30f6514f824463573027d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 19 Jan 2024 14:58:16 +0100 Subject: [PATCH 03/52] Utility: compute a version in common --- .../src/Wire/API/Federation/Version.hs | 38 +++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index b365df07df2..e734c505e4c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -26,6 +26,7 @@ module Wire.API.Federation.Version VersionInfo (..), versionInfo, VersionRange (..), + versionInCommon, ) where @@ -47,6 +48,9 @@ versionInt :: Version -> Int versionInt V0 = 0 versionInt V1 = 1 +intToVersion :: Int -> Maybe Version +intToVersion intV = find (\v -> versionInt v == intV) [minBound .. maxBound] + instance ToSchema Version where schema = enum @Integer "Version" . mconcat $ @@ -148,6 +152,40 @@ deriving via Schema VersionRange instance ToJSON VersionRange deriving via Schema VersionRange instance FromJSON VersionRange +-- | Compute the lower and upper boundary of a version range. The first +-- component of the pair is the lower boundary, while the second component is +-- the upper boundary. The upper boundary is inclusive. +versionRangeToBoundaries :: VersionRange -> (Version, Version) +versionRangeToBoundaries AllVersions = (minBound @Version, maxBound @Version) +versionRangeToBoundaries (FromVersion fv) = (fv, maxBound @Version) +versionRangeToBoundaries (UntilVersion uv) = (minBound @Version, pred uv) +versionRangeToBoundaries (FromUntilVersion fv uv) = (fv, pred uv) + +-- | Checks if a version is within a given version range. +inVersionRange :: Version -> VersionRange -> Bool +inVersionRange v vr = + let (lo, hi) = versionRangeToBoundaries vr + in lo <= v && v < hi + +-- | For a version range of a local backend and for a set of versions that a +-- remote backend supports, compute the newest version supported by both. The +-- remote versions are given as integers as the range of versions supported by +-- the remote backend can include a version unknown to the local backend. If +-- there is no version in common, the return value is 'Nothing'. +versionInCommon :: VersionRange -> Set Int -> Maybe Version +versionInCommon localVersions remoteVersions = + foldl' f Nothing (Set.map inRange remoteVersions) + where + inRange :: Int -> Maybe Version + inRange i = do + v <- intToVersion i + guard (v `inVersionRange` localVersions) $> v + + f :: Maybe Version -> Maybe Version -> Maybe Version + f Nothing mv = mv + f (Just m) (Just v) = Just $ m `max` v + f v Nothing = v + $(genSingletons [''Version]) $(promoteOrdInstances [''Version]) From 86c617affd27e34b1b128fcd7aa2f32fc9316dd6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 24 Jan 2024 12:13:44 +0100 Subject: [PATCH 04/52] Parameterise version negotiation Instead of directly looking into 'supportedVersions', parameterise the function by taking as input a set of versions. This makes it usable for negotiation based on an endpoint's version range. --- .../src/Wire/API/Federation/Client.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 648a4ee3ec6..674fdfb8727 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -306,7 +306,7 @@ runFederatorClientToCodensity env action = runExceptT $ do v <- runVersionedFederatorClientToCodensity (FederatorClientVersionedEnv env Nothing) - versionNegotiation + (versionNegotiation supportedVersions) runVersionedFederatorClientToCodensity @c (FederatorClientVersionedEnv env (Just v)) action @@ -323,8 +323,8 @@ runVersionedFederatorClientToCodensity env = where unmaybe = (maybe (E.throw FederatorClientVersionMismatch) pure =<<) -versionNegotiation :: FederatorClient 'Brig Version -versionNegotiation = +versionNegotiation :: Set Version -> FederatorClient 'Brig Version +versionNegotiation localVersions = let req = defaultRequest { requestPath = "/api-version", @@ -337,10 +337,10 @@ versionNegotiation = remoteVersions <- case Aeson.decode body of Nothing -> E.throw (FederatorClientVersionNegotiationError InvalidVersionInfo) Just info -> pure (Set.fromList (vinfoSupported info)) - case Set.lookupMax (Set.intersection remoteVersions supportedVersions) of + case Set.lookupMax (Set.intersection remoteVersions localVersions) of Just v -> pure v Nothing -> E.throw . FederatorClientVersionNegotiationError $ - if Set.lookupMax supportedVersions > Set.lookupMax remoteVersions + if Set.lookupMax localVersions > Set.lookupMax remoteVersions then RemoteTooOld else RemoteTooNew From 39f8caccc76147b44a7365c0a82969a3e42f726c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 24 Jan 2024 12:16:11 +0100 Subject: [PATCH 05/52] Define the PayloadBundle type This gets enqueued instead of individual 'BackendNotification's --- .../src/Wire/API/Federation/API.hs | 32 +++++-- .../API/Federation/BackendNotifications.hs | 86 ++++++++++++++----- 2 files changed, 90 insertions(+), 28 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 242991d2c41..970e58ef86b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -24,6 +24,8 @@ module Wire.API.Federation.API HasUnsafeFedEndpoint, fedClient, fedQueueClient, + toBundle, + fedQueueClientBundle, fedClientIn, unsafeFedClientIn, module Wire.API.MakesFederatedCall, @@ -88,6 +90,30 @@ fedClient :: Client m api fedClient = clientIn (Proxy @api) (Proxy @m) +fedClientIn :: + forall (comp :: Component) (name :: Symbol) m api. + (HasFedEndpoint comp api name, HasClient m api) => + Client m api +fedClientIn = clientIn (Proxy @api) (Proxy @m) + +fedQueueClientBundle :: + KnownComponent c => + PayloadBundle c -> + FedQueueClient c () +fedQueueClientBundle bundle = do + env <- ask + let msg = + newMsg + { msgBody = encode bundle, + msgDeliveryMode = Just (env.deliveryMode), + msgContentType = Just "application/json" + } + -- Empty string means default exchange + exchange = "" + liftIO $ do + ensureQueue env.channel env.targetDomain._domainText + void $ publishMsg env.channel exchange (routingKey env.targetDomain._domainText) msg + fedQueueClient :: forall {k} (tag :: k). ( HasNotificationEndpoint tag, @@ -112,12 +138,6 @@ fedQueueClient payload = do ensureQueue env.channel env.targetDomain._domainText void $ publishMsg env.channel exchange (routingKey env.targetDomain._domainText) msg -fedClientIn :: - forall (comp :: Component) (name :: Symbol) m api. - (HasFedEndpoint comp api name, HasClient m api) => - Client m api -fedClientIn = clientIn (Proxy @api) (Proxy @m) - -- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended -- to be used in test situations only. unsafeFedClientIn :: diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index b3b905dfcd5..4062e937d7f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -5,10 +5,11 @@ module Wire.API.Federation.BackendNotifications where import Control.Exception import Control.Monad.Except -import Data.Aeson +import Data.Aeson qualified as A import Data.Domain import Data.Id (RequestId) import Data.Map qualified as Map +import Data.Schema import Data.Text qualified as Text import Data.Text.Lazy.Encoding qualified as TL import Imports @@ -20,6 +21,7 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Error +import Wire.API.Federation.HasNotificationEndpoint import Wire.API.Federation.Version import Wire.API.RawJson @@ -40,27 +42,67 @@ data BackendNotification = BackendNotification requestId :: Maybe RequestId } deriving (Show, Eq) - -instance ToJSON BackendNotification where - toJSON notif = - object - [ "ownDomain" .= notif.ownDomain, - "targetComponent" .= notif.targetComponent, - "path" .= notif.path, - "body" .= TL.decodeUtf8 notif.body.rawJsonBytes, - "bodyVersions" .= notif.bodyVersions, - "requestId" .= notif.requestId - ] - -instance FromJSON BackendNotification where - parseJSON = withObject "BackendNotification" $ \o -> - BackendNotification - <$> o .: "ownDomain" - <*> o .: "targetComponent" - <*> o .: "path" - <*> (RawJson . TL.encodeUtf8 <$> o .: "body") - <*> o .:? "bodyVersions" - <*> o .:? "requestId" + deriving (A.ToJSON, A.FromJSON) via (Schema BackendNotification) + +instance ToSchema BackendNotification where + schema = + object "BackendNotification" $ + BackendNotification + <$> ownDomain .= field "ownDomain" schema + <*> targetComponent .= field "targetComponent" schema + <*> path .= field "path" schema + <*> (TL.decodeUtf8 . rawJsonBytes . body) + .= field "body" (RawJson . TL.encodeUtf8 <$> schema) + <*> bodyVersions .= maybe_ (optField "bodyVersions" schema) + <*> (.requestId) .= maybe_ (optField "requestId" schema) + +data PayloadBundle (c :: Component) = PayloadBundle + { originDomain :: Domain, + targetDomain :: Domain, + notifications :: [BackendNotification] + } + deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) + +-- | This instance is not ideal as it assumes that two bundles have the same +-- origin domain and the same target domain. An alternative is not to define a +-- function that can throw if either of the domains don't line up, as such a +-- runtime error is a symptom of an application code bug. An alternative is to +-- use two ghost type variables in the PayloadBundle type, but that would +-- permeate other types too, including the FedQueueClient, which seems like a +-- high price to pay for a bit of type safety gain in a few places. +instance KnownComponent c => Semigroup (PayloadBundle c) where + b1 <> b2 = + PayloadBundle + { originDomain = b1.originDomain, + targetDomain = b1.targetDomain, + notifications = notifications b1 <> notifications b2 + } + +instance ToSchema (PayloadBundle c) where + schema = + object "PayloadBundle" $ + PayloadBundle + <$> (.originDomain) .= field "origin-domain" schema + <*> (.targetDomain) .= field "target-domain" schema + <*> notifications .= field "notifications" (array schema) + +toBundle :: + forall {k} (tag :: k). + ( HasNotificationEndpoint tag, + KnownSymbol (NotificationPath tag), + KnownComponent (NotificationComponent k), + ToJSON (Payload tag) + ) => + FedQueueEnv -> + Payload tag -> + PayloadBundle (NotificationComponent k) +toBundle env payload = do + let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload + PayloadBundle + { originDomain = env.originDomain, + targetDomain = env.targetDomain, + notifications = [notif] + } type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse From f2da0fe3837900de64352a042409f0ca0a583f9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 19 Jan 2024 17:01:39 +0100 Subject: [PATCH 06/52] Convert a call to use fedQueueClientBundle The fedQueueClientBundle function is to be renamed to fedQueueClient once aligning is done --- services/galley/src/Galley/API/Action.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 0b373dc9574..d3287d43c1d 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -898,7 +898,9 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- because quid's backend will update local state and notify its users -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedQueueClient @'OnConversationUpdatedTag update $> Nothing + then do + env <- ask + fedQueueClientBundle (toBundle @'OnConversationUpdatedTag env update) $> Nothing else pure (Just update) -- notify local participants and bots From 0b8a3b4880a8ff4e127f59136d980bd1f3ae4316 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Thu, 25 Jan 2024 09:21:12 +0100 Subject: [PATCH 07/52] Move fedNotifToBackendNotif next to BackendNotification --- .../API/Federation/BackendNotifications.hs | 31 +++++++++++++++- .../API/Federation/HasNotificationEndpoint.hs | 36 ------------------- 2 files changed, 30 insertions(+), 37 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 4062e937d7f..2f8f1e4833e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -12,6 +12,7 @@ import Data.Map qualified as Map import Data.Schema import Data.Text qualified as Text import Data.Text.Lazy.Encoding qualified as TL +import GHC.TypeLits import Imports import Network.AMQP qualified as Q import Network.AMQP.Types qualified as Q @@ -56,6 +57,34 @@ instance ToSchema BackendNotification where <*> bodyVersions .= maybe_ (optField "bodyVersions" schema) <*> (.requestId) .= maybe_ (optField "requestId" schema) +-- | Convert a federation endpoint to a backend notification to be enqueued to a +-- RabbitMQ queue. +fedNotifToBackendNotif :: + forall {k} (tag :: k). + KnownSymbol (NotificationPath tag) => + KnownComponent (NotificationComponent k) => + A.ToJSON (Payload tag) => + HasNotificationEndpoint tag => + RequestId -> + Domain -> + Payload tag -> + BackendNotification +fedNotifToBackendNotif rid ownDomain payload = + let p = Text.pack . symbolVal $ Proxy @(NotificationPath tag) + b = RawJson . A.encode $ payload + in toNotif p b + where + toNotif :: Text -> RawJson -> BackendNotification + toNotif path body = + BackendNotification + { ownDomain = ownDomain, + targetComponent = componentVal @(NotificationComponent k), + path = path, + body = body, + bodyVersions = Just $ versionRange @tag, + requestId = Just rid + } + data PayloadBundle (c :: Component) = PayloadBundle { originDomain :: Domain, targetDomain :: Domain, @@ -91,7 +120,7 @@ toBundle :: ( HasNotificationEndpoint tag, KnownSymbol (NotificationPath tag), KnownComponent (NotificationComponent k), - ToJSON (Payload tag) + A.ToJSON (Payload tag) ) => FedQueueEnv -> Payload tag -> diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index 4fe5eaf8815..744174091c5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -17,18 +17,10 @@ module Wire.API.Federation.HasNotificationEndpoint where -import Data.Aeson -import Data.Domain -import Data.Id import Data.Kind -import Data.Proxy -import Data.Text qualified as T import GHC.TypeLits -import Imports -import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Component import Wire.API.Federation.Version -import Wire.API.RawJson class IsNotificationTag k where type NotificationComponent k = (c :: Component) | c -> k @@ -43,31 +35,3 @@ class HasNotificationEndpoint t where -- | The federation API version range this endpoint is supported in. versionRange :: VersionRange - --- | Convert a federation endpoint to a backend notification to be enqueued to a --- RabbitMQ queue. -fedNotifToBackendNotif :: - forall {k} (tag :: k). - KnownSymbol (NotificationPath tag) => - KnownComponent (NotificationComponent k) => - ToJSON (Payload tag) => - HasNotificationEndpoint tag => - RequestId -> - Domain -> - Payload tag -> - BackendNotification -fedNotifToBackendNotif rid ownDomain payload = - let p = T.pack . symbolVal $ Proxy @(NotificationPath tag) - b = RawJson . encode $ payload - in toNotif p b - where - toNotif :: Text -> RawJson -> BackendNotification - toNotif path body = - BackendNotification - { ownDomain = ownDomain, - targetComponent = componentVal @(NotificationComponent k), - path = path, - body = body, - bodyVersions = Just $ versionRange @tag, - requestId = Just rid - } From bfb342559cd98e9e27d13f11c9150526f724573c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Wed, 24 Jan 2024 15:16:41 +0100 Subject: [PATCH 08/52] Parse a queue message as a PayloadBundle --- .../API/Federation/BackendNotifications.hs | 13 +- .../src/Wire/API/Federation/Client.hs | 11 +- .../src/Wire/API/Federation/Version.hs | 6 +- .../src/Wire/BackendNotificationPusher.hs | 120 ++++++++++++++---- 4 files changed, 118 insertions(+), 32 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 2f8f1e4833e..a36c9cbc86b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -4,6 +4,7 @@ module Wire.API.Federation.BackendNotifications where import Control.Exception +import Control.Monad.Codensity import Control.Monad.Except import Data.Aeson qualified as A import Data.Domain @@ -100,9 +101,12 @@ data PayloadBundle (c :: Component) = PayloadBundle -- permeate other types too, including the FedQueueClient, which seems like a -- high price to pay for a bit of type safety gain in a few places. instance KnownComponent c => Semigroup (PayloadBundle c) where + -- TODO(md): replace the Semigroup instance by a custom function that can + -- fail. b1 <> b2 = PayloadBundle { originDomain = b1.originDomain, + -- the assumption is that b2 has the same origin and target domain. targetDomain = b1.targetDomain, notifications = notifications b1 <> notifications b2 } @@ -135,7 +139,7 @@ toBundle env payload = do type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse -sendNotification :: FederatorClientEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ()) +sendNotification :: FederatorClientVersionedEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ()) sendNotification env component path body = case component of Brig -> go @'Brig @@ -148,8 +152,11 @@ sendNotification env component path body = go :: forall c. (KnownComponent c) => IO (Either FederatorClientError ()) go = - runFederatorClient env . void $ - clientIn (Proxy @BackendNotificationAPI) (Proxy @(FederatorClient c)) (withoutFirstSlash path) body + lowerCodensity + . runExceptT + . runVersionedFederatorClientToCodensity env + . void + $ clientIn (Proxy @BackendNotificationAPI) (Proxy @(FederatorClient c)) (withoutFirstSlash path) body enqueue :: Q.Channel -> RequestId -> Domain -> Domain -> Q.DeliveryMode -> FedQueueClient c a -> IO a enqueue channel requestId originDomain targetDomain deliveryMode (FedQueueClient action) = diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 674fdfb8727..44001ef0bd0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -171,7 +171,16 @@ instance KnownComponent c => RunClient (FederatorClient c) where expectedStatuses v <- asks cveVersion - let vreq = req {requestHeaders = (versionHeader, toByteString' (versionInt (fromMaybe V0 v))) :<| requestHeaders req} + let vreq = + req + { requestHeaders = + ( versionHeader, + toByteString' + ( versionInt (fromMaybe V0 v) + ) + ) + :<| requestHeaders req + } withHTTP2StreamingRequest successfulStatus vreq $ \resp -> do bdy <- diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index e734c505e4c..7f33b2ce80e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -26,7 +26,7 @@ module Wire.API.Federation.Version VersionInfo (..), versionInfo, VersionRange (..), - versionInCommon, + latestCommonVersion, ) where @@ -172,8 +172,8 @@ inVersionRange v vr = -- remote versions are given as integers as the range of versions supported by -- the remote backend can include a version unknown to the local backend. If -- there is no version in common, the return value is 'Nothing'. -versionInCommon :: VersionRange -> Set Int -> Maybe Version -versionInCommon localVersions remoteVersions = +latestCommonVersion :: VersionRange -> Set Int -> Maybe Version +latestCommonVersion localVersions remoteVersions = foldl' f Nothing (Set.map inRange remoteVersions) where inRange :: Int -> Maybe Version diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 1fb6721eb58..78e050561b3 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -19,8 +19,10 @@ import Network.RabbitMqAdmin import Prometheus import System.Logger.Class qualified as Log import UnliftIO +import Wire.API.Federation.API import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client +import Wire.API.Federation.Version import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util @@ -78,32 +80,100 @@ pushNotification runningFlag targetDomain (msg, envelope) = do UnliftIO.bracket_ (takeMVar runningFlag) (putMVar runningFlag ()) go where go :: AppT IO () - go = case A.eitherDecode @BackendNotification (Q.msgBody msg) of + -- go = case A.eitherDecode @BackendNotification (Q.msgBody msg) of + go = case A.eitherDecode @(PayloadBundle _) (Q.msgBody msg) of Left e -> do - Log.err $ - Log.msg (Log.val "Failed to parse notification, the notification will be ignored") - . Log.field "domain" (domainText targetDomain) - . Log.field "error" e - - -- FUTUREWORK: This rejects the message without any requeueing. This is - -- dangerous as it could happen that a new type of notification is - -- introduced and an old instance of this worker is running, in which case - -- the notification will just get dropped. On the other hand not dropping - -- this message blocks the whole queue. Perhaps there is a better way to - -- deal with this. - lift $ reject envelope False - Right notif -> do - ceFederator <- asks (.federatorInternal) - ceHttp2Manager <- asks http2Manager - let ceOriginDomain = notif.ownDomain - ceTargetDomain = targetDomain - ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId - fcEnv = FederatorClientEnv {..} - liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body - lift $ ack envelope - metrics <- asks backendNotificationMetrics - withLabel metrics.pushedCounter (domainText targetDomain) incCounter - withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) + case A.eitherDecode @BackendNotification (Q.msgBody msg) of + Left eBN -> do + Log.err $ + Log.msg + ( Log.val "Cannot parse a queued message as s notification " + <> "nor as a bundle; the message will be ignored" + ) + . Log.field "domain" (domainText targetDomain) + . Log.field "error-notification" eBN + . Log.field + "error-bundle" + e + -- FUTUREWORK: This rejects the message without any requeueing. This is + -- dangerous as it could happen that a new type of notification is + -- introduced and an old instance of this worker is running, in which case + -- the notification will just get dropped. On the other hand not dropping + -- this message blocks the whole queue. Perhaps there is a better way to + -- deal with this. + lift $ reject envelope False + Right notif -> do + ceFederator <- asks (.federatorInternal) + ceHttp2Manager <- asks http2Manager + let ceOriginDomain = notif.ownDomain + ceTargetDomain = targetDomain + ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId + cveEnv = FederatorClientEnv {..} + cveVersion = Just V0 -- V0 is assumed for non-versioned queue messages + fcEnv = FederatorClientVersionedEnv {..} + liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body + lift $ ack envelope + metrics <- asks backendNotificationMetrics + withLabel metrics.pushedCounter (domainText targetDomain) incCounter + withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) + Right bundle -> do + federator <- asks (.federatorInternal) + manager <- asks http2Manager + let env = + FederatorClientEnv + { ceOriginDomain = bundle.originDomain, + ceTargetDomain = bundle.targetDomain, + ceFederator = federator, + ceHttp2Manager = manager, + ceOriginRequestId = RequestId "N/A" + } + remoteVersions :: Set Int <- + liftIO + ( runFederatorClient @'Brig env $ + fedClientIn @'Brig @"api-version" () + ) + >>= \case + Left e -> do + Log.err $ + Log.msg (Log.val "Failed to get supported API versions, the notification will be ignored") + . Log.field "domain" (domainText targetDomain) + . Log.field "error" (displayException e) + throwM e + Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi + let mostRecentNotif = foldl' combine Nothing (notifications bundle) + combine :: + Maybe (BackendNotification, Version) -> + BackendNotification -> + Maybe (BackendNotification, Version) + combine greatest notif = + let notifGreatest = bodyVersions notif >>= flip latestCommonVersion remoteVersions + in case (greatest, notifGreatest) of + (Nothing, Nothing) -> Nothing + (Nothing, Just v) -> Just (notif, v) + (Just (gn, gv), Nothing) -> Just (gn, gv) + (Just (gn, gv), Just v) -> + if v > gv + then Just (notif, v) + else Just (gn, gv) + case mostRecentNotif of + Nothing -> + -- TODO(md): do more severe logging warning the site operator + Log.err $ + Log.msg (Log.val "No federation API version in common, the notification will be ignored") + . Log.field "domain" (domainText targetDomain) + Just (notif, Just -> cveVersion) -> do + ceFederator <- asks (.federatorInternal) + ceHttp2Manager <- asks http2Manager + let ceOriginDomain = notif.ownDomain + ceTargetDomain = targetDomain + ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId + cveEnv = FederatorClientEnv {..} + fcEnv = FederatorClientVersionedEnv {..} + liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body + lift $ ack envelope + metrics <- asks backendNotificationMetrics + withLabel metrics.pushedCounter (domainText targetDomain) incCounter + withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter -- for a handful of remote domains. From 3b121f98286858532f722d956e67957a8e42f0af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 12:24:49 +0100 Subject: [PATCH 09/52] Remove targetDomain from PayloadBundle --- .../src/Wire/API/Federation/BackendNotifications.hs | 4 ---- .../background-worker/src/Wire/BackendNotificationPusher.hs | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index a36c9cbc86b..971a70996ec 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -88,7 +88,6 @@ fedNotifToBackendNotif rid ownDomain payload = data PayloadBundle (c :: Component) = PayloadBundle { originDomain :: Domain, - targetDomain :: Domain, notifications :: [BackendNotification] } deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) @@ -107,7 +106,6 @@ instance KnownComponent c => Semigroup (PayloadBundle c) where PayloadBundle { originDomain = b1.originDomain, -- the assumption is that b2 has the same origin and target domain. - targetDomain = b1.targetDomain, notifications = notifications b1 <> notifications b2 } @@ -116,7 +114,6 @@ instance ToSchema (PayloadBundle c) where object "PayloadBundle" $ PayloadBundle <$> (.originDomain) .= field "origin-domain" schema - <*> (.targetDomain) .= field "target-domain" schema <*> notifications .= field "notifications" (array schema) toBundle :: @@ -133,7 +130,6 @@ toBundle env payload = do let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload PayloadBundle { originDomain = env.originDomain, - targetDomain = env.targetDomain, notifications = [notif] } diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 78e050561b3..53c99287f2d 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -122,7 +122,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do let env = FederatorClientEnv { ceOriginDomain = bundle.originDomain, - ceTargetDomain = bundle.targetDomain, + ceTargetDomain = targetDomain, ceFederator = federator, ceHttp2Manager = manager, ceOriginRequestId = RequestId "N/A" From 0ab7dc86f042e61e5fcc577bffbd48a676c69968 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 13:47:25 +0100 Subject: [PATCH 10/52] Remove originDomain from PayloadBundle --- .../API/Federation/BackendNotifications.hs | 32 ++++--------------- .../background-worker/background-worker.cabal | 1 + .../src/Wire/BackendNotificationPusher.hs | 6 ++-- 3 files changed, 11 insertions(+), 28 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 971a70996ec..2ad16cd2995 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -9,6 +9,7 @@ import Control.Monad.Except import Data.Aeson qualified as A import Data.Domain import Data.Id (RequestId) +import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Schema import Data.Text qualified as Text @@ -86,35 +87,17 @@ fedNotifToBackendNotif rid ownDomain payload = requestId = Just rid } -data PayloadBundle (c :: Component) = PayloadBundle - { originDomain :: Domain, - notifications :: [BackendNotification] +newtype PayloadBundle (c :: Component) = PayloadBundle + { notifications :: NE.NonEmpty BackendNotification } deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) --- | This instance is not ideal as it assumes that two bundles have the same --- origin domain and the same target domain. An alternative is not to define a --- function that can throw if either of the domains don't line up, as such a --- runtime error is a symptom of an application code bug. An alternative is to --- use two ghost type variables in the PayloadBundle type, but that would --- permeate other types too, including the FedQueueClient, which seems like a --- high price to pay for a bit of type safety gain in a few places. -instance KnownComponent c => Semigroup (PayloadBundle c) where - -- TODO(md): replace the Semigroup instance by a custom function that can - -- fail. - b1 <> b2 = - PayloadBundle - { originDomain = b1.originDomain, - -- the assumption is that b2 has the same origin and target domain. - notifications = notifications b1 <> notifications b2 - } - +-- TODO(md): automatically derive this instance instance ToSchema (PayloadBundle c) where schema = object "PayloadBundle" $ PayloadBundle - <$> (.originDomain) .= field "origin-domain" schema - <*> notifications .= field "notifications" (array schema) + <$> notifications .= field "notifications" (nonEmptyArray schema) toBundle :: forall {k} (tag :: k). @@ -128,10 +111,7 @@ toBundle :: PayloadBundle (NotificationComponent k) toBundle env payload = do let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload - PayloadBundle - { originDomain = env.originDomain, - notifications = [notif] - } + PayloadBundle . pure $ notif type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 1eb4df1229d..35113550d00 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -29,6 +29,7 @@ library build-depends: aeson , amqp + , base , containers , exceptions , extended diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 53c99287f2d..af2c01093f5 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -8,6 +8,7 @@ import Control.Retry import Data.Aeson qualified as A import Data.Domain import Data.Id +import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text @@ -121,11 +122,12 @@ pushNotification runningFlag targetDomain (msg, envelope) = do manager <- asks http2Manager let env = FederatorClientEnv - { ceOriginDomain = bundle.originDomain, + { ceOriginDomain = ownDomain . NE.head $ bundle.notifications, ceTargetDomain = targetDomain, ceFederator = federator, ceHttp2Manager = manager, - ceOriginRequestId = RequestId "N/A" + ceOriginRequestId = + fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications } remoteVersions :: Set Int <- liftIO From 1592554873e3f8210cc200fe4f9b147fd864b9d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 13:50:23 +0100 Subject: [PATCH 11/52] instance Semigroup PayloadBundle --- .../src/Wire/API/Federation/BackendNotifications.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 2ad16cd2995..ff7b2739ce0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -91,6 +91,7 @@ newtype PayloadBundle (c :: Component) = PayloadBundle { notifications :: NE.NonEmpty BackendNotification } deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) + deriving newtype (Semigroup) -- TODO(md): automatically derive this instance instance ToSchema (PayloadBundle c) where From b6d3812684f0d4dc1da65111339037a855ab5d7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 14:41:23 +0100 Subject: [PATCH 12/52] TODO note: refactoring --- services/background-worker/src/Wire/BackendNotificationPusher.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index af2c01093f5..03878b089f8 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -129,6 +129,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceOriginRequestId = fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications } + -- TODO(md): pull this out into a separate function for redability and testability remoteVersions :: Set Int <- liftIO ( runFederatorClient @'Brig env $ From a29dea51fef5a3a2dbe49d57c95c6c1cbf489eb8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 16:42:43 +0100 Subject: [PATCH 13/52] More focused signature of toBundle --- .../src/Wire/API/Federation/BackendNotifications.hs | 8 +++++--- services/galley/src/Galley/API/Action.hs | 6 ++++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index ff7b2739ce0..817d275c0a3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -107,11 +107,13 @@ toBundle :: KnownComponent (NotificationComponent k), A.ToJSON (Payload tag) ) => - FedQueueEnv -> + RequestId -> + -- | The origin domain + Domain -> Payload tag -> PayloadBundle (NotificationComponent k) -toBundle env payload = do - let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload +toBundle reqId originDomain payload = do + let notif = fedNotifToBackendNotif @tag reqId originDomain payload PayloadBundle . pure $ notif type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index d3287d43c1d..565bcf9ecb9 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -116,6 +116,7 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as F +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.FederationStatus import Wire.API.MLS.CipherSuite @@ -899,8 +900,9 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid then do - env <- ask - fedQueueClientBundle (toBundle @'OnConversationUpdatedTag env update) $> Nothing + reqId <- asks (.requestId) + origin <- asks (.originDomain) + fedQueueClientBundle (toBundle @'OnConversationUpdatedTag reqId origin update) $> Nothing else pure (Just update) -- notify local participants and bots From 5934575d96345d8957b3f1591978790bb8cdca6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 16:58:38 +0100 Subject: [PATCH 14/52] Make all fedQueue endpoints use the new client --- .../src/Wire/API/Federation/API.hs | 30 ++-------------- .../API/Federation/BackendNotifications.hs | 6 ++++ services/brig/src/Brig/Federation/Client.hs | 5 +-- services/galley/src/Galley/API/Action.hs | 5 ++- services/galley/src/Galley/API/Clients.hs | 10 +++++- services/galley/src/Galley/API/Internal.hs | 6 +++- .../galley/src/Galley/API/MLS/Propagate.hs | 34 +++++++++++-------- services/galley/src/Galley/API/Message.hs | 5 ++- 8 files changed, 51 insertions(+), 50 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 970e58ef86b..5253d14b8b2 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -25,7 +25,6 @@ module Wire.API.Federation.API fedClient, fedQueueClient, toBundle, - fedQueueClientBundle, fedClientIn, unsafeFedClientIn, module Wire.API.MakesFederatedCall, @@ -51,7 +50,6 @@ import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Endpoint -import Wire.API.Federation.HasNotificationEndpoint import Wire.API.MakesFederatedCall import Wire.API.Routes.Named @@ -96,11 +94,11 @@ fedClientIn :: Client m api fedClientIn = clientIn (Proxy @api) (Proxy @m) -fedQueueClientBundle :: +fedQueueClient :: KnownComponent c => PayloadBundle c -> FedQueueClient c () -fedQueueClientBundle bundle = do +fedQueueClient bundle = do env <- ask let msg = newMsg @@ -114,30 +112,6 @@ fedQueueClientBundle bundle = do ensureQueue env.channel env.targetDomain._domainText void $ publishMsg env.channel exchange (routingKey env.targetDomain._domainText) msg -fedQueueClient :: - forall {k} (tag :: k). - ( HasNotificationEndpoint tag, - KnownSymbol (NotificationPath tag), - KnownComponent (NotificationComponent k), - ToJSON (Payload tag) - ) => - Payload tag -> - FedQueueClient (NotificationComponent k) () -fedQueueClient payload = do - env <- ask - let notif = fedNotifToBackendNotif @tag env.requestId env.originDomain payload - msg = - newMsg - { msgBody = encode notif, - msgDeliveryMode = Just (env.deliveryMode), - msgContentType = Just "application/json" - } - -- Empty string means default exchange - exchange = "" - liftIO $ do - ensureQueue env.channel env.targetDomain._domainText - void $ publishMsg env.channel exchange (routingKey env.targetDomain._domainText) msg - -- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended -- to be used in test situations only. unsafeFedClientIn :: diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 817d275c0a3..d70aeff9da5 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -190,6 +190,12 @@ ensureQueue chan queue = do newtype FedQueueClient c a = FedQueueClient (ReaderT FedQueueEnv IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader FedQueueEnv) +reqOrigin :: FedQueueClient c (RequestId, Domain) +reqOrigin = do + reqId <- asks (.requestId) + origin <- asks (.originDomain) + pure (reqId, origin) + data FedQueueEnv = FedQueueEnv { channel :: Q.Channel, originDomain :: Domain, diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index ad697843719..391046bcede 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -157,8 +157,9 @@ notifyUserDeleted self remotes = do view rabbitmqChannel >>= \case Just chanVar -> do enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ - void $ - fedQueueClient @'OnUserDeletedConnectionsTag notif + void $ do + (reqId, origin) <- reqOrigin + fedQueueClient $ toBundle @'OnUserDeletedConnectionsTag reqId origin notif Nothing -> Log.err $ Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 565bcf9ecb9..e392b2519c0 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -900,9 +900,8 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid then do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClientBundle (toBundle @'OnConversationUpdatedTag reqId origin update) $> Nothing + (reqId, origin) <- reqOrigin + fedQueueClient (toBundle @'OnConversationUpdatedTag reqId origin update) $> Nothing else pure (Just update) -- notify local participants and bots diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 9ae38817dc8..bc1fe119ec4 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -50,6 +50,7 @@ import Polysemy.TinyLog qualified as P import Wire.API.Conversation hiding (Member) import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.Routes.MultiTablePaging import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (CassandraPaging) @@ -138,5 +139,12 @@ rmClientH (usr ::: cid) = do removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () removeRemoteMLSClients convIds = do for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> - let rpc = void $ fedQueueClient @'OnClientRemovedTag (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) + let rpc = void $ do + (req, origin) <- reqOrigin + fedQueueClient + ( toBundle @'OnClientRemovedTag + req + origin + (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) + ) in enqueueNotification remoteConvs Q.Persistent rpc diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2e4d7435980..eece786b7f6 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -91,6 +91,7 @@ import Wire.API.Event.Conversation import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.Provider.Service hiding (Service) import Wire.API.Routes.API @@ -425,7 +426,10 @@ rmUser lusr conn = do leaveRemoteConversations cids = for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) - let rpc = void $ fedQueueClient @'OnUserDeletedConversationsTag userDelete + let rpc = void $ do + (req, origin) <- reqOrigin + fedQueueClient $ + toBundle @'OnUserDeletedConversationsTag req origin userDelete enqueueNotification remoteConvs Q.Persistent rpc -- FUTUREWORK: Add a retry mechanism if there are federation errrors. diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 53efadec2dc..0ee5572a4f3 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -41,6 +41,7 @@ import Polysemy.TinyLog hiding (trace) import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.MLS.Credential import Wire.API.MLS.Message import Wire.API.MLS.Serialisation @@ -88,20 +89,25 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do -- send to remotes (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ - \rs -> - fedQueueClient @'OnMLSMessageSentTag $ - RemoteMLSMessage - { time = now, - sender = qusr, - metadata = mm, - conversation = qUnqualified qcnv, - subConversation = sconv, - recipients = - Map.fromList $ - tUnqualified rs - >>= toList . remoteMemberMLSClients, - message = Base64ByteString msg.raw - } + \rs -> do + (reqId, origin) <- reqOrigin + fedQueueClient $ + toBundle @'OnMLSMessageSentTag + reqId + origin + ( RemoteMLSMessage + { time = now, + sender = qusr, + metadata = mm, + conversation = qUnqualified qcnv, + subConversation = sconv, + recipients = + Map.fromList $ + tUnqualified rs + >>= toList . remoteMemberMLSClients, + message = Base64ByteString msg.raw + } + ) where cmWithoutSender = maybe cm (flip cmRemoveClient cm . mkClientIdentity qusr) mSenderClient diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 355fccd7942..f094e6984fc 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -78,6 +78,7 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Message @@ -698,7 +699,9 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand transient = mmTransient metadata, recipients = UserClientMap rcpts } - let rpc = void $ fedQueueClient @'OnMessageSentTag rm + let rpc = void $ do + (reqId, origin) <- reqOrigin + fedQueueClient $ toBundle @'OnMessageSentTag reqId origin rm enqueueNotification domain Q.Persistent rpc where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) From 6862fcaebb85c250d3cf3d04bd9a710dae67458e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Fri, 26 Jan 2024 17:04:53 +0100 Subject: [PATCH 15/52] Test: dequeueing a payload bundle --- .../Wire/BackendNotificationPusherSpec.hs | 38 +++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 2b2c6052a91..838359d0da0 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -40,6 +40,7 @@ import Util.Options import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common +import Wire.API.Federation.API.Galley import Wire.API.Federation.BackendNotifications import Wire.API.RawJson import Wire.BackendNotificationPusher @@ -93,6 +94,43 @@ spec = do getVectorWith env.backendNotificationMetrics.pushedCounter getCounter `shouldReturn` [(domainText targetDomain, 1)] + it "should push notification bundles" $ do + let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) + let origDomain = Domain "origin.example.com" + targetDomain = Domain "target.example.com" + -- Just using 'arbitrary' could generate a very big list, making tests very + -- slow. Make me wonder if notification pusher should even try to parse the + -- actual content, seems like wasted compute power. + notifContent <- + generate $ + ClientRemovedRequest <$> arbitrary <*> arbitrary <*> arbitrary + let bundle = toBundle @'OnClientRemovedTag (RequestId "N/A") origDomain notifContent + envelope <- newMockEnvelope + let msg = + Q.newMsg + { Q.msgBody = Aeson.encode bundle, + Q.msgContentType = Just "application/json" + } + runningFlag <- newMVar () + (env, fedReqs) <- + withTempMockFederator [] returnSuccess . runTestAppT $ do + wait =<< pushNotification runningFlag targetDomain (msg, envelope) + ask + + readIORef envelope.acks `shouldReturn` 1 + readIORef envelope.rejections `shouldReturn` [] + fedReqs + `shouldBe` [ FederatedRequest + { frTargetDomain = targetDomain, + frOriginDomain = origDomain, + frComponent = Galley, + frRPC = "on-client-removed", + frBody = Aeson.encode notifContent + } + ] + getVectorWith env.backendNotificationMetrics.pushedCounter getCounter + `shouldReturn` [(domainText targetDomain, 1)] + it "should reject invalid notifications" $ do let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) envelope <- newMockEnvelope From df4e34c36ec5239c94ba0b52330f376697c1e01b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 10:19:03 +0100 Subject: [PATCH 16/52] Add a futurework note on dropping support for parsing backend notifications in RabbitMQ queue --- .../background-worker/src/Wire/BackendNotificationPusher.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 03878b089f8..f2b5f130eeb 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -104,6 +104,10 @@ pushNotification runningFlag targetDomain (msg, envelope) = do -- deal with this. lift $ reject envelope False Right notif -> do + -- FUTUREWORK: Drop support for parsing it as a + -- single notification as soon as we can guarantee + -- that the message queue does not contain any + -- 'BackendNotification's anymore. ceFederator <- asks (.federatorInternal) ceHttp2Manager <- asks http2Manager let ceOriginDomain = notif.ownDomain From f4dd8cea56da6db5f8589fff7848f9b3f9f4bc0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 10:58:22 +0100 Subject: [PATCH 17/52] Pull out mostRecentNotif into a standalone function --- .../src/Wire/BackendNotificationPusher.hs | 35 ++++++++++--------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index f2b5f130eeb..5fa5b19aeb1 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -147,22 +147,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do . Log.field "error" (displayException e) throwM e Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi - let mostRecentNotif = foldl' combine Nothing (notifications bundle) - combine :: - Maybe (BackendNotification, Version) -> - BackendNotification -> - Maybe (BackendNotification, Version) - combine greatest notif = - let notifGreatest = bodyVersions notif >>= flip latestCommonVersion remoteVersions - in case (greatest, notifGreatest) of - (Nothing, Nothing) -> Nothing - (Nothing, Just v) -> Just (notif, v) - (Just (gn, gv), Nothing) -> Just (gn, gv) - (Just (gn, gv), Just v) -> - if v > gv - then Just (notif, v) - else Just (gn, gv) - case mostRecentNotif of + case mostRecentNotif bundle remoteVersions of Nothing -> -- TODO(md): do more severe logging warning the site operator Log.err $ @@ -182,6 +167,24 @@ pushNotification runningFlag targetDomain (msg, envelope) = do withLabel metrics.pushedCounter (domainText targetDomain) incCounter withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) +mostRecentNotif :: PayloadBundle c -> Set Int -> Maybe (BackendNotification, Version) +mostRecentNotif bundle remoteVersions = foldl' combine Nothing (notifications bundle) + where + combine :: + Maybe (BackendNotification, Version) -> + BackendNotification -> + Maybe (BackendNotification, Version) + combine greatest notif = + let notifGreatest = bodyVersions notif >>= flip latestCommonVersion remoteVersions + in case (greatest, notifGreatest) of + (Nothing, Nothing) -> Nothing + (Nothing, Just v) -> Just (notif, v) + (Just (gn, gv), Nothing) -> Just (gn, gv) + (Just (gn, gv), Just v) -> + if v > gv + then Just (notif, v) + else Just (gn, gv) + -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter -- for a handful of remote domains. -- Consumers is passed in explicitly so that cleanup code has a reference to the consumer tags. From 400dc6fcdc785aa956a62b3fbe47779695c70d3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 11:05:29 +0100 Subject: [PATCH 18/52] Fix Nix dependencies --- services/background-worker/default.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 910b9a396dd..2ff9f6086e3 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -50,6 +50,7 @@ mkDerivation { libraryHaskellDepends = [ aeson amqp + base containers exceptions extended From 0a3b9aaa47cad0b051e103f31902207807b45ebe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 11:20:11 +0100 Subject: [PATCH 19/52] A TODO and a FUTUREWORK note --- .../background-worker/src/Wire/BackendNotificationPusher.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 5fa5b19aeb1..eeda88fbe02 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -167,6 +167,11 @@ pushNotification runningFlag targetDomain (msg, envelope) = do withLabel metrics.pushedCounter (domainText targetDomain) incCounter withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) +-- TODO(md): put this into BackendNotification.hs (and tests too) +-- +-- FUTUREWORK(fisx): we could compute a Set Int from the bundle and do set +-- operations on remoteVersions and localVersions. would be slightly more +-- readable, possibly. mostRecentNotif :: PayloadBundle c -> Set Int -> Maybe (BackendNotification, Version) mostRecentNotif bundle remoteVersions = foldl' combine Nothing (notifications bundle) where From c7f5de41a031e8259f31605f71e5ac095c43ed69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 12:37:31 +0100 Subject: [PATCH 20/52] Unit tests for mostRecentNotif. --- .../Wire/BackendNotificationPusherSpec.hs | 29 ++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 838359d0da0..680226a2af5 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-incomplete-patterns #-} module Test.Wire.BackendNotificationPusherSpec where @@ -11,8 +11,10 @@ import Data.ByteString.Builder qualified as Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain import Data.Id +import Data.List.NonEmpty qualified as NE import Data.Range import Data.Sequence qualified as Seq +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Federator.MockServer @@ -42,6 +44,7 @@ import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Federation.BackendNotifications +import Wire.API.Federation.Version import Wire.API.RawJson import Wire.BackendNotificationPusher import Wire.BackgroundWorker.Env @@ -268,6 +271,30 @@ spec = do calls `shouldSatisfy` (\c -> length c >= 2) mapM_ (\vhost -> vhost `shouldBe` rabbitmqVHost) calls + describe "mostRecentNotif" $ do + let versionToBundle (NE.nonEmpty -> Just (versionRanges :: NE.NonEmpty VersionRange)) = do + PayloadBundle $ + flip fmap versionRanges $ \v -> + BackendNotification + { ownDomain = undefined, + targetComponent = undefined, + path = undefined, + body = undefined, + bodyVersions = Just v, + requestId = undefined + } + + it "[..] + [] = fail" $ do + mostRecentNotif (versionToBundle [AllVersions]) (Set.fromList []) `shouldBe` Nothing + it "[0] + [1] = fail" $ do + mostRecentNotif (versionToBundle [FromUntilVersion V0 V1]) (Set.fromList []) `shouldBe` Nothing + focus . it "[1] + [0, 1] = 1" $ do + fmap snd (mostRecentNotif (versionToBundle [FromVersion V1]) (Set.fromList [0, 1])) `shouldBe` Just V1 + it "[0] + [0, 1] = 0" $ do + fmap snd (mostRecentNotif (versionToBundle [FromVersion V0]) (Set.fromList [0, 1])) `shouldBe` Just V0 + it "[..] + [1] = 1" $ do + fmap snd (mostRecentNotif (versionToBundle [UntilVersion V1, FromVersion V1]) (Set.fromList [1])) `shouldBe` Just V1 + untilM :: (Monad m) => m Bool -> m () untilM action = do b <- action From 8ba0c2c2273d0c6d3ce75398c2badae041180a53 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 29 Jan 2024 14:35:52 +0100 Subject: [PATCH 21/52] Refactor VersionRange --- .../API/Federation/API/Brig/Notifications.hs | 2 +- .../Federation/API/Galley/Notifications.hs | 10 +- .../src/Wire/API/Federation/Version.hs | 117 ++++++------------ .../Wire/BackendNotificationPusherSpec.hs | 17 +-- 4 files changed, 51 insertions(+), 95 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs index 1f7b697dd74..2018d9ed88e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs @@ -50,7 +50,7 @@ instance IsNotificationTag BrigNotificationTag where instance HasNotificationEndpoint 'OnUserDeletedConnectionsTag where type Payload 'OnUserDeletedConnectionsTag = UserDeletedConnectionsNotification type NotificationPath 'OnUserDeletedConnectionsTag = "on-user-deleted-connections" - versionRange = AllVersions + versionRange = allVersions instance ToSchema UserDeletedConnectionsNotification diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index b73448c05f4..b804260b0cf 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -54,31 +54,31 @@ instance IsNotificationTag GalleyNotificationTag where instance HasNotificationEndpoint 'OnClientRemovedTag where type Payload 'OnClientRemovedTag = ClientRemovedRequest type NotificationPath 'OnClientRemovedTag = "on-client-removed" - versionRange = AllVersions + versionRange = allVersions -- used to notify this backend that a new message has been posted to a -- remote conversation instance HasNotificationEndpoint 'OnMessageSentTag where type Payload 'OnMessageSentTag = RemoteMessage ConvId type NotificationPath 'OnMessageSentTag = "on-message-sent" - versionRange = AllVersions + versionRange = allVersions instance HasNotificationEndpoint 'OnMLSMessageSentTag where type Payload 'OnMLSMessageSentTag = RemoteMLSMessage type NotificationPath 'OnMLSMessageSentTag = "on-mls-message-sent" - versionRange = AllVersions + versionRange = allVersions -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" - versionRange = AllVersions + versionRange = allVersions instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification type NotificationPath 'OnUserDeletedConversationsTag = "on-user-deleted-conversations" - versionRange = AllVersions + versionRange = allVersions -- | All the notification endpoints return an 'EmptyResponse'. type GalleyNotificationAPI = diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 7f33b2ce80e..8b62a39429c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -18,20 +18,28 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . module Wire.API.Federation.Version - ( Version (..), + ( -- * Version, VersionInfo + Version (..), V0Sym0, V1Sym0, versionInt, supportedVersions, VersionInfo (..), versionInfo, + + -- * VersionRange VersionRange (..), + fromVersion, + toVersionExcl, + allVersions, + fromVersions, + untilVersions, latestCommonVersion, + mostRecentTuple, ) where -import Control.Lens (makePrisms, (?~)) -import Control.Lens.Tuple (_1) +import Control.Lens (makeLenses, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.OpenApi qualified as S import Data.Schema @@ -83,38 +91,10 @@ versionInfo = VersionInfo (toList supportedVersions) ---------------------------------------------------------------------- -data VersionRangeTag - = VersionRangeTagAll - | VersionRangeTagFrom - | VersionRangeTagUntil - | VersionRangeTagFromUntil - deriving (Eq, Enum, Bounded) - -versionRangeTagSchema :: ValueSchema NamedSwaggerDoc VersionRangeTag -versionRangeTagSchema = - enum @Text "VersionRange Tag" $ - mconcat - [ element "all-versions" VersionRangeTagAll, - element "from" VersionRangeTagFrom, - element "until" VersionRangeTagUntil, - element "from-until" VersionRangeTagFromUntil - ] - -versionPairSchema :: ValueSchema NamedSwaggerDoc (Version, Version) -versionPairSchema = - object "VersionPair" $ - (,) - <$> fst .= field "from" schema - <*> snd .= field "until" schema - -data VersionRange - = AllVersions - | -- | The version in the argument represent an inclusive bound. - FromVersion Version - | -- | The version in the argument represent an exclusive bound. - UntilVersion Version - | -- | The second argument represents an exclusive upper bound. - FromUntilVersion Version Version +data VersionRange = VersionRange + { _fromVersion :: Version, + _toVersionExcl :: Maybe Version + } deriving instance Eq VersionRange @@ -122,50 +102,35 @@ deriving instance Show VersionRange deriving instance Ord VersionRange -makePrisms ''VersionRange +makeLenses ''VersionRange instance ToSchema VersionRange where schema = object "VersionRange" $ - fromTagged - <$> toTagged - .= bind - (fst .= field "tag" versionRangeTagSchema) - (snd .= fieldOver _1 "value" untaggedSchema) + VersionRange + <$> _fromVersion .= field "from" schema + <*> _toVersionExcl .= maybe_ (optFieldWithDocModifier "until_excl" desc schema) where - toTagged :: VersionRange -> (VersionRangeTag, VersionRange) - toTagged d@AllVersions = (VersionRangeTagAll, d) - toTagged d@(FromVersion _) = (VersionRangeTagFrom, d) - toTagged d@(UntilVersion _) = (VersionRangeTagUntil, d) - toTagged d@(FromUntilVersion _ _) = (VersionRangeTagFromUntil, d) - - fromTagged :: (VersionRangeTag, VersionRange) -> VersionRange - fromTagged = snd - - untaggedSchema = dispatch $ \case - VersionRangeTagAll -> tag _AllVersions null_ - VersionRangeTagFrom -> tag _FromVersion (unnamed schema) - VersionRangeTagUntil -> tag _UntilVersion (unnamed schema) - VersionRangeTagFromUntil -> tag _FromUntilVersion $ unnamed versionPairSchema + desc = description ?~ "exlusive upper version bound" deriving via Schema VersionRange instance ToJSON VersionRange deriving via Schema VersionRange instance FromJSON VersionRange --- | Compute the lower and upper boundary of a version range. The first --- component of the pair is the lower boundary, while the second component is --- the upper boundary. The upper boundary is inclusive. -versionRangeToBoundaries :: VersionRange -> (Version, Version) -versionRangeToBoundaries AllVersions = (minBound @Version, maxBound @Version) -versionRangeToBoundaries (FromVersion fv) = (fv, maxBound @Version) -versionRangeToBoundaries (UntilVersion uv) = (minBound @Version, pred uv) -versionRangeToBoundaries (FromUntilVersion fv uv) = (fv, pred uv) - --- | Checks if a version is within a given version range. -inVersionRange :: Version -> VersionRange -> Bool -inVersionRange v vr = - let (lo, hi) = versionRangeToBoundaries vr - in lo <= v && v < hi +allVersions :: VersionRange +allVersions = VersionRange minBound Nothing + +fromVersions :: Version -> VersionRange +fromVersions v = VersionRange v Nothing + +untilVersions :: Version -> VersionRange +untilVersions v = VersionRange minBound (Just v) + +enumVersionRange :: VersionRange -> Set Version +enumVersionRange = + Set.fromList . \case + (VersionRange l Nothing) -> [l ..] + (VersionRange l (Just u)) -> init [l .. u] -- | For a version range of a local backend and for a set of versions that a -- remote backend supports, compute the newest version supported by both. The @@ -173,18 +138,8 @@ inVersionRange v vr = -- the remote backend can include a version unknown to the local backend. If -- there is no version in common, the return value is 'Nothing'. latestCommonVersion :: VersionRange -> Set Int -> Maybe Version -latestCommonVersion localVersions remoteVersions = - foldl' f Nothing (Set.map inRange remoteVersions) - where - inRange :: Int -> Maybe Version - inRange i = do - v <- intToVersion i - guard (v `inVersionRange` localVersions) $> v - - f :: Maybe Version -> Maybe Version -> Maybe Version - f Nothing mv = mv - f (Just m) (Just v) = Just $ m `max` v - f v Nothing = v +latestCommonVersion (Set.map versionInt . enumVersionRange -> localVersions) remoteVersions = + intToVersion =<< Set.lookupMax (Set.intersection localVersions remoteVersions) $(genSingletons [''Version]) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 680226a2af5..8586860324a 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -284,16 +284,17 @@ spec = do requestId = undefined } - it "[..] + [] = fail" $ do - mostRecentNotif (versionToBundle [AllVersions]) (Set.fromList []) `shouldBe` Nothing - it "[0] + [1] = fail" $ do - mostRecentNotif (versionToBundle [FromUntilVersion V0 V1]) (Set.fromList []) `shouldBe` Nothing - focus . it "[1] + [0, 1] = 1" $ do - fmap snd (mostRecentNotif (versionToBundle [FromVersion V1]) (Set.fromList [0, 1])) `shouldBe` Just V1 + -- FUTUREWORK: once we have more Version values, we may want to add some tests here. + it "[..] + [] = null" $ do + mostRecentNotif (versionToBundle [allVersions]) (Set.fromList []) `shouldBe` Nothing + it "[0] + [1] = null" $ do + mostRecentNotif (versionToBundle [VersionRange V0 (Just V1)]) (Set.fromList []) `shouldBe` Nothing + it "[1] + [0, 1] = 1" $ do + fmap snd (mostRecentNotif (versionToBundle [VersionRange V1 Nothing]) (Set.fromList [0, 1])) `shouldBe` Just V1 it "[0] + [0, 1] = 0" $ do - fmap snd (mostRecentNotif (versionToBundle [FromVersion V0]) (Set.fromList [0, 1])) `shouldBe` Just V0 + fmap snd (mostRecentNotif (versionToBundle [VersionRange V0 (Just V1)]) (Set.fromList [0, 1])) `shouldBe` Just V0 it "[..] + [1] = 1" $ do - fmap snd (mostRecentNotif (versionToBundle [UntilVersion V1, FromVersion V1]) (Set.fromList [1])) `shouldBe` Just V1 + fmap snd (mostRecentNotif (versionToBundle [VersionRange V0 (Just V1), VersionRange V1 Nothing]) (Set.fromList [1])) `shouldBe` Just V1 untilM :: (Monad m) => m Bool -> m () untilM action = do From 3619b54986c800578b1b13552c8fe3807dc5b595 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 15:15:57 +0100 Subject: [PATCH 22/52] Slight refactoring of mostRecentNotif --- .../src/Wire/BackendNotificationPusher.hs | 19 ++++++++------- .../Wire/BackendNotificationPusherSpec.hs | 24 +++++-------------- 2 files changed, 16 insertions(+), 27 deletions(-) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index eeda88fbe02..15976739760 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -173,21 +173,22 @@ pushNotification runningFlag targetDomain (msg, envelope) = do -- operations on remoteVersions and localVersions. would be slightly more -- readable, possibly. mostRecentNotif :: PayloadBundle c -> Set Int -> Maybe (BackendNotification, Version) -mostRecentNotif bundle remoteVersions = foldl' combine Nothing (notifications bundle) +mostRecentNotif = + mostRecentTuple bodyVersions . (NE.toList . notifications) + +mostRecentTuple :: forall a. (a -> Maybe VersionRange) -> [a] -> Set Int -> Maybe (a, Version) +mostRecentTuple pr as remoteVersions = foldl' combine Nothing as where - combine :: - Maybe (BackendNotification, Version) -> - BackendNotification -> - Maybe (BackendNotification, Version) - combine greatest notif = - let notifGreatest = bodyVersions notif >>= flip latestCommonVersion remoteVersions + combine :: Maybe (a, Version) -> a -> Maybe (a, Version) + combine greatest a = + let notifGreatest = pr a >>= flip latestCommonVersion remoteVersions in case (greatest, notifGreatest) of (Nothing, Nothing) -> Nothing - (Nothing, Just v) -> Just (notif, v) + (Nothing, Just v) -> Just (a, v) (Just (gn, gv), Nothing) -> Just (gn, gv) (Just (gn, gv), Just v) -> if v > gv - then Just (notif, v) + then Just (a, v) else Just (gn, gv) -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 8586860324a..bfbb2f76eff 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -11,7 +11,6 @@ import Data.ByteString.Builder qualified as Builder import Data.ByteString.Lazy qualified as LBS import Data.Domain import Data.Id -import Data.List.NonEmpty qualified as NE import Data.Range import Data.Sequence qualified as Seq import Data.Set qualified as Set @@ -272,29 +271,18 @@ spec = do mapM_ (\vhost -> vhost `shouldBe` rabbitmqVHost) calls describe "mostRecentNotif" $ do - let versionToBundle (NE.nonEmpty -> Just (versionRanges :: NE.NonEmpty VersionRange)) = do - PayloadBundle $ - flip fmap versionRanges $ \v -> - BackendNotification - { ownDomain = undefined, - targetComponent = undefined, - path = undefined, - body = undefined, - bodyVersions = Just v, - requestId = undefined - } - + let mostRecent = mostRecentTuple Just -- FUTUREWORK: once we have more Version values, we may want to add some tests here. it "[..] + [] = null" $ do - mostRecentNotif (versionToBundle [allVersions]) (Set.fromList []) `shouldBe` Nothing + mostRecent [allVersions] (Set.fromList []) `shouldBe` Nothing it "[0] + [1] = null" $ do - mostRecentNotif (versionToBundle [VersionRange V0 (Just V1)]) (Set.fromList []) `shouldBe` Nothing + mostRecent [VersionRange V0 (Just V1)] (Set.fromList []) `shouldBe` Nothing it "[1] + [0, 1] = 1" $ do - fmap snd (mostRecentNotif (versionToBundle [VersionRange V1 Nothing]) (Set.fromList [0, 1])) `shouldBe` Just V1 + fmap snd (mostRecent [VersionRange V1 Nothing] (Set.fromList [0, 1])) `shouldBe` Just V1 it "[0] + [0, 1] = 0" $ do - fmap snd (mostRecentNotif (versionToBundle [VersionRange V0 (Just V1)]) (Set.fromList [0, 1])) `shouldBe` Just V0 + fmap snd (mostRecent [VersionRange V0 (Just V1)] (Set.fromList [0, 1])) `shouldBe` Just V0 it "[..] + [1] = 1" $ do - fmap snd (mostRecentNotif (versionToBundle [VersionRange V0 (Just V1), VersionRange V1 Nothing]) (Set.fromList [1])) `shouldBe` Just V1 + fmap snd (mostRecent [VersionRange V0 (Just V1), VersionRange V1 Nothing] (Set.fromList [1])) `shouldBe` Just V1 untilM :: (Monad m) => m Bool -> m () untilM action = do From bd73ba60f64543f7ec1bf7d0e0d29b3be6d7d73b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Mon, 29 Jan 2024 15:45:22 +0100 Subject: [PATCH 23/52] Move mostRecentTuple --- .../src/Wire/API/Federation/Version.hs | 16 ++++++++ .../Test/Wire/API/Federation/VersionSpec.hs | 40 +++++++++++++++++++ .../wire-api-federation.cabal | 3 ++ .../src/Wire/BackendNotificationPusher.hs | 26 +----------- .../Wire/BackendNotificationPusherSpec.hs | 17 -------- 5 files changed, 60 insertions(+), 42 deletions(-) create mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 8b62a39429c..30ebf8beb46 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -41,6 +41,7 @@ where import Control.Lens (makeLenses, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.List.NonEmpty qualified as NE import Data.OpenApi qualified as S import Data.Schema import Data.Set qualified as Set @@ -141,6 +142,21 @@ latestCommonVersion :: VersionRange -> Set Int -> Maybe Version latestCommonVersion (Set.map versionInt . enumVersionRange -> localVersions) remoteVersions = intToVersion =<< Set.lookupMax (Set.intersection localVersions remoteVersions) +mostRecentTuple :: forall a. (a -> Maybe VersionRange) -> NE.NonEmpty a -> Set Int -> Maybe (a, Version) +mostRecentTuple pr (NE.toList -> as) remoteVersions = foldl' combine Nothing as + where + combine :: Maybe (a, Version) -> a -> Maybe (a, Version) + combine greatest a = + let notifGreatest = pr a >>= flip latestCommonVersion remoteVersions + in case (greatest, notifGreatest) of + (Nothing, Nothing) -> Nothing + (Nothing, Just v) -> Just (a, v) + (Just (gn, gv), Nothing) -> Just (gn, gv) + (Just (gn, gv), Just v) -> + if v > gv + then Just (a, v) + else Just (gn, gv) + $(genSingletons [''Version]) $(promoteOrdInstances [''Version]) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs new file mode 100644 index 00000000000..859ebccca1d --- /dev/null +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs @@ -0,0 +1,40 @@ +-- 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 Test.Wire.API.Federation.VersionSpec where + +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Set qualified as Set +import Imports +import Test.Hspec +import Wire.API.Federation.Version + +spec :: Spec +spec = do + describe "mostRecentTuple" $ do + let mostRecent = mostRecentTuple Just + -- FUTUREWORK: once we have more Version values, we may want to add some tests here. + it "[..] + [] = null" $ do + mostRecent (pure allVersions) (Set.fromList []) `shouldBe` Nothing + it "[0] + [1] = null" $ do + mostRecent (pure $ VersionRange V0 (Just V1)) (Set.fromList []) `shouldBe` Nothing + it "[1] + [0, 1] = 1" $ do + fmap snd (mostRecent (pure $ VersionRange V1 Nothing) (Set.fromList [0, 1])) `shouldBe` Just V1 + it "[0] + [0, 1] = 0" $ do + fmap snd (mostRecent (pure $ VersionRange V0 (Just V1)) (Set.fromList [0, 1])) `shouldBe` Just V0 + it "[..] + [1] = 1" $ do + fmap snd (mostRecent (VersionRange V0 (Just V1) :| [VersionRange V1 Nothing]) (Set.fromList [1])) `shouldBe` Just V1 diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index d92f39c0792..689611a40f2 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -31,6 +31,7 @@ library Wire.API.Federation.Error Wire.API.Federation.HasNotificationEndpoint Wire.API.Federation.Version + Wire.API.Federation.VersionSpec other-modules: Paths_wire_api_federation hs-source-dirs: src @@ -138,6 +139,8 @@ test-suite spec Test.Wire.API.Federation.Golden.NewConnectionRequest Test.Wire.API.Federation.Golden.NewConnectionResponse Test.Wire.API.Federation.Golden.Runner + Test.Wire.API.Federation.Version + Test.Wire.API.Federation.VersionSpec hs-source-dirs: test default-extensions: diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 15976739760..583ef5f97c8 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -147,7 +147,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do . Log.field "error" (displayException e) throwM e Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi - case mostRecentNotif bundle remoteVersions of + case mostRecentTuple bodyVersions (notifications bundle) remoteVersions of Nothing -> -- TODO(md): do more severe logging warning the site operator Log.err $ @@ -167,30 +167,6 @@ pushNotification runningFlag targetDomain (msg, envelope) = do withLabel metrics.pushedCounter (domainText targetDomain) incCounter withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) --- TODO(md): put this into BackendNotification.hs (and tests too) --- --- FUTUREWORK(fisx): we could compute a Set Int from the bundle and do set --- operations on remoteVersions and localVersions. would be slightly more --- readable, possibly. -mostRecentNotif :: PayloadBundle c -> Set Int -> Maybe (BackendNotification, Version) -mostRecentNotif = - mostRecentTuple bodyVersions . (NE.toList . notifications) - -mostRecentTuple :: forall a. (a -> Maybe VersionRange) -> [a] -> Set Int -> Maybe (a, Version) -mostRecentTuple pr as remoteVersions = foldl' combine Nothing as - where - combine :: Maybe (a, Version) -> a -> Maybe (a, Version) - combine greatest a = - let notifGreatest = pr a >>= flip latestCommonVersion remoteVersions - in case (greatest, notifGreatest) of - (Nothing, Nothing) -> Nothing - (Nothing, Just v) -> Just (a, v) - (Just (gn, gv), Nothing) -> Just (gn, gv) - (Just (gn, gv), Just v) -> - if v > gv - then Just (a, v) - else Just (gn, gv) - -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter -- for a handful of remote domains. -- Consumers is passed in explicitly so that cleanup code has a reference to the consumer tags. diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index bfbb2f76eff..081a058aef6 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-incomplete-patterns #-} module Test.Wire.BackendNotificationPusherSpec where @@ -13,7 +12,6 @@ import Data.Domain import Data.Id import Data.Range import Data.Sequence qualified as Seq -import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Federator.MockServer @@ -43,7 +41,6 @@ import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Federation.BackendNotifications -import Wire.API.Federation.Version import Wire.API.RawJson import Wire.BackendNotificationPusher import Wire.BackgroundWorker.Env @@ -270,20 +267,6 @@ spec = do calls `shouldSatisfy` (\c -> length c >= 2) mapM_ (\vhost -> vhost `shouldBe` rabbitmqVHost) calls - describe "mostRecentNotif" $ do - let mostRecent = mostRecentTuple Just - -- FUTUREWORK: once we have more Version values, we may want to add some tests here. - it "[..] + [] = null" $ do - mostRecent [allVersions] (Set.fromList []) `shouldBe` Nothing - it "[0] + [1] = null" $ do - mostRecent [VersionRange V0 (Just V1)] (Set.fromList []) `shouldBe` Nothing - it "[1] + [0, 1] = 1" $ do - fmap snd (mostRecent [VersionRange V1 Nothing] (Set.fromList [0, 1])) `shouldBe` Just V1 - it "[0] + [0, 1] = 0" $ do - fmap snd (mostRecent [VersionRange V0 (Just V1)] (Set.fromList [0, 1])) `shouldBe` Just V0 - it "[..] + [1] = 1" $ do - fmap snd (mostRecent [VersionRange V0 (Just V1), VersionRange V1 Nothing] (Set.fromList [1])) `shouldBe` Just V1 - untilM :: (Monad m) => m Bool -> m () untilM action = do b <- action From 16d520c182aa259b5cbfa50add5f37afec842b04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marko=20Dimja=C5=A1evi=C4=87?= Date: Tue, 30 Jan 2024 09:39:55 +0100 Subject: [PATCH 24/52] Disable a deprecation warning I don't know how to fix the warning so turning it off is probably not the nicest thing to do --- .../test/Test/Wire/BackendNotificationPusherSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 081a058aef6..838359d0da0 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Test.Wire.BackendNotificationPusherSpec where From 12889ae37d78fdf888ac74aaaa0e22523a99fde4 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Feb 2024 11:25:55 +0100 Subject: [PATCH 25/52] Inline reqOrigin --- .../src/Wire/API/Federation/BackendNotifications.hs | 6 ------ services/brig/src/Brig/Federation/Client.hs | 3 ++- services/galley/src/Galley/API/Action.hs | 3 ++- services/galley/src/Galley/API/Clients.hs | 3 ++- services/galley/src/Galley/API/Internal.hs | 3 ++- services/galley/src/Galley/API/MLS/Propagate.hs | 3 ++- services/galley/src/Galley/API/Message.hs | 3 ++- 7 files changed, 12 insertions(+), 12 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index d70aeff9da5..817d275c0a3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -190,12 +190,6 @@ ensureQueue chan queue = do newtype FedQueueClient c a = FedQueueClient (ReaderT FedQueueEnv IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadReader FedQueueEnv) -reqOrigin :: FedQueueClient c (RequestId, Domain) -reqOrigin = do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - pure (reqId, origin) - data FedQueueEnv = FedQueueEnv { channel :: Q.Channel, originDomain :: Domain, diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 391046bcede..591d3edb95f 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -158,7 +158,8 @@ notifyUserDeleted self remotes = do Just chanVar -> do enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ void $ do - (reqId, origin) <- reqOrigin + reqId <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnUserDeletedConnectionsTag reqId origin notif Nothing -> Log.err $ diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index e392b2519c0..2c6d066148a 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -900,7 +900,8 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid then do - (reqId, origin) <- reqOrigin + reqId <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient (toBundle @'OnConversationUpdatedTag reqId origin update) $> Nothing else pure (Just update) diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index bc1fe119ec4..f98a46fb35a 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -140,7 +140,8 @@ rmClientH (usr ::: cid) = do removeRemoteMLSClients convIds = do for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> let rpc = void $ do - (req, origin) <- reqOrigin + req <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient ( toBundle @'OnClientRemovedTag req diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index eece786b7f6..2cfa2fd179c 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -427,7 +427,8 @@ rmUser lusr conn = do for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) let rpc = void $ do - (req, origin) <- reqOrigin + req <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnUserDeletedConversationsTag req origin userDelete enqueueNotification remoteConvs Q.Persistent rpc diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 0ee5572a4f3..3f3f014188f 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -90,7 +90,8 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do -- send to remotes (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ \rs -> do - (reqId, origin) <- reqOrigin + reqId <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnMLSMessageSentTag reqId diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index f094e6984fc..4162ff38bae 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -700,7 +700,8 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand recipients = UserClientMap rcpts } let rpc = void $ do - (reqId, origin) <- reqOrigin + reqId <- asks (.requestId) + origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnMessageSentTag reqId origin rm enqueueNotification domain Q.Persistent rpc where From 8ce41a27aff14ca66a6ba6633ea225708e01cab2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Feb 2024 11:22:39 +0100 Subject: [PATCH 26/52] Remove redundant maxBound Co-authored-by: fisx --- libs/wire-api-federation/src/Wire/API/Federation/Version.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 30ebf8beb46..24b7e58847b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -58,7 +58,7 @@ versionInt V0 = 0 versionInt V1 = 1 intToVersion :: Int -> Maybe Version -intToVersion intV = find (\v -> versionInt v == intV) [minBound .. maxBound] +intToVersion intV = find (\v -> versionInt v == intV) [minBound ..] instance ToSchema Version where schema = From e9f833ade851028081d5c916fa027f089d0fbc83 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Feb 2024 13:37:34 +0100 Subject: [PATCH 27/52] Introduce change in notification API --- .../Federation/API/Galley/Notifications.hs | 54 ++++++++++++++++++- .../src/Wire/API/Federation/Version.hs | 13 ++--- .../wire-api-federation.cabal | 1 - services/galley/src/Galley/API/Action.hs | 14 ++--- services/galley/src/Galley/API/Create.hs | 25 ++++++--- services/galley/src/Galley/API/Federation.hs | 2 +- services/galley/src/Galley/API/Internal.hs | 10 ++-- services/galley/src/Galley/API/Util.hs | 36 ++++++++----- .../Effects/BackendNotificationQueueAccess.hs | 6 +++ .../Galley/Intra/BackendNotificationQueue.hs | 14 +++++ 10 files changed, 133 insertions(+), 42 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index b804260b0cf..e9fa6b9e91c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -44,6 +44,7 @@ data GalleyNotificationTag = OnClientRemovedTag | OnMessageSentTag | OnMLSMessageSentTag + | OnConversationUpdatedTagV0 | OnConversationUpdatedTag | OnUserDeletedConversationsTag deriving (Show, Eq, Generic, Bounded, Enum) @@ -70,10 +71,15 @@ instance HasNotificationEndpoint 'OnMLSMessageSentTag where -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation +instance HasNotificationEndpoint 'OnConversationUpdatedTagV0 where + type Payload 'OnConversationUpdatedTagV0 = ConversationUpdateV0 + type NotificationPath 'OnConversationUpdatedTagV0 = "on-conversation-updated" + versionRange = rangeUntilVersion V1 + instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" - versionRange = allVersions + versionRange = rangeFromVersion V1 instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification @@ -135,7 +141,7 @@ data RemoteMLSMessage = RemoteMLSMessage instance ToSchema RemoteMLSMessage -data ConversationUpdate = ConversationUpdate +data ConversationUpdateV0 = ConversationUpdateV0 { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, -- | The unqualified ID of the conversation where the update is happening. @@ -153,12 +159,56 @@ data ConversationUpdate = ConversationUpdate } deriving (Eq, Show, Generic) +instance ToJSON ConversationUpdateV0 + +instance FromJSON ConversationUpdateV0 + +instance ToSchema ConversationUpdateV0 + +data ConversationUpdate = ConversationUpdate + { time :: UTCTime, + origUserId :: Qualified UserId, + -- | The unqualified ID of the conversation where the update is happening. + -- The ID is local to the sender to prevent putting arbitrary domain that + -- is different than that of the backend making a conversation membership + -- update request. + convId :: ConvId, + -- | A list of users from the receiving backend that need to be sent + -- notifications about this change. This is required as we do not expect a + -- non-conversation owning backend to have an indexed mapping of + -- conversation to users. + alreadyPresentUsers :: [UserId], + -- | Information on the specific action that caused the update. + action :: SomeConversationAction + } + deriving (Eq, Show, Generic) + instance ToJSON ConversationUpdate instance FromJSON ConversationUpdate instance ToSchema ConversationUpdate +conversationUpdateToV0 :: ConversationUpdate -> ConversationUpdateV0 +conversationUpdateToV0 cu = + ConversationUpdateV0 + { cuTime = cu.time, + cuOrigUserId = cu.origUserId, + cuConvId = cu.convId, + cuAlreadyPresentUsers = cu.alreadyPresentUsers, + cuAction = cu.action + } + +conversationUpdateFromV0 :: ConversationUpdateV0 -> ConversationUpdate +conversationUpdateFromV0 cu = + ConversationUpdate + { time = cu.cuTime, + origUserId = cu.cuOrigUserId, + convId = cu.cuConvId, + alreadyPresentUsers = cu.cuAlreadyPresentUsers, + action = cu.cuAction + } + type UserDeletedNotificationMaxConvs = 1000 data UserDeletedConversationsNotification = UserDeletedConversationsNotification diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 24b7e58847b..e6b60ec2e96 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -32,9 +32,9 @@ module Wire.API.Federation.Version fromVersion, toVersionExcl, allVersions, - fromVersions, - untilVersions, latestCommonVersion, + rangeFromVersion, + rangeUntilVersion, mostRecentTuple, ) where @@ -94,6 +94,7 @@ versionInfo = VersionInfo (toList supportedVersions) data VersionRange = VersionRange { _fromVersion :: Version, + -- | 'Nothing' here means that 'maxBound' is included. _toVersionExcl :: Maybe Version } @@ -121,11 +122,11 @@ deriving via Schema VersionRange instance FromJSON VersionRange allVersions :: VersionRange allVersions = VersionRange minBound Nothing -fromVersions :: Version -> VersionRange -fromVersions v = VersionRange v Nothing +rangeFromVersion :: Version -> VersionRange +rangeFromVersion v = VersionRange v Nothing -untilVersions :: Version -> VersionRange -untilVersions v = VersionRange minBound (Just v) +rangeUntilVersion :: Version -> VersionRange +rangeUntilVersion v = VersionRange minBound (Just v) enumVersionRange :: VersionRange -> Set Version enumVersionRange = diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 689611a40f2..7df9c193fc7 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -31,7 +31,6 @@ library Wire.API.Federation.Error Wire.API.Federation.HasNotificationEndpoint Wire.API.Federation.Version - Wire.API.Federation.VersionSpec other-modules: Paths_wire_api_federation hs-source-dirs: src diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 2c6d066148a..6b09122e31d 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -928,14 +928,14 @@ updateLocalStateOfRemoteConv :: updateLocalStateOfRemoteConv rcu con = do loc <- qualifyLocal () let cu = tUnqualified rcu - rconvId = fmap F.cuConvId rcu + rconvId = fmap (.convId) rcu qconvId = tUntagged rconvId -- Note: we generally do not send notifications to users that are not part of -- the conversation (from our point of view), to prevent spam from the remote -- backend. See also the comment below. (presentUsers, allUsersArePresent) <- - E.selectRemoteMembers (F.cuAlreadyPresentUsers cu) rconvId + E.selectRemoteMembers cu.alreadyPresentUsers rconvId -- Perform action, and determine extra notification targets. -- @@ -946,12 +946,12 @@ updateLocalStateOfRemoteConv rcu con = do -- updated, we do **not** add them to the list of targets, because we have no -- way to make sure that they are actually supposed to receive that notification. - (mActualAction, extraTargets) <- case F.cuAction cu of + (mActualAction, extraTargets) <- case cu.action of sca@(SomeConversationAction singTag action) -> case singTag of SConversationJoinTag -> do let ConversationJoin toAdd role = action let (localUsers, remoteUsers) = partitionQualified loc toAdd - addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId (F.cuOrigUserId cu) localUsers + addedLocalUsers <- Set.toList <$> addLocalUsersToRemoteConv rconvId cu.origUserId localUsers let allAddedUsers = map (tUntagged . qualifyAs loc) addedLocalUsers <> map tUntagged remoteUsers pure $ ( fmap @@ -960,7 +960,7 @@ updateLocalStateOfRemoteConv rcu con = do addedLocalUsers ) SConversationLeaveTag -> do - let users = foldQualified loc (pure . tUnqualified) (const []) (F.cuOrigUserId cu) + let users = foldQualified loc (pure . tUnqualified) (const []) cu.origUserId E.deleteMembersInRemoteConversation rconvId users pure (Just sca, []) SConversationRemoveMembersTag -> do @@ -980,7 +980,7 @@ updateLocalStateOfRemoteConv rcu con = do unless allUsersArePresent $ P.warn $ - Log.field "conversation" (toByteString' (F.cuConvId cu)) + Log.field "conversation" (toByteString' cu.convId) . Log.field "domain" (toByteString' (tDomain rcu)) . Log.msg ( "Attempt to send notification about conversation update \ @@ -990,7 +990,7 @@ updateLocalStateOfRemoteConv rcu con = do -- Send notifications for mActualAction $ \(SomeConversationAction tag action) -> do - let event = conversationActionToEvent tag (F.cuTime cu) (F.cuOrigUserId cu) qconvId Nothing action + let event = conversationActionToEvent tag cu.time cu.origUserId qconvId Nothing action targets = nubOrd $ presentUsers <> extraTargets -- FUTUREWORK: support bots? pushConversationEvent con event (qualifyAs loc targets) [] $> event diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index f255c0d9658..837a79dfd7e 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -91,7 +91,8 @@ import Wire.NotificationSubsystem -- | The public-facing endpoint for creating group conversations in the client -- API up to and including version 3. createGroupConversationUpToV3 :: - ( Member BrigAccess r, + ( Member BackendNotificationQueueAccess r, + Member BrigAccess r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, @@ -129,7 +130,8 @@ createGroupConversationUpToV3 lusr conn newConv = mapError UnreachableBackendsLe -- | The public-facing endpoint for creating group conversations in the client -- API in version 4 and above. createGroupConversation :: - ( Member BrigAccess r, + ( Member BackendNotificationQueueAccess r, + Member BrigAccess r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, @@ -169,7 +171,8 @@ createGroupConversation lusr conn newConv = do CreateGroupConversation conv mempty createGroupConversationGeneric :: - ( Member BrigAccess r, + ( Member BackendNotificationQueueAccess r, + Member BrigAccess r, Member ConversationStore r, Member (ErrorS 'ConvAccessDenied) r, Member (Error FederationError) r, @@ -309,7 +312,8 @@ createProteusSelfConversation lusr = do conversationCreated lusr c createOne2OneConversation :: - ( Member BrigAccess r, + ( Member BackendNotificationQueueAccess r, + Member BrigAccess r, Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -386,7 +390,8 @@ createOne2OneConversation lusr zcon j = Nothing -> throwS @'TeamNotFound createLegacyOne2OneConversationUnchecked :: - ( Member ConversationStore r, + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error InvalidInput) r, @@ -428,7 +433,8 @@ createLegacyOne2OneConversationUnchecked self zcon name mtid other = do Right () -> conversationCreated self c createOne2OneConversationUnchecked :: - ( Member ConversationStore r, + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error UnreachableBackends) r, @@ -452,7 +458,8 @@ createOne2OneConversationUnchecked self zcon name mtid other = do create (one2OneConvId BaseProtocolProteusTag (tUntagged self) other) self zcon name mtid other createOne2OneConversationLocally :: - ( Member ConversationStore r, + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, Member (Error FederationError) r, Member (Error InternalError) r, Member (Error UnreachableBackends) r, @@ -502,7 +509,8 @@ createOne2OneConversationRemotely _ _ _ _ _ _ = throw FederationNotImplemented createConnectConversation :: - ( Member ConversationStore r, + ( Member BackendNotificationQueueAccess r, + Member ConversationStore r, Member (ErrorS 'ConvNotFound) r, Member (Error FederationError) r, Member (Error InternalError) r, @@ -654,6 +662,7 @@ notifyCreatedConversation :: Member (Error UnreachableBackends) r, Member FederatorAccess r, Member NotificationSubsystem r, + Member BackendNotificationQueueAccess r, Member (Input UTCTime) r, Member P.TinyLog r ) => diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 7e292c55aab..071f846d27e 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -464,7 +464,7 @@ updateConversation origDomain updateRequest = do let rusr = toRemoteUnsafe origDomain updateRequest.user lcnv = qualifyAs loc updateRequest.convId - mkResponse $ case action updateRequest of + mkResponse $ case updateRequest.action of SomeConversationAction tag action -> case tag of SConversationJoinTag -> mapToGalleyError @(HasConversationActionGalleyErrors 'ConversationJoinTag) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2cfa2fd179c..4c595dbf712 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -412,11 +412,11 @@ rmUser lusr conn = do notifyRemoteMembers now qUser cid remotes = do let convUpdate = ConversationUpdate - { cuTime = now, - cuOrigUserId = qUser, - cuConvId = cid, - cuAlreadyPresentUsers = tUnqualified remotes, - cuAction = SomeConversationAction (sing @'ConversationLeaveTag) () + { time = now, + origUserId = qUser, + convId = cid, + alreadyPresentUsers = tUnqualified remotes, + action = SomeConversationAction (sing @'ConversationLeaveTag) () } let rpc = fedClient @'Galley @"on-conversation-updated" convUpdate runFederatedEither remotes rpc diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index b4759ef59e2..b59cb22df48 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -45,6 +45,7 @@ import Galley.Data.Conversation qualified as Data import Galley.Data.Services (BotMember, newBotMember) import Galley.Data.Types qualified as DataTypes import Galley.Effects +import Galley.Effects.BackendNotificationQueueAccess import Galley.Effects.BrigAccess import Galley.Effects.CodeStore import Galley.Effects.ConversationStore @@ -60,6 +61,7 @@ import Galley.Types.Teams import Galley.Types.UserList import Gundeck.Types.Push.V2 qualified as PushV2 import Imports hiding (forkIO) +import Network.AMQP qualified as Q import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (Error, fromEither) @@ -80,6 +82,7 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.Password import Wire.API.Routes.Public.Galley.Conversation @@ -823,12 +826,12 @@ ensureNoUnreachableBackends results = do throw (UnreachableBackends (map (tDomain . fst) errors)) pure values --- | Notify remote users of being added to a new conversation. In case a remote --- domain is unreachable, an exception is thrown, the conversation deleted and --- the client gets an error response. +-- | Notify remote users of being added to a new conversation. registerRemoteConversationMemberships :: ( Member ConversationStore r, Member (Error UnreachableBackends) r, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r, Member FederatorAccess r ) => -- | The time stamp when the conversation was created @@ -861,6 +864,7 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do -- reachable members in buckets per remote domain let joined :: [Remote [RemoteMember]] = allRemoteBuckets + joinedCoupled :: [(Remote [RemoteMember], NonEmpty (Remote UserId))] joinedCoupled = foldMap ( \ruids -> @@ -873,10 +877,18 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do ) joined - void . (ensureNoUnreachableBackends =<<) $ - -- Send an update to remotes about the final list of participants - runFederatedConcurrentlyBucketsEither joinedCoupled $ - fedClient @'Galley @"on-conversation-updated" . convUpdateJoin + -- Send an update to remotes about the final list of participants + -- runFederatedConcurrentlyBucketsEither joinedCoupled $ + -- fedClient @'Galley @"on-conversation-updated" . convUpdateJoin + + -- runFederatedConcurrentlyEither : does the bucketing + -- runFederatedConcurrentlyBucketsEither : takes a list of buckets + + r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> do + reqId <- asks (.requestId) + origin <- asks (.originDomain) + fedQueueClient $ toBundle @'OnConversationUpdatedTag reqId origin (convUpdateJoin z) + either throw (void . pure) r where creator :: Maybe UserId creator = cnvmCreator . DataTypes.convMetadata . tUnqualified $ lc @@ -896,11 +908,11 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do convUpdateJoin :: (QualifiedWithTag t [RemoteMember], NonEmpty (QualifiedWithTag t' UserId)) -> ConversationUpdate convUpdateJoin (toNotify, newMembers) = ConversationUpdate - { cuTime = now, - cuOrigUserId = tUntagged lusr, - cuConvId = DataTypes.convId (tUnqualified lc), - cuAlreadyPresentUsers = fmap (tUnqualified . rmId) . tUnqualified $ toNotify, - cuAction = + { time = now, + origUserId = tUntagged lusr, + convId = DataTypes.convId (tUnqualified lc), + alreadyPresentUsers = fmap (tUnqualified . rmId) . tUnqualified $ toNotify, + action = SomeConversationAction (sing @'ConversationJoinTag) -- FUTUREWORK(md): replace the member role with whatever is provided in diff --git a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs index bdefa146314..3e6791d3a11 100644 --- a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs +++ b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs @@ -23,5 +23,11 @@ data BackendNotificationQueueAccess m a where f (Remote x) -> (Remote [x] -> FedQueueClient c a) -> BackendNotificationQueueAccess m (Either FederationError [Remote a]) + EnqueueNotificationsConcurrentlyBuckets :: + (KnownComponent c, Foldable f, Functor f) => + Q.DeliveryMode -> + f (Remote [x], y) -> -- FUTUREWORK: could just be `[Remote z]`, probably? this would also make the intepreters way more elegant, maybe. + ((Remote [x], y) -> FedQueueClient c a) -> + BackendNotificationQueueAccess m (Either FederationError [Remote a]) makeSem ''BackendNotificationQueueAccess diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index 316a94dcce7..cf13878af90 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -32,6 +32,8 @@ interpretBackendNotificationQueueAccess = interpret $ \case embedApp . runExceptT $ enqueueNotification (tDomain remote) deliveryMode action EnqueueNotificationsConcurrently m xs rpc -> do embedApp . runExceptT $ enqueueNotificationsConcurrently m xs rpc + EnqueueNotificationsConcurrentlyBuckets m xs rpc -> do + embedApp . runExceptT $ enqueueNotificationsConcurrentlyBuckets m xs rpc getChannel :: ExceptT FederationError App (MVar Q.Channel) getChannel = view rabbitmqChannel >>= maybe (throwE FederationNotConfigured) pure @@ -78,6 +80,18 @@ enqueueNotificationsConcurrently m xs f = do qualifyAs r <$> enqueueSingleNotification (tDomain r) m chanVar (f r) +enqueueNotificationsConcurrentlyBuckets :: + (Foldable f) => + Q.DeliveryMode -> + f (Remote [x], y) -> + ((Remote [x], y) -> FedQueueClient c a) -> + ExceptT FederationError App [Remote a] +enqueueNotificationsConcurrentlyBuckets m xs f = do + chanVar <- getChannel + lift $ pooledForConcurrentlyN 8 (toList xs) $ \(r, y) -> + qualifyAs r + <$> enqueueSingleNotification (tDomain r) m chanVar (f (r, y)) + data NoRabbitMqChannel = NoRabbitMqChannel deriving (Show) From 6048ede39eceb83d852ec2519b4e5f213f84b854 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 5 Feb 2024 10:30:30 +0100 Subject: [PATCH 28/52] Clean up backend notification effect --- services/galley/src/Galley/API/Clients.hs | 2 +- services/galley/src/Galley/API/Internal.hs | 2 +- services/galley/src/Galley/API/Message.hs | 2 +- services/galley/src/Galley/API/Util.hs | 17 +++++------------ .../Effects/BackendNotificationQueueAccess.hs | 6 +++--- .../src/Galley/Effects/FederatorAccess.hs | 10 +++++----- .../Galley/Intra/BackendNotificationQueue.hs | 16 ++++++++-------- services/galley/src/Galley/Intra/Federator.hs | 11 ++++++----- 8 files changed, 30 insertions(+), 36 deletions(-) diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index f98a46fb35a..5734ae7ee5f 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -148,4 +148,4 @@ rmClientH (usr ::: cid) = do origin (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) ) - in enqueueNotification remoteConvs Q.Persistent rpc + in enqueueNotification Q.Persistent remoteConvs rpc diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 4c595dbf712..2f2bfa9a117 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -431,7 +431,7 @@ rmUser lusr conn = do origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnUserDeletedConversationsTag req origin userDelete - enqueueNotification remoteConvs Q.Persistent rpc + enqueueNotification Q.Persistent remoteConvs rpc -- FUTUREWORK: Add a retry mechanism if there are federation errrors. -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 4162ff38bae..85d83dafb58 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -703,7 +703,7 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand reqId <- asks (.requestId) origin <- asks (.originDomain) fedQueueClient $ toBundle @'OnMessageSentTag reqId origin rm - enqueueNotification domain Q.Persistent rpc + enqueueNotification Q.Persistent domain rpc where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) handle (Right _) = pure mempty diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index b59cb22df48..5066eb9b840 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -864,7 +864,7 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do -- reachable members in buckets per remote domain let joined :: [Remote [RemoteMember]] = allRemoteBuckets - joinedCoupled :: [(Remote [RemoteMember], NonEmpty (Remote UserId))] + joinedCoupled :: [Remote ([RemoteMember], NonEmpty (Remote UserId))] joinedCoupled = foldMap ( \ruids -> @@ -873,17 +873,10 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do filter (\r -> tDomain r /= tDomain ruids) joined in case NE.nonEmpty nj of Nothing -> [] - Just v -> [(ruids, v)] + Just v -> [fmap (,v) ruids] ) joined - -- Send an update to remotes about the final list of participants - -- runFederatedConcurrentlyBucketsEither joinedCoupled $ - -- fedClient @'Galley @"on-conversation-updated" . convUpdateJoin - - -- runFederatedConcurrentlyEither : does the bucketing - -- runFederatedConcurrentlyBucketsEither : takes a list of buckets - r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> do reqId <- asks (.requestId) origin <- asks (.originDomain) @@ -905,13 +898,13 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do toMembers :: [RemoteMember] -> Set OtherMember toMembers rs = Set.fromList $ localNonCreators <> fmap remoteMemberToOther rs - convUpdateJoin :: (QualifiedWithTag t [RemoteMember], NonEmpty (QualifiedWithTag t' UserId)) -> ConversationUpdate - convUpdateJoin (toNotify, newMembers) = + convUpdateJoin :: Remote ([RemoteMember], NonEmpty (Remote UserId)) -> ConversationUpdate + convUpdateJoin (tUnqualified -> (toNotify, newMembers)) = ConversationUpdate { time = now, origUserId = tUntagged lusr, convId = DataTypes.convId (tUnqualified lc), - alreadyPresentUsers = fmap (tUnqualified . rmId) . tUnqualified $ toNotify, + alreadyPresentUsers = fmap (tUnqualified . rmId) toNotify, action = SomeConversationAction (sing @'ConversationJoinTag) diff --git a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs index 3e6791d3a11..93e01126c9f 100644 --- a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs +++ b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs @@ -13,8 +13,8 @@ import Wire.API.Federation.Error data BackendNotificationQueueAccess m a where EnqueueNotification :: KnownComponent c => - Remote x -> Q.DeliveryMode -> + Remote x -> FedQueueClient c a -> BackendNotificationQueueAccess m (Either FederationError a) EnqueueNotificationsConcurrently :: @@ -26,8 +26,8 @@ data BackendNotificationQueueAccess m a where EnqueueNotificationsConcurrentlyBuckets :: (KnownComponent c, Foldable f, Functor f) => Q.DeliveryMode -> - f (Remote [x], y) -> -- FUTUREWORK: could just be `[Remote z]`, probably? this would also make the intepreters way more elegant, maybe. - ((Remote [x], y) -> FedQueueClient c a) -> + f (Remote x) -> + (Remote x -> FedQueueClient c a) -> BackendNotificationQueueAccess m (Either FederationError [Remote a]) makeSem ''BackendNotificationQueueAccess diff --git a/services/galley/src/Galley/Effects/FederatorAccess.hs b/services/galley/src/Galley/Effects/FederatorAccess.hs index 8afd28cb842..cfa3b508c76 100644 --- a/services/galley/src/Galley/Effects/FederatorAccess.hs +++ b/services/galley/src/Galley/Effects/FederatorAccess.hs @@ -63,11 +63,11 @@ data FederatorAccess m a where -- already in buckets. The buckets are paired with arbitrary data that affect -- the payload of the request for each remote backend. RunFederatedConcurrentlyBucketsEither :: - forall (c :: Component) a m x y. - (KnownComponent c) => - [(Remote [x], y)] -> - ((Remote [x], y) -> FederatorClient c a) -> - FederatorAccess m [Either (Remote [x], FederationError) (Remote a)] + forall (c :: Component) f a m x. + (KnownComponent c, Foldable f) => + f (Remote x) -> + (Remote x -> FederatorClient c a) -> + FederatorAccess m [Either (Remote x, FederationError) (Remote a)] IsFederationConfigured :: FederatorAccess m Bool makeSem ''FederatorAccess diff --git a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs index cf13878af90..cefe3cdc1e4 100644 --- a/services/galley/src/Galley/Intra/BackendNotificationQueue.hs +++ b/services/galley/src/Galley/Intra/BackendNotificationQueue.hs @@ -28,8 +28,8 @@ interpretBackendNotificationQueueAccess :: Sem (BackendNotificationQueueAccess ': r) a -> Sem r a interpretBackendNotificationQueueAccess = interpret $ \case - EnqueueNotification remote deliveryMode action -> do - embedApp . runExceptT $ enqueueNotification (tDomain remote) deliveryMode action + EnqueueNotification deliveryMode remote action -> do + embedApp . runExceptT $ enqueueNotification deliveryMode (tDomain remote) action EnqueueNotificationsConcurrently m xs rpc -> do embedApp . runExceptT $ enqueueNotificationsConcurrently m xs rpc EnqueueNotificationsConcurrentlyBuckets m xs rpc -> do @@ -63,8 +63,8 @@ enqueueSingleNotification remoteDomain deliveryMode chanVar action = do Just chan -> do liftIO $ enqueue chan rid ownDomain remoteDomain deliveryMode action -enqueueNotification :: Domain -> Q.DeliveryMode -> FedQueueClient c a -> ExceptT FederationError App a -enqueueNotification remoteDomain deliveryMode action = do +enqueueNotification :: Q.DeliveryMode -> Domain -> FedQueueClient c a -> ExceptT FederationError App a +enqueueNotification deliveryMode remoteDomain action = do chanVar <- getChannel lift $ enqueueSingleNotification remoteDomain deliveryMode chanVar action @@ -83,14 +83,14 @@ enqueueNotificationsConcurrently m xs f = do enqueueNotificationsConcurrentlyBuckets :: (Foldable f) => Q.DeliveryMode -> - f (Remote [x], y) -> - ((Remote [x], y) -> FedQueueClient c a) -> + f (Remote x) -> + (Remote x -> FedQueueClient c a) -> ExceptT FederationError App [Remote a] enqueueNotificationsConcurrentlyBuckets m xs f = do chanVar <- getChannel - lift $ pooledForConcurrentlyN 8 (toList xs) $ \(r, y) -> + lift $ pooledForConcurrentlyN 8 (toList xs) $ \r -> qualifyAs r - <$> enqueueSingleNotification (tDomain r) m chanVar (f (r, y)) + <$> enqueueSingleNotification (tDomain r) m chanVar (f r) data NoRabbitMqChannel = NoRabbitMqChannel deriving (Show) diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index 6e09422c98a..c1dd13bae16 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -102,9 +102,10 @@ runFederatedConcurrentlyEither xs rpc = bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc r) runFederatedConcurrentlyBucketsEither :: - [(Remote [a], y)] -> - ((Remote [a], y) -> FederatorClient c b) -> - App [Either (Remote [a], FederationError) (Remote b)] + Foldable f => + f (Remote x) -> + (Remote x -> FederatorClient c b) -> + App [Either (Remote x, FederationError) (Remote b)] runFederatedConcurrentlyBucketsEither xs rpc = - pooledForConcurrentlyN 8 xs $ \(r, v) -> - bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc (r, v)) + pooledForConcurrentlyN 8 (toList xs) $ \r -> + bimap (r,) (qualifyAs r) <$> runFederatedEither r (rpc r) From e9ce727efbea77e864967905bb6133ac62179c73 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 5 Feb 2024 11:05:42 +0100 Subject: [PATCH 29/52] Refactor fedQueueClient API --- .../src/Wire/API/Federation/API.hs | 17 ++- .../API/Federation/BackendNotifications.hs | 19 ++- .../Federation/Golden/ConversationUpdate.hs | 20 +-- services/brig/src/Brig/Federation/Client.hs | 5 +- services/galley/src/Galley/API/Action.hs | 6 +- services/galley/src/Galley/API/Clients.hs | 12 +- services/galley/src/Galley/API/Internal.hs | 7 +- .../galley/src/Galley/API/MLS/Propagate.hs | 36 +++-- services/galley/src/Galley/API/Message.hs | 7 +- services/galley/src/Galley/API/Util.hs | 7 +- services/galley/test/integration/API.hs | 126 +++++++++--------- .../galley/test/integration/API/Federation.hs | 100 +++++++------- services/galley/test/integration/API/MLS.hs | 10 +- .../galley/test/integration/API/MLS/Util.hs | 10 +- 14 files changed, 189 insertions(+), 193 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 5253d14b8b2..fbde4aca9a7 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -50,6 +50,7 @@ import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client import Wire.API.Federation.Component import Wire.API.Federation.Endpoint +import Wire.API.Federation.HasNotificationEndpoint import Wire.API.MakesFederatedCall import Wire.API.Routes.Named @@ -94,11 +95,11 @@ fedClientIn :: Client m api fedClientIn = clientIn (Proxy @api) (Proxy @m) -fedQueueClient :: +fedQueueClientFromBundle :: KnownComponent c => PayloadBundle c -> FedQueueClient c () -fedQueueClient bundle = do +fedQueueClientFromBundle bundle = do env <- ask let msg = newMsg @@ -112,6 +113,18 @@ fedQueueClient bundle = do ensureQueue env.channel env.targetDomain._domainText void $ publishMsg env.channel exchange (routingKey env.targetDomain._domainText) msg +fedQueueClient :: + forall {k} (tag :: k) c. + ( HasNotificationEndpoint tag, + KnownSymbol (NotificationPath tag), + KnownComponent (NotificationComponent k), + ToJSON (Payload tag), + c ~ NotificationComponent k + ) => + Payload tag -> + FedQueueClient c () +fedQueueClient payload = fedQueueClientFromBundle =<< makeBundle @tag payload + -- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended -- to be used in test situations only. unsafeFedClientIn :: diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 817d275c0a3..c3d5666d063 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -112,9 +112,24 @@ toBundle :: Domain -> Payload tag -> PayloadBundle (NotificationComponent k) -toBundle reqId originDomain payload = do +toBundle reqId originDomain payload = let notif = fedNotifToBackendNotif @tag reqId originDomain payload - PayloadBundle . pure $ notif + in PayloadBundle . pure $ notif + +makeBundle :: + forall {k} (tag :: k) c. + ( HasNotificationEndpoint tag, + KnownSymbol (NotificationPath tag), + KnownComponent (NotificationComponent k), + A.ToJSON (Payload tag), + c ~ NotificationComponent k + ) => + Payload tag -> + FedQueueClient c (PayloadBundle c) +makeBundle payload = do + reqId <- asks (.requestId) + origin <- asks (.originDomain) + pure $ toBundle @tag reqId origin payload type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index 3e8635f9851..f2a3dd76342 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -50,27 +50,27 @@ dee = Id (fromJust (UUID.fromString "00000fff-0000-aaaa-0000-000100005007")) testObject_ConversationUpdate1 :: ConversationUpdate testObject_ConversationUpdate1 = ConversationUpdate - { cuTime = read "1864-04-12 12:22:43.673 UTC", - cuOrigUserId = + { time = read "1864-04-12 12:22:43.673 UTC", + origUserId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000007"))) (Domain "golden.example.com"), - cuConvId = + convId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), - cuAlreadyPresentUsers = [], - cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qAlice :| [qBob]) roleNameWireAdmin) + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qAlice :| [qBob]) roleNameWireAdmin) } testObject_ConversationUpdate2 :: ConversationUpdate testObject_ConversationUpdate2 = ConversationUpdate - { cuTime = read "1864-04-12 12:22:43.673 UTC", - cuOrigUserId = + { time = read "1864-04-12 12:22:43.673 UTC", + origUserId = Qualified (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000007"))) (Domain "golden.example.com"), - cuConvId = + convId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), - cuAlreadyPresentUsers = [chad, dee], - cuAction = SomeConversationAction (sing @'ConversationLeaveTag) () + alreadyPresentUsers = [chad, dee], + action = SomeConversationAction (sing @'ConversationLeaveTag) () } diff --git a/services/brig/src/Brig/Federation/Client.hs b/services/brig/src/Brig/Federation/Client.hs index 591d3edb95f..d86f706169f 100644 --- a/services/brig/src/Brig/Federation/Client.hs +++ b/services/brig/src/Brig/Federation/Client.hs @@ -157,10 +157,7 @@ notifyUserDeleted self remotes = do view rabbitmqChannel >>= \case Just chanVar -> do enqueueNotification (tDomain self) remoteDomain Q.Persistent chanVar $ - void $ do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient $ toBundle @'OnUserDeletedConnectionsTag reqId origin notif + fedQueueClient @'OnUserDeletedConnectionsTag notif Nothing -> Log.err $ Log.msg ("Federation error while notifying remote backends of a user deletion." :: ByteString) diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 6b09122e31d..2398929357c 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -116,7 +116,6 @@ import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as F -import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.FederationStatus import Wire.API.MLS.CipherSuite @@ -899,10 +898,7 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- because quid's backend will update local state and notify its users -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid - then do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient (toBundle @'OnConversationUpdatedTag reqId origin update) $> Nothing + then fedQueueClient @'OnConversationUpdatedTag update $> Nothing else pure (Just update) -- notify local participants and bots diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 5734ae7ee5f..c4077dbf228 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -50,7 +50,6 @@ import Polysemy.TinyLog qualified as P import Wire.API.Conversation hiding (Member) import Wire.API.Federation.API import Wire.API.Federation.API.Galley -import Wire.API.Federation.BackendNotifications import Wire.API.Routes.MultiTablePaging import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (CassandraPaging) @@ -139,13 +138,8 @@ rmClientH (usr ::: cid) = do removeRemoteMLSClients :: Range 1 1000 [Remote ConvId] -> Sem r () removeRemoteMLSClients convIds = do for_ (bucketRemote (fromRange convIds)) $ \remoteConvs -> - let rpc = void $ do - req <- asks (.requestId) - origin <- asks (.originDomain) + let rpc = fedQueueClient - ( toBundle @'OnClientRemovedTag - req - origin - (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) - ) + @'OnClientRemovedTag + (ClientRemovedRequest usr cid (tUnqualified remoteConvs)) in enqueueNotification Q.Persistent remoteConvs rpc diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2f2bfa9a117..d66f5f86a9d 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -91,7 +91,6 @@ import Wire.API.Event.Conversation import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley -import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.Provider.Service hiding (Service) import Wire.API.Routes.API @@ -426,11 +425,7 @@ rmUser lusr conn = do leaveRemoteConversations cids = for_ (bucketRemote (fromRange cids)) $ \remoteConvs -> do let userDelete = UserDeletedConversationsNotification (tUnqualified lusr) (unsafeRange (tUnqualified remoteConvs)) - let rpc = void $ do - req <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient $ - toBundle @'OnUserDeletedConversationsTag req origin userDelete + let rpc = fedQueueClient @'OnUserDeletedConversationsTag userDelete enqueueNotification Q.Persistent remoteConvs rpc -- FUTUREWORK: Add a retry mechanism if there are federation errrors. diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 3f3f014188f..3a99fa9783d 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -41,7 +41,6 @@ import Polysemy.TinyLog hiding (trace) import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley -import Wire.API.Federation.BackendNotifications import Wire.API.MLS.Credential import Wire.API.MLS.Message import Wire.API.MLS.Serialisation @@ -89,26 +88,21 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do -- send to remotes (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ - \rs -> do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient $ - toBundle @'OnMLSMessageSentTag - reqId - origin - ( RemoteMLSMessage - { time = now, - sender = qusr, - metadata = mm, - conversation = qUnqualified qcnv, - subConversation = sconv, - recipients = - Map.fromList $ - tUnqualified rs - >>= toList . remoteMemberMLSClients, - message = Base64ByteString msg.raw - } - ) + \rs -> + fedQueueClient + @'OnMLSMessageSentTag + RemoteMLSMessage + { time = now, + sender = qusr, + metadata = mm, + conversation = qUnqualified qcnv, + subConversation = sconv, + recipients = + Map.fromList $ + tUnqualified rs + >>= toList . remoteMemberMLSClients, + message = Base64ByteString msg.raw + } where cmWithoutSender = maybe cm (flip cmRemoveClient cm . mkClientIdentity qusr) mSenderClient diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index 85d83dafb58..e28839f0f95 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -78,7 +78,6 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Galley -import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Message @@ -699,11 +698,7 @@ sendRemoteMessages domain now sender senderClient lcnv metadata messages = (hand transient = mmTransient metadata, recipients = UserClientMap rcpts } - let rpc = void $ do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient $ toBundle @'OnMessageSentTag reqId origin rm - enqueueNotification Q.Persistent domain rpc + enqueueNotification Q.Persistent domain (fedQueueClient @'OnMessageSentTag rm) where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) handle (Right _) = pure mempty diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 5066eb9b840..b5781ecde71 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -82,7 +82,6 @@ import Wire.API.Error.Galley import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley -import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Error import Wire.API.Password import Wire.API.Routes.Public.Galley.Conversation @@ -877,10 +876,8 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do ) joined - r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> do - reqId <- asks (.requestId) - origin <- asks (.originDomain) - fedQueueClient $ toBundle @'OnConversationUpdatedTag reqId origin (convUpdateJoin z) + r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + fedQueueClient @'OnConversationUpdatedTag (convUpdateJoin z) either throw (void . pure) r where creator :: Maybe UserId diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 2ac9f185e71..94dcaa803de 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -502,15 +502,15 @@ postConvWithRemoteUsersOk rbs = do let fedReqsAdd = filter (\r -> frRPC r == "on-conversation-updated") federatedRequests fedReqAddBodies <- for fedReqsAdd $ assertRight . parseFedRequest forM_ fedReqAddBodies $ \(fedReqAddBody :: ConversationUpdate) -> liftIO $ do - fedReqAddBody.cuOrigUserId @?= qAlice - fedReqAddBody.cuConvId @?= cid + fedReqAddBody.origUserId @?= qAlice + fedReqAddBody.convId @?= cid -- This remote backend must already have their users in the conversation, -- otherwise they should not be receiving the conversation update message assertBool "The list of already present users should be non-empty" . not . null - $ fedReqAddBody.cuAlreadyPresentUsers - case fedReqAddBody.cuAction of + $ fedReqAddBody.alreadyPresentUsers + case fedReqAddBody.action of SomeConversationAction SConversationJoinTag _action -> pure () _ -> assertFailure @() "Unexpected update action" where @@ -1867,11 +1867,11 @@ paginateConvListIds = do conv <- randomId let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qChad, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) + { time = now, + origUserId = qChad, + convId = conv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu @@ -1883,11 +1883,11 @@ paginateConvListIds = do conv <- randomId let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qDee, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) + { time = now, + origUserId = qDee, + convId = conv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu @@ -1928,11 +1928,11 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do conv <- randomId let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qChad, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) + { time = now, + origUserId = qChad, + convId = conv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu @@ -1946,11 +1946,11 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do conv <- randomId let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qDee, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) + { time = now, + origUserId = qDee, + convId = conv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu @@ -3204,11 +3204,11 @@ putRemoteConvMemberOk update = do now <- liftIO getCurrentTime let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = qUnqualified qconv, - cuAlreadyPresentUsers = [], - cuAction = + { time = now, + origUserId = qbob, + convId = qUnqualified qconv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu @@ -3349,11 +3349,11 @@ putRemoteReceiptModeOk = do now <- liftIO getCurrentTime let cuAddAlice = ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = qUnqualified qconv, - cuAlreadyPresentUsers = [], - cuAction = + { time = now, + origUserId = qbob, + convId = qUnqualified qconv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireAdmin) } void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAlice @@ -3364,11 +3364,11 @@ putRemoteReceiptModeOk = do connectWithRemoteUser adam qbob let cuAddAdam = ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = qUnqualified qconv, - cuAlreadyPresentUsers = [], - cuAction = + { time = now, + origUserId = qbob, + convId = qUnqualified qconv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qadam) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAdam @@ -3377,11 +3377,11 @@ putRemoteReceiptModeOk = do let action = ConversationReceiptModeUpdate newReceiptMode let responseConvUpdate = ConversationUpdate - { cuTime = now, - cuOrigUserId = qalice, - cuConvId = qUnqualified qconv, - cuAlreadyPresentUsers = [adam], - cuAction = + { time = now, + origUserId = qalice, + convId = qUnqualified qconv, + alreadyPresentUsers = [adam], + action = SomeConversationAction (sing @'ConversationReceiptModeUpdateTag) action } let mockResponse = mockReply (ConversationUpdateResponseUpdate responseConvUpdate) @@ -3634,33 +3634,33 @@ removeUser = do liftIO $ do let bConvUpdateRPCs = filter (matchFedRequest bDomain "on-conversation-updated") fedRequests - bConvUpdates <- mapM (assertRight . eitherDecode . frBody) bConvUpdateRPCs + bConvUpdates :: [ConversationUpdate] <- mapM (assertRight . eitherDecode . frBody) bConvUpdateRPCs - bConvUpdatesA2 <- assertOne $ filter (\cu -> cuConvId cu == qUnqualified qconvA2) bConvUpdates - cuOrigUserId bConvUpdatesA2 @?= alexDel - cuAction bConvUpdatesA2 @?= SomeConversationAction (sing @'ConversationLeaveTag) () - cuAlreadyPresentUsers bConvUpdatesA2 @?= [qUnqualified berta] + bConvUpdatesA2 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA2) bConvUpdates + bConvUpdatesA2.origUserId @?= alexDel + bConvUpdatesA2.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () + bConvUpdatesA2.alreadyPresentUsers @?= [qUnqualified berta] - bConvUpdatesA4 <- assertOne $ filter (\cu -> cuConvId cu == qUnqualified qconvA4) bConvUpdates - cuOrigUserId bConvUpdatesA4 @?= alexDel - cuAction bConvUpdatesA4 @?= SomeConversationAction (sing @'ConversationLeaveTag) () - cuAlreadyPresentUsers bConvUpdatesA4 @?= [qUnqualified bart] + bConvUpdatesA4 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA4) bConvUpdates + bConvUpdatesA4.origUserId @?= alexDel + bConvUpdatesA4.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () + bConvUpdatesA4.alreadyPresentUsers @?= [qUnqualified bart] liftIO $ do cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "on-conversation-updated") fedRequests - Right convUpdate <- pure . eitherDecode . frBody $ cConvUpdateRPC - cuConvId convUpdate @?= qUnqualified qconvA4 - cuOrigUserId convUpdate @?= alexDel - cuAction convUpdate @?= SomeConversationAction (sing @'ConversationLeaveTag) () - cuAlreadyPresentUsers convUpdate @?= [qUnqualified carl] + Right (convUpdate :: ConversationUpdate) <- pure . eitherDecode . frBody $ cConvUpdateRPC + convUpdate.convId @?= qUnqualified qconvA4 + convUpdate.origUserId @?= alexDel + convUpdate.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () + convUpdate.alreadyPresentUsers @?= [qUnqualified carl] liftIO $ do dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "on-conversation-updated") fedRequests - Right convUpdate <- pure . eitherDecode . frBody $ dConvUpdateRPC - cuConvId convUpdate @?= qUnqualified qconvA2 - cuOrigUserId convUpdate @?= alexDel - cuAction convUpdate @?= SomeConversationAction (sing @'ConversationLeaveTag) () - cuAlreadyPresentUsers convUpdate @?= [qUnqualified dwight] + Right (convUpdate :: ConversationUpdate) <- pure . eitherDecode . frBody $ dConvUpdateRPC + convUpdate.convId @?= qUnqualified qconvA2 + convUpdate.origUserId @?= alexDel + convUpdate.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () + convUpdate.alreadyPresentUsers @?= [qUnqualified dwight] -- Check memberships mems1 <- fmap cnvMembers . responseJsonError =<< getConvQualified alice' qconvA1 diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 070010d0867..0badb2f79c3 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -241,11 +241,11 @@ addLocalUser = do now <- liftIO getCurrentTime let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [charlie], - FedGalley.cuAction = + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [charlie], + FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qalice :| [qdee]) roleNameWireMember) } WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do @@ -295,11 +295,11 @@ addUnconnectedUsersOnly = do -- Bob attempts to add unconnected Charlie (possible abuse) let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qBob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [alice], - FedGalley.cuAction = + { FedGalley.time = now, + FedGalley.origUserId = qBob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [alice], + FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qCharlie :| []) roleNameWireMember) } -- Alice receives no notifications from this @@ -329,20 +329,20 @@ removeLocalUser = do now <- liftIO getCurrentTime let cuAdd = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qBob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [], - FedGalley.cuAction = + { FedGalley.time = now, + FedGalley.origUserId = qBob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [], + FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } cuRemove = FedGalley.ConversationUpdate - { FedGalley.cuTime = addUTCTime (secondsToNominalDiffTime 5) now, - FedGalley.cuOrigUserId = qAlice, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [alice], - FedGalley.cuAction = + { FedGalley.time = addUTCTime (secondsToNominalDiffTime 5) now, + FedGalley.origUserId = qAlice, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [alice], + FedGalley.action = SomeConversationAction (sing @'ConversationLeaveTag) () } @@ -402,11 +402,11 @@ removeRemoteUser = do let cuRemove user = FedGalley.ConversationUpdate - { FedGalley.cuTime = addUTCTime (secondsToNominalDiffTime 5) now, - FedGalley.cuOrigUserId = qBob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [alice, charlie, dee], - FedGalley.cuAction = + { FedGalley.time = addUTCTime (secondsToNominalDiffTime 5) now, + FedGalley.origUserId = qBob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [alice, charlie, dee], + FedGalley.action = SomeConversationAction (sing @'ConversationRemoveMembersTag) (ConversationRemoveMembers (pure user) EdReasonRemoved) @@ -457,11 +457,11 @@ notifyUpdate extras action etype edata = do now <- liftIO getCurrentTime let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [alice, charlie], - FedGalley.cuAction = action + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [alice, charlie], + FedGalley.action = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu @@ -499,11 +499,11 @@ notifyUpdateUnavailable extras action etype edata = do now <- liftIO getCurrentTime let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [alice, charlie], - FedGalley.cuAction = action + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [alice, charlie], + FedGalley.action = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do ((), _fedRequests) <- @@ -635,11 +635,11 @@ notifyDeletedConversation = do now <- liftIO getCurrentTime let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = qUnqualified qconv, - FedGalley.cuAlreadyPresentUsers = [alice], - FedGalley.cuAction = SomeConversationAction (sing @'ConversationDeleteTag) () + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = qUnqualified qconv, + FedGalley.alreadyPresentUsers = [alice], + FedGalley.action = SomeConversationAction (sing @'ConversationDeleteTag) () } void $ runFedClient @"on-conversation-updated" fedGalleyClient bobDomain cu @@ -691,11 +691,11 @@ addRemoteUser = do -- The conversation owning let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = qUnqualified qconv, - FedGalley.cuAlreadyPresentUsers = map qUnqualified [qalice, qcharlie], - FedGalley.cuAction = + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = qUnqualified qconv, + FedGalley.alreadyPresentUsers = map qUnqualified [qalice, qcharlie], + FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qdee :| [qeve, qflo]) roleNameWireMember) } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do @@ -774,11 +774,11 @@ onMessageSent = do connectWithRemoteUser alice qbob let cu = FedGalley.ConversationUpdate - { FedGalley.cuTime = now, - FedGalley.cuOrigUserId = qbob, - FedGalley.cuConvId = conv, - FedGalley.cuAlreadyPresentUsers = [], - FedGalley.cuAction = + { FedGalley.time = now, + FedGalley.origUserId = qbob, + FedGalley.convId = conv, + FedGalley.alreadyPresentUsers = [], + FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 3429d03a1bc..d998d891fc7 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -880,11 +880,11 @@ testRemoteToRemoteInSub = do connectWithRemoteUser alice qbob let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = qbob, - cuConvId = conv, - cuAlreadyPresentUsers = [], - cuAction = + { time = now, + origUserId = qbob, + convId = conv, + alreadyPresentUsers = [], + action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 8cc9b51c601..d979556e596 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -965,11 +965,11 @@ receiveOnConvUpdated conv origUser joiner = do now <- liftIO getCurrentTime let cu = ConversationUpdate - { cuTime = now, - cuOrigUserId = origUser, - cuConvId = qUnqualified conv, - cuAlreadyPresentUsers = [qUnqualified joiner], - cuAction = + { time = now, + origUserId = origUser, + convId = qUnqualified conv, + alreadyPresentUsers = [qUnqualified joiner], + action = SomeConversationAction SConversationJoinTag ConversationJoin From 71958cf7dba7ab7306ed9d44fa2f0ffcfe1bb5f6 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 5 Feb 2024 14:07:04 +0100 Subject: [PATCH 30/52] Make ConversationUpdate request versioned --- .../src/Wire/API/Federation/API.hs | 10 ++++--- .../src/Wire/API/Federation/API/Util.hs | 29 +++++++++++++++++++ .../API/Federation/HasNotificationEndpoint.hs | 2 +- .../wire-api-federation.cabal | 1 + services/galley/src/Galley/API/Action.hs | 4 ++- services/galley/src/Galley/API/Util.hs | 2 +- 6 files changed, 41 insertions(+), 7 deletions(-) create mode 100644 libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index fbde4aca9a7..5cbecac19d8 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -24,13 +24,14 @@ module Wire.API.Federation.API HasUnsafeFedEndpoint, fedClient, fedQueueClient, - toBundle, + sendBundle, fedClientIn, unsafeFedClientIn, module Wire.API.MakesFederatedCall, -- * Re-exports Component (..), + makeConversationUpdateBundle, ) where @@ -46,6 +47,7 @@ import Servant.Client.Core import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Cargohold import Wire.API.Federation.API.Galley +import Wire.API.Federation.API.Util import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client import Wire.API.Federation.Component @@ -95,11 +97,11 @@ fedClientIn :: Client m api fedClientIn = clientIn (Proxy @api) (Proxy @m) -fedQueueClientFromBundle :: +sendBundle :: KnownComponent c => PayloadBundle c -> FedQueueClient c () -fedQueueClientFromBundle bundle = do +sendBundle bundle = do env <- ask let msg = newMsg @@ -123,7 +125,7 @@ fedQueueClient :: ) => Payload tag -> FedQueueClient c () -fedQueueClient payload = fedQueueClientFromBundle =<< makeBundle @tag payload +fedQueueClient payload = sendBundle =<< makeBundle @tag payload -- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended -- to be used in test situations only. diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs new file mode 100644 index 00000000000..d855c2abb01 --- /dev/null +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs @@ -0,0 +1,29 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2023 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.API.Federation.API.Util where + +import Imports +import Wire.API.Federation.API.Galley.Notifications +import Wire.API.Federation.BackendNotifications +import Wire.API.Federation.Component + +makeConversationUpdateBundle :: + ConversationUpdate -> + FedQueueClient 'Galley (PayloadBundle 'Galley) +makeConversationUpdateBundle update = + (<>) <$> makeBundle update <*> makeBundle (conversationUpdateToV0 update) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index 744174091c5..c6c8a27561f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -27,7 +27,7 @@ class IsNotificationTag k where class HasNotificationEndpoint t where -- | The type of the payload for this endpoint - type Payload t :: Type + type Payload t = (p :: Type) | p -> t -- | The central path component of a notification endpoint, e.g., -- "on-conversation-updated". diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 7df9c193fc7..bf8fa429e5e 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -23,6 +23,7 @@ library Wire.API.Federation.API.Common Wire.API.Federation.API.Galley Wire.API.Federation.API.Galley.Notifications + Wire.API.Federation.API.Util Wire.API.Federation.BackendNotifications Wire.API.Federation.Client Wire.API.Federation.Component diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 2398929357c..51eec49ead5 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -898,7 +898,9 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do -- because quid's backend will update local state and notify its users -- itself using the ConversationUpdate returned by this function if notifyOrigDomain || tDomain ruids /= qDomain quid - then fedQueueClient @'OnConversationUpdatedTag update $> Nothing + then do + makeConversationUpdateBundle update >>= sendBundle + pure Nothing else pure (Just update) -- notify local participants and bots diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index b5781ecde71..4f77e38f01f 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -877,7 +877,7 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do joined r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> - fedQueueClient @'OnConversationUpdatedTag (convUpdateJoin z) + makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle either throw (void . pure) r where creator :: Maybe UserId From 532d05b29ccdd7fa9fecfe46b1bc04d013c18696 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 9 Feb 2024 17:04:25 +0100 Subject: [PATCH 31/52] Expose v0 notification endpoint --- .../Federation/API/Galley/Notifications.hs | 3 ++ .../API/Federation/BackendNotifications.hs | 9 ++--- .../src/Wire/API/Federation/Endpoint.hs | 38 +++++++++++++++---- .../API/Federation/HasNotificationEndpoint.hs | 21 +++++++++- services/galley/src/Galley/API/Federation.hs | 19 +++++++++- services/galley/src/Galley/API/Internal.hs | 5 ++- services/galley/test/integration/API.hs | 16 ++++---- .../galley/test/integration/API/Federation.hs | 26 +++++++------ services/galley/test/integration/API/MLS.hs | 4 +- .../galley/test/integration/API/MLS/Util.hs | 4 +- services/galley/test/integration/TestSetup.hs | 3 +- 11 files changed, 110 insertions(+), 38 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index e9fa6b9e91c..0a4eee272c8 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -74,11 +74,13 @@ instance HasNotificationEndpoint 'OnMLSMessageSentTag where instance HasNotificationEndpoint 'OnConversationUpdatedTagV0 where type Payload 'OnConversationUpdatedTagV0 = ConversationUpdateV0 type NotificationPath 'OnConversationUpdatedTagV0 = "on-conversation-updated" + type NotificationVersionTag 'OnConversationUpdatedTagV0 = 'Just 'V0 versionRange = rangeUntilVersion V1 instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" + type NotificationVersionTag 'OnConversationUpdatedTag = 'Just 'V1 versionRange = rangeFromVersion V1 instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where @@ -91,6 +93,7 @@ type GalleyNotificationAPI = NotificationFedEndpoint 'OnClientRemovedTag :<|> NotificationFedEndpoint 'OnMessageSentTag :<|> NotificationFedEndpoint 'OnMLSMessageSentTag + :<|> NotificationFedEndpoint 'OnConversationUpdatedTagV0 :<|> NotificationFedEndpoint 'OnConversationUpdatedTag :<|> NotificationFedEndpoint 'OnUserDeletedConversationsTag diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index c3d5666d063..74ac3bbd018 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -14,7 +14,6 @@ import Data.Map qualified as Map import Data.Schema import Data.Text qualified as Text import Data.Text.Lazy.Encoding qualified as TL -import GHC.TypeLits import Imports import Network.AMQP qualified as Q import Network.AMQP.Types qualified as Q @@ -63,7 +62,7 @@ instance ToSchema BackendNotification where -- RabbitMQ queue. fedNotifToBackendNotif :: forall {k} (tag :: k). - KnownSymbol (NotificationPath tag) => + HasFedPath tag => KnownComponent (NotificationComponent k) => A.ToJSON (Payload tag) => HasNotificationEndpoint tag => @@ -72,7 +71,7 @@ fedNotifToBackendNotif :: Payload tag -> BackendNotification fedNotifToBackendNotif rid ownDomain payload = - let p = Text.pack . symbolVal $ Proxy @(NotificationPath tag) + let p = Text.pack $ fedPath @tag b = RawJson . A.encode $ payload in toNotif p b where @@ -103,7 +102,7 @@ instance ToSchema (PayloadBundle c) where toBundle :: forall {k} (tag :: k). ( HasNotificationEndpoint tag, - KnownSymbol (NotificationPath tag), + HasFedPath tag, KnownComponent (NotificationComponent k), A.ToJSON (Payload tag) ) => @@ -119,7 +118,7 @@ toBundle reqId originDomain payload = makeBundle :: forall {k} (tag :: k) c. ( HasNotificationEndpoint tag, - KnownSymbol (NotificationPath tag), + HasFedPath tag, KnownComponent (NotificationComponent k), A.ToJSON (Payload tag), c ~ NotificationComponent k diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs index e656a3eda2f..82b90cc48f0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs @@ -23,6 +23,7 @@ where import Data.Kind import GHC.TypeLits +import Imports import Servant.API import Wire.API.ApplyMods import Wire.API.Federation.API.Common @@ -41,21 +42,29 @@ type instance FedPath (name :: Symbol) = name type instance FedPath (Versioned v name) = name +type UnnamedFedEndpointWithMods (mods :: [Type]) path input output = + ( ApplyMods + mods + (path :> OriginDomainHeader :> ReqBody '[JSON] input :> Post '[JSON] output) + ) + type FedEndpointWithMods (mods :: [Type]) name input output = Named name - ( ApplyMods - mods - (FedPath name :> OriginDomainHeader :> ReqBody '[JSON] input :> Post '[JSON] output) + ( UnnamedFedEndpointWithMods mods (FedPath name) input output ) -type NotificationFedEndpointWithMods (mods :: [Type]) name input = - FedEndpointWithMods mods name input EmptyResponse - type FedEndpoint name input output = FedEndpointWithMods '[] name input output +type NotificationFedEndpointWithMods (mods :: [Type]) name path input = + Named name (UnnamedFedEndpointWithMods mods path input EmptyResponse) + type NotificationFedEndpoint tag = - FedEndpoint (NotificationPath tag) (Payload tag) EmptyResponse + MkNotificationFedEndpoint + '[] + (NotificationPath tag) + (NotificationVersionTag tag) + (Payload tag) type StreamingFedEndpoint name input output = Named @@ -65,3 +74,18 @@ type StreamingFedEndpoint name input output = :> ReqBody '[JSON] input :> StreamPost NoFraming OctetStream output ) + +type family + MkNotificationFedEndpoint + (m :: [Type]) + (s :: Symbol) + (v :: Maybe k) + (p :: Type) + +type instance + MkNotificationFedEndpoint m s 'Nothing p = + NotificationFedEndpointWithMods m s s p + +type instance + MkNotificationFedEndpoint m s ('Just v) p = + NotificationFedEndpointWithMods m (Versioned v s) s p diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index c6c8a27561f..c925cd5abda 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -15,10 +15,18 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Wire.API.Federation.HasNotificationEndpoint where +module Wire.API.Federation.HasNotificationEndpoint + ( IsNotificationTag (..), + HasNotificationEndpoint (..), + HasFedPath, + fedPath, + ) +where import Data.Kind +import Data.Proxy import GHC.TypeLits +import Imports import Wire.API.Federation.Component import Wire.API.Federation.Version @@ -33,5 +41,16 @@ class HasNotificationEndpoint t where -- "on-conversation-updated". type NotificationPath t :: Symbol + -- | An optional version tag to distinguish different versions of the same + -- endpoint. + type NotificationVersionTag t :: Maybe Version + + type NotificationVersionTag t = 'Nothing + -- | The federation API version range this endpoint is supported in. versionRange :: VersionRange + +type HasFedPath t = KnownSymbol (NotificationPath t) + +fedPath :: forall t. HasFedPath t => String +fedPath = symbolVal (Proxy @(NotificationPath t)) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 071f846d27e..9f8e7084340 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -84,7 +84,9 @@ import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Common (EmptyResponse (..)) import Wire.API.Federation.API.Galley +import Wire.API.Federation.Endpoint import Wire.API.Federation.Error +import Wire.API.Federation.Version import Wire.API.MLS.Credential import Wire.API.MLS.GroupInfo import Wire.API.MLS.Serialisation @@ -119,7 +121,8 @@ federationSitemap = :<|> Named @"on-client-removed" onClientRemoved :<|> Named @"on-message-sent" onMessageSent :<|> Named @"on-mls-message-sent" onMLSMessageSent - :<|> Named @"on-conversation-updated" onConversationUpdated + :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 + :<|> Named @(Versioned 'V1 "on-conversation-updated") onConversationUpdated :<|> Named @"on-user-deleted-conversations" onUserDeleted onClientRemoved :: @@ -225,6 +228,20 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse +onConversationUpdatedV0 :: + ( Member BrigAccess r, + Member NotificationSubsystem r, + Member ExternalAccess r, + Member (Input (Local ())) r, + Member MemberStore r, + Member P.TinyLog r + ) => + Domain -> + ConversationUpdateV0 -> + Sem r EmptyResponse +onConversationUpdatedV0 domain cu = + onConversationUpdated domain (conversationUpdateFromV0 cu) + -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: ( Member BackendNotificationQueueAccess r, diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index d66f5f86a9d..fe82a00480d 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -91,7 +91,9 @@ import Wire.API.Event.Conversation import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.Endpoint import Wire.API.Federation.Error +import Wire.API.Federation.Version import Wire.API.Provider.Service hiding (Service) import Wire.API.Routes.API import Wire.API.Routes.Internal.Galley @@ -417,7 +419,8 @@ rmUser lusr conn = do alreadyPresentUsers = tUnqualified remotes, action = SomeConversationAction (sing @'ConversationLeaveTag) () } - let rpc = fedClient @'Galley @"on-conversation-updated" convUpdate + -- TODO: use notification + let rpc = fedClient @'Galley @(Versioned 'V1 "on-conversation-updated") convUpdate runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 94dcaa803de..7a9bd5acb9e 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -108,6 +108,8 @@ import Wire.API.Team.Member qualified as Teams import Wire.API.User import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) +import qualified Wire.API.Federation.Endpoint as F +import qualified Wire.API.Federation.Version as F tests :: IO TestSetup -> TestTree tests s = @@ -1873,7 +1875,7 @@ paginateConvListIds = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1889,7 +1891,7 @@ paginateConvListIds = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient deeDomain cu -- 1 Proteus self conv + 1 MLS self conv + 2 convs with bob and eve + 196 -- local convs + 25 convs on chad.example.com + 31 on dee.example = 256 convs. @@ -1934,7 +1936,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1952,7 +1954,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient deeDomain cu foldM_ (getChunkedConvs 16 0 alice) Nothing [4, 3, 2, 1, 0 :: Int] @@ -3211,7 +3213,7 @@ putRemoteConvMemberOk update = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cu -- Expected member state let memberAlice = @@ -3356,7 +3358,7 @@ putRemoteReceiptModeOk = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireAdmin) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAlice + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAddAlice -- add another user adam as member qadam <- randomQualifiedUser @@ -3371,7 +3373,7 @@ putRemoteReceiptModeOk = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qadam) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAdam + void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAddAdam let newReceiptMode = ReceiptMode 42 let action = ConversationReceiptModeUpdate newReceiptMode diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index 0badb2f79c3..a5c078e7ff9 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -58,6 +58,8 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as FedGalley import Wire.API.Federation.Component +import Wire.API.Federation.Endpoint +import Wire.API.Federation.Version import Wire.API.Internal.Notification import Wire.API.Message import Wire.API.Routes.Internal.Galley.ConversationsIntra @@ -249,7 +251,7 @@ addLocalUser = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qalice :| [qdee]) roleNameWireMember) } WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember @@ -303,7 +305,7 @@ addUnconnectedUsersOnly = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qCharlie :| []) roleNameWireMember) } -- Alice receives no notifications from this - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cu WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: @@ -348,9 +350,9 @@ removeLocalUser = do connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAdd + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAdd afterAddition <- listRemoteConvs remoteDomain alice - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuRemove + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cuRemove liftIO $ do void . WS.assertMatch (3 # Second) ws $ wsAssertMemberJoinWithRole qconv qBob [qAlice] roleNameWireMember @@ -413,21 +415,21 @@ removeRemoteUser = do } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qEve) + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qEve) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qEve] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qDee) + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qDee) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qDee] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qFlo) + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qFlo) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA] $ wsAssertMembersLeave qconv qBob [qFlo] @@ -464,7 +466,7 @@ notifyUpdate extras action etype edata = do FedGalley.action = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -509,7 +511,7 @@ notifyUpdateUnavailable extras action etype edata = do ((), _fedRequests) <- withTempMockFederator' (throw $ MockErrorResponse Http.status500 "Down for maintenance") $ void $ - runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -641,7 +643,7 @@ notifyDeletedConversation = do FedGalley.alreadyPresentUsers = [alice], FedGalley.action = SomeConversationAction (sing @'ConversationDeleteTag) () } - void $ runFedClient @"on-conversation-updated" fedGalleyClient bobDomain cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bobDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsAlice $ \n -> do @@ -699,7 +701,7 @@ addRemoteUser = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qdee :| [qeve, qflo]) roleNameWireMember) } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu void . liftIO $ do WS.assertMatchN_ (5 # Second) [wsA, wsD] $ wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember @@ -781,7 +783,7 @@ onMessageSent = do FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu let txt = "Hello from another backend" msg client = Map.fromList [(client, txt)] diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index d998d891fc7..7754db14f39 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -65,6 +65,8 @@ import Wire.API.MLS.SubConversation import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version +import Wire.API.Federation.Endpoint +import qualified Wire.API.Federation.Version as F tests :: IO TestSetup -> TestTree tests s = @@ -887,7 +889,7 @@ testRemoteToRemoteInSub = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu + void $ runFedClient @(Versioned 'F.V1 "on-conversation-updated") fedGalleyClient bdom cu let txt = "Hello from another backend" rcpts = Map.fromList [(alice, aliceC1 :| [aliceC2]), (eve, eveC :| [])] diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index d979556e596..3a88350c81d 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -72,6 +72,8 @@ import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role (roleNameWireMember) import Wire.API.Event.Conversation import Wire.API.Federation.API.Galley +import Wire.API.Federation.Endpoint +import Wire.API.Federation.Version import Wire.API.MLS.CipherSuite (SignatureSchemeTag (Ed25519)) import Wire.API.MLS.CommitBundle import Wire.API.MLS.Credential @@ -979,7 +981,7 @@ receiveOnConvUpdated conv origUser joiner = do } void $ runFedClient - @"on-conversation-updated" + @(Versioned 'V1 "on-conversation-updated") client (qDomain conv) cu diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 2cdb594af24..d4d8c7151b0 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -55,7 +55,6 @@ import Data.ByteString.Conversion import Data.Domain import Data.Proxy import Data.Text qualified as Text -import GHC.TypeLits import Galley.Aws qualified as Aws import Galley.Options (Opts) import Imports @@ -141,7 +140,7 @@ instance VersionedMonad v ClientM where guardVersion _ = pure () runFedClient :: - forall (name :: Symbol) comp m api. + forall name comp m api. ( HasUnsafeFedEndpoint comp api name, Servant.HasClient Servant.ClientM api, MonadIO m, From 75bd0e91fec1b5144df180dc511f973c08d6c1e7 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 12 Feb 2024 15:11:35 +0100 Subject: [PATCH 32/52] Fatal logs for version mismatch in pusher --- .../background-worker/src/Wire/BackendNotificationPusher.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 583ef5f97c8..b9f8cfe4487 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -149,8 +149,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi case mostRecentTuple bodyVersions (notifications bundle) remoteVersions of Nothing -> - -- TODO(md): do more severe logging warning the site operator - Log.err $ + Log.fatal $ Log.msg (Log.val "No federation API version in common, the notification will be ignored") . Log.field "domain" (domainText targetDomain) Just (notif, Just -> cveVersion) -> do From d629922f266ae24d7ad200d63517e64d26b1e967 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 13 Feb 2024 10:19:23 +0100 Subject: [PATCH 33/52] Add TODOs --- .../src/Wire/API/Federation/BackendNotifications.hs | 1 + services/background-worker/src/Wire/BackendNotificationPusher.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 74ac3bbd018..a6bb01a08e0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -134,6 +134,7 @@ type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> sendNotification :: FederatorClientVersionedEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ()) sendNotification env component path body = + -- TODO: use singletons case component of Brig -> go @'Brig Galley -> go @'Galley diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index b9f8cfe4487..dc541bb8c74 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -134,6 +134,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications } -- TODO(md): pull this out into a separate function for redability and testability + -- TODO: this asks API versions twice remoteVersions :: Set Int <- liftIO ( runFederatorClient @'Brig env $ From 6d9ac818fe972ae0a78db944bdd75a51278de03c Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 13 Feb 2024 10:52:16 +0100 Subject: [PATCH 34/52] Add notification mods and generate version ranges --- .../src/Wire/API/Federation/API.hs | 3 +- .../API/Federation/API/Brig/Notifications.hs | 2 - .../Federation/API/Galley/Notifications.hs | 9 ++--- .../API/Federation/BackendNotifications.hs | 17 ++++---- .../src/Wire/API/Federation/Endpoint.hs | 2 +- .../API/Federation/HasNotificationEndpoint.hs | 40 ++++++++++++++++++- .../src/Wire/API/Federation/Version.hs | 37 +++++++++++++---- .../Test/Wire/API/Federation/VersionSpec.hs | 8 ++-- 8 files changed, 86 insertions(+), 32 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API.hs b/libs/wire-api-federation/src/Wire/API/Federation/API.hs index 5cbecac19d8..053275577e3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -118,7 +118,8 @@ sendBundle bundle = do fedQueueClient :: forall {k} (tag :: k) c. ( HasNotificationEndpoint tag, - KnownSymbol (NotificationPath tag), + HasVersionRange tag, + HasFedPath tag, KnownComponent (NotificationComponent k), ToJSON (Payload tag), c ~ NotificationComponent k diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs index 2018d9ed88e..931febcf4b6 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig/Notifications.hs @@ -25,7 +25,6 @@ import Imports import Wire.API.Federation.Component import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint -import Wire.API.Federation.Version import Wire.API.Util.Aeson import Wire.Arbitrary @@ -50,7 +49,6 @@ instance IsNotificationTag BrigNotificationTag where instance HasNotificationEndpoint 'OnUserDeletedConnectionsTag where type Payload 'OnUserDeletedConnectionsTag = UserDeletedConnectionsNotification type NotificationPath 'OnUserDeletedConnectionsTag = "on-user-deleted-connections" - versionRange = allVersions instance ToSchema UserDeletedConnectionsNotification diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index 0a4eee272c8..9d5adfb1604 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -37,6 +37,7 @@ import Wire.API.Federation.HasNotificationEndpoint import Wire.API.Federation.Version import Wire.API.MLS.SubConversation import Wire.API.Message +import Wire.API.Routes.Version (From, Until) import Wire.API.Util.Aeson import Wire.Arbitrary @@ -55,19 +56,16 @@ instance IsNotificationTag GalleyNotificationTag where instance HasNotificationEndpoint 'OnClientRemovedTag where type Payload 'OnClientRemovedTag = ClientRemovedRequest type NotificationPath 'OnClientRemovedTag = "on-client-removed" - versionRange = allVersions -- used to notify this backend that a new message has been posted to a -- remote conversation instance HasNotificationEndpoint 'OnMessageSentTag where type Payload 'OnMessageSentTag = RemoteMessage ConvId type NotificationPath 'OnMessageSentTag = "on-message-sent" - versionRange = allVersions instance HasNotificationEndpoint 'OnMLSMessageSentTag where type Payload 'OnMLSMessageSentTag = RemoteMLSMessage type NotificationPath 'OnMLSMessageSentTag = "on-mls-message-sent" - versionRange = allVersions -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation @@ -75,18 +73,17 @@ instance HasNotificationEndpoint 'OnConversationUpdatedTagV0 where type Payload 'OnConversationUpdatedTagV0 = ConversationUpdateV0 type NotificationPath 'OnConversationUpdatedTagV0 = "on-conversation-updated" type NotificationVersionTag 'OnConversationUpdatedTagV0 = 'Just 'V0 - versionRange = rangeUntilVersion V1 + type NotificationMods 'OnConversationUpdatedTagV0 = '[Until 'V1] instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" type NotificationVersionTag 'OnConversationUpdatedTag = 'Just 'V1 - versionRange = rangeFromVersion V1 + type NotificationMods 'OnConversationUpdatedTag = '[From 'V1] instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification type NotificationPath 'OnUserDeletedConversationsTag = "on-user-deleted-conversations" - versionRange = allVersions -- | All the notification endpoints return an 'EmptyResponse'. type GalleyNotificationAPI = diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index a6bb01a08e0..1b6fc7e23d4 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -62,10 +62,11 @@ instance ToSchema BackendNotification where -- RabbitMQ queue. fedNotifToBackendNotif :: forall {k} (tag :: k). - HasFedPath tag => - KnownComponent (NotificationComponent k) => - A.ToJSON (Payload tag) => - HasNotificationEndpoint tag => + ( HasFedPath tag, + HasVersionRange tag, + KnownComponent (NotificationComponent k), + A.ToJSON (Payload tag) + ) => RequestId -> Domain -> Payload tag -> @@ -101,8 +102,8 @@ instance ToSchema (PayloadBundle c) where toBundle :: forall {k} (tag :: k). - ( HasNotificationEndpoint tag, - HasFedPath tag, + ( HasFedPath tag, + HasVersionRange tag, KnownComponent (NotificationComponent k), A.ToJSON (Payload tag) ) => @@ -117,8 +118,8 @@ toBundle reqId originDomain payload = makeBundle :: forall {k} (tag :: k) c. - ( HasNotificationEndpoint tag, - HasFedPath tag, + ( HasFedPath tag, + HasVersionRange tag, KnownComponent (NotificationComponent k), A.ToJSON (Payload tag), c ~ NotificationComponent k diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs index 82b90cc48f0..f24085139cb 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs @@ -61,7 +61,7 @@ type NotificationFedEndpointWithMods (mods :: [Type]) name path input = type NotificationFedEndpoint tag = MkNotificationFedEndpoint - '[] + (NotificationMods tag) (NotificationPath tag) (NotificationVersionTag tag) (Payload tag) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs index c925cd5abda..7fba640ee90 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -19,16 +19,20 @@ module Wire.API.Federation.HasNotificationEndpoint ( IsNotificationTag (..), HasNotificationEndpoint (..), HasFedPath, + HasVersionRange, fedPath, + versionRange, ) where import Data.Kind import Data.Proxy +import Data.Singletons import GHC.TypeLits import Imports import Wire.API.Federation.Component import Wire.API.Federation.Version +import Wire.API.Routes.Version (From, Until) class IsNotificationTag k where type NotificationComponent k = (c :: Component) | c -> k @@ -47,10 +51,42 @@ class HasNotificationEndpoint t where type NotificationVersionTag t = 'Nothing - -- | The federation API version range this endpoint is supported in. - versionRange :: VersionRange + type NotificationMods t :: [Type] + + type NotificationMods t = '[] type HasFedPath t = KnownSymbol (NotificationPath t) +type HasVersionRange t = MkVersionRange (NotificationMods t) + fedPath :: forall t. HasFedPath t => String fedPath = symbolVal (Proxy @(NotificationPath t)) + +-- | Build a version range using any 'Until' and 'From' combinators present in +-- the endpoint modifiers. +class MkVersionRange mods where + mkVersionRange :: VersionRange + +instance MkVersionRange '[] where + mkVersionRange = allVersions + +instance + {-# OVERLAPPING #-} + (MkVersionRange mods, SingI v) => + MkVersionRange (From (v :: Version) ': mods) + where + mkVersionRange = mkVersionRange @mods <> rangeFromVersion (demote @v) + +instance + {-# OVERLAPPING #-} + (MkVersionRange mods, SingI v) => + MkVersionRange (Until (v :: Version) ': mods) + where + mkVersionRange = mkVersionRange @mods <> rangeUntilVersion (demote @v) + +instance {-# OVERLAPPABLE #-} MkVersionRange mods => MkVersionRange (m ': mods) where + mkVersionRange = mkVersionRange @mods + +-- | The federation API version range this endpoint is supported in. +versionRange :: forall t. HasVersionRange t => VersionRange +versionRange = mkVersionRange @(NotificationMods t) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index e6b60ec2e96..25cc9925f5e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -28,6 +28,7 @@ module Wire.API.Federation.Version versionInfo, -- * VersionRange + VersionUpperBound (..), VersionRange (..), fromVersion, toVersionExcl, @@ -92,10 +93,24 @@ versionInfo = VersionInfo (toList supportedVersions) ---------------------------------------------------------------------- +-- | The upper bound of a version range. +-- +-- The order of constructors here makes the 'Unbounded' value maximum in the +-- generated lexicographic ordering. +data VersionUpperBound = VersionUpperBound Version | Unbounded + deriving (Eq, Ord, Show) + +versionFromUpperBound :: VersionUpperBound -> Maybe Version +versionFromUpperBound (VersionUpperBound v) = Just v +versionFromUpperBound Unbounded = Nothing + +versionToUpperBound :: Maybe Version -> VersionUpperBound +versionToUpperBound (Just v) = VersionUpperBound v +versionToUpperBound Nothing = Unbounded + data VersionRange = VersionRange { _fromVersion :: Version, - -- | 'Nothing' here means that 'maxBound' is included. - _toVersionExcl :: Maybe Version + _toVersionExcl :: VersionUpperBound } deriving instance Eq VersionRange @@ -111,7 +126,8 @@ instance ToSchema VersionRange where object "VersionRange" $ VersionRange <$> _fromVersion .= field "from" schema - <*> _toVersionExcl .= maybe_ (optFieldWithDocModifier "until_excl" desc schema) + <*> (versionFromUpperBound . _toVersionExcl) + .= maybe_ (versionToUpperBound <$> optFieldWithDocModifier "until_excl" desc schema) where desc = description ?~ "exlusive upper version bound" @@ -120,19 +136,24 @@ deriving via Schema VersionRange instance ToJSON VersionRange deriving via Schema VersionRange instance FromJSON VersionRange allVersions :: VersionRange -allVersions = VersionRange minBound Nothing +allVersions = VersionRange minBound Unbounded + +-- | The semigroup instance of VersionRange is intersection. +instance Semigroup VersionRange where + VersionRange from1 to1 <> VersionRange from2 to2 = + VersionRange (max from1 from2) (min to1 to2) rangeFromVersion :: Version -> VersionRange -rangeFromVersion v = VersionRange v Nothing +rangeFromVersion v = VersionRange v Unbounded rangeUntilVersion :: Version -> VersionRange -rangeUntilVersion v = VersionRange minBound (Just v) +rangeUntilVersion v = VersionRange minBound (VersionUpperBound v) enumVersionRange :: VersionRange -> Set Version enumVersionRange = Set.fromList . \case - (VersionRange l Nothing) -> [l ..] - (VersionRange l (Just u)) -> init [l .. u] + VersionRange l Unbounded -> [l ..] + VersionRange l (VersionUpperBound u) -> init [l .. u] -- | For a version range of a local backend and for a set of versions that a -- remote backend supports, compute the newest version supported by both. The diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs index 859ebccca1d..386b88825de 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs @@ -31,10 +31,10 @@ spec = do it "[..] + [] = null" $ do mostRecent (pure allVersions) (Set.fromList []) `shouldBe` Nothing it "[0] + [1] = null" $ do - mostRecent (pure $ VersionRange V0 (Just V1)) (Set.fromList []) `shouldBe` Nothing + mostRecent (pure $ VersionRange V0 (VersionUpperBound V1)) (Set.fromList []) `shouldBe` Nothing it "[1] + [0, 1] = 1" $ do - fmap snd (mostRecent (pure $ VersionRange V1 Nothing) (Set.fromList [0, 1])) `shouldBe` Just V1 + fmap snd (mostRecent (pure $ VersionRange V1 Unbounded) (Set.fromList [0, 1])) `shouldBe` Just V1 it "[0] + [0, 1] = 0" $ do - fmap snd (mostRecent (pure $ VersionRange V0 (Just V1)) (Set.fromList [0, 1])) `shouldBe` Just V0 + fmap snd (mostRecent (pure $ VersionRange V0 (VersionUpperBound V1)) (Set.fromList [0, 1])) `shouldBe` Just V0 it "[..] + [1] = 1" $ do - fmap snd (mostRecent (VersionRange V0 (Just V1) :| [VersionRange V1 Nothing]) (Set.fromList [1])) `shouldBe` Just V1 + fmap snd (mostRecent (VersionRange V0 (VersionUpperBound V1) :| [VersionRange V1 Unbounded]) (Set.fromList [1])) `shouldBe` Just V1 From 2cf8c8620bc20c3a7fd5088bbe1f97badbf6b538 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 13 Feb 2024 11:08:49 +0100 Subject: [PATCH 35/52] Use existential to lift components to type level --- .../src/Wire/API/Federation/BackendNotifications.hs | 12 ++++-------- .../src/Wire/API/Federation/Component.hs | 9 +++++++++ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 1b6fc7e23d4..06893daed63 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -134,19 +134,15 @@ makeBundle payload = do type BackendNotificationAPI = Capture "name" Text :> ReqBody '[JSON] RawJson :> Post '[JSON] EmptyResponse sendNotification :: FederatorClientVersionedEnv -> Component -> Text -> RawJson -> IO (Either FederatorClientError ()) -sendNotification env component path body = - -- TODO: use singletons - case component of - Brig -> go @'Brig - Galley -> go @'Galley - Cargohold -> go @'Cargohold +sendNotification env component path body = case someComponent component of + SomeComponent p -> go p where withoutFirstSlash :: Text -> Text withoutFirstSlash (Text.stripPrefix "/" -> Just t) = t withoutFirstSlash t = t - go :: forall c. (KnownComponent c) => IO (Either FederatorClientError ()) - go = + go :: forall c. KnownComponent c => Proxy c -> IO (Either FederatorClientError ()) + go _ = lowerCodensity . runExceptT . runVersionedFederatorClientToCodensity env diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs index 73595904f7c..1a5b91e6bd3 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Component.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Component.hs @@ -21,6 +21,7 @@ module Wire.API.Federation.Component ) where +import Data.Proxy import Imports import Wire.API.MakesFederatedCall (Component (..)) @@ -46,3 +47,11 @@ instance KnownComponent 'Galley where instance KnownComponent 'Cargohold where componentVal = Cargohold + +data SomeComponent where + SomeComponent :: KnownComponent c => Proxy c -> SomeComponent + +someComponent :: Component -> SomeComponent +someComponent Brig = SomeComponent (Proxy @'Brig) +someComponent Galley = SomeComponent (Proxy @'Galley) +someComponent Cargohold = SomeComponent (Proxy @'Cargohold) From 126f18cc9964d18cdaa7519ec9a5a278cea5aaa2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 13 Feb 2024 13:30:46 +0100 Subject: [PATCH 36/52] Skip negotiation when fetching remote versions --- .../src/Wire/API/Federation/Client.hs | 14 ++++++++++++++ .../src/Wire/BackendNotificationPusher.hs | 6 ++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 44001ef0bd0..3fc876335f7 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -21,8 +21,10 @@ module Wire.API.Federation.Client ( FederatorClientEnv (..), FederatorClientVersionedEnv (..), + unversionedEnv, FederatorClient, runFederatorClient, + runVersionedFederatorClient, runFederatorClientToCodensity, runVersionedFederatorClientToCodensity, performHTTP2Request, @@ -85,6 +87,9 @@ data FederatorClientVersionedEnv = FederatorClientVersionedEnv cveVersion :: Maybe Version } +unversionedEnv :: FederatorClientEnv -> FederatorClientVersionedEnv +unversionedEnv env = FederatorClientVersionedEnv env Nothing + -- | A request to a remote backend. The API version of the remote backend is in -- the environment. The 'MaybeT' layer is used to match endpoint versions (via -- the 'Alternative' and 'VersionedMonad' instances). @@ -306,6 +311,15 @@ runFederatorClient env = lowerCodensity . runFederatorClientToCodensity env +runVersionedFederatorClient :: + FederatorClientVersionedEnv -> + FederatorClient c a -> + IO (Either FederatorClientError a) +runVersionedFederatorClient venv = + lowerCodensity + . runExceptT + . runVersionedFederatorClientToCodensity venv + runFederatorClientToCodensity :: forall c a. FederatorClientEnv -> diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index dc541bb8c74..36ded2f1a6e 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -134,10 +134,12 @@ pushNotification runningFlag targetDomain (msg, envelope) = do fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications } -- TODO(md): pull this out into a separate function for redability and testability - -- TODO: this asks API versions twice remoteVersions :: Set Int <- liftIO - ( runFederatorClient @'Brig env $ + -- use versioned client with no version set: since we are manually + -- performing version negotiation, we don't want the client to + -- negotiate a version for us + ( runVersionedFederatorClient @'Brig (unversionedEnv env) $ fedClientIn @'Brig @"api-version" () ) >>= \case From 914f54e71f7a3258f53fdd67cae60e6805bc84ee Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 14 Feb 2024 16:27:34 +0100 Subject: [PATCH 37/52] Move notification change to V2 --- .../Federation/API/Galley/Notifications.hs | 35 +++++++++---------- .../src/Wire/API/Federation/API/Util.hs | 2 +- .../src/Wire/API/Federation/Version.hs | 7 ++-- services/galley/src/Galley/API/Federation.hs | 12 +++---- services/galley/src/Galley/API/Internal.hs | 4 +-- services/galley/test/integration/API.hs | 16 ++++----- .../galley/test/integration/API/Federation.hs | 26 +++++++------- services/galley/test/integration/API/MLS.hs | 4 +-- .../galley/test/integration/API/MLS/Util.hs | 4 +-- 9 files changed, 51 insertions(+), 59 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index 9d5adfb1604..3a432852fbb 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -45,7 +45,7 @@ data GalleyNotificationTag = OnClientRemovedTag | OnMessageSentTag | OnMLSMessageSentTag - | OnConversationUpdatedTagV0 + | OnConversationUpdatedTagV1 | OnConversationUpdatedTag | OnUserDeletedConversationsTag deriving (Show, Eq, Generic, Bounded, Enum) @@ -69,17 +69,16 @@ instance HasNotificationEndpoint 'OnMLSMessageSentTag where -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation -instance HasNotificationEndpoint 'OnConversationUpdatedTagV0 where - type Payload 'OnConversationUpdatedTagV0 = ConversationUpdateV0 - type NotificationPath 'OnConversationUpdatedTagV0 = "on-conversation-updated" - type NotificationVersionTag 'OnConversationUpdatedTagV0 = 'Just 'V0 - type NotificationMods 'OnConversationUpdatedTagV0 = '[Until 'V1] +instance HasNotificationEndpoint 'OnConversationUpdatedTagV1 where + type Payload 'OnConversationUpdatedTagV1 = ConversationUpdateV1 + type NotificationPath 'OnConversationUpdatedTagV1 = "on-conversation-updated" + type NotificationVersionTag 'OnConversationUpdatedTagV1 = 'Just 'V1 + type NotificationMods 'OnConversationUpdatedTagV1 = '[Until 'V2] instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" - type NotificationVersionTag 'OnConversationUpdatedTag = 'Just 'V1 - type NotificationMods 'OnConversationUpdatedTag = '[From 'V1] + type NotificationMods 'OnConversationUpdatedTag = '[From 'V2] instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification @@ -90,7 +89,7 @@ type GalleyNotificationAPI = NotificationFedEndpoint 'OnClientRemovedTag :<|> NotificationFedEndpoint 'OnMessageSentTag :<|> NotificationFedEndpoint 'OnMLSMessageSentTag - :<|> NotificationFedEndpoint 'OnConversationUpdatedTagV0 + :<|> NotificationFedEndpoint 'OnConversationUpdatedTagV1 :<|> NotificationFedEndpoint 'OnConversationUpdatedTag :<|> NotificationFedEndpoint 'OnUserDeletedConversationsTag @@ -141,7 +140,7 @@ data RemoteMLSMessage = RemoteMLSMessage instance ToSchema RemoteMLSMessage -data ConversationUpdateV0 = ConversationUpdateV0 +data ConversationUpdateV1 = ConversationUpdateV1 { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, -- | The unqualified ID of the conversation where the update is happening. @@ -159,11 +158,11 @@ data ConversationUpdateV0 = ConversationUpdateV0 } deriving (Eq, Show, Generic) -instance ToJSON ConversationUpdateV0 +instance ToJSON ConversationUpdateV1 -instance FromJSON ConversationUpdateV0 +instance FromJSON ConversationUpdateV1 -instance ToSchema ConversationUpdateV0 +instance ToSchema ConversationUpdateV1 data ConversationUpdate = ConversationUpdate { time :: UTCTime, @@ -189,9 +188,9 @@ instance FromJSON ConversationUpdate instance ToSchema ConversationUpdate -conversationUpdateToV0 :: ConversationUpdate -> ConversationUpdateV0 -conversationUpdateToV0 cu = - ConversationUpdateV0 +conversationUpdateToV1 :: ConversationUpdate -> ConversationUpdateV1 +conversationUpdateToV1 cu = + ConversationUpdateV1 { cuTime = cu.time, cuOrigUserId = cu.origUserId, cuConvId = cu.convId, @@ -199,8 +198,8 @@ conversationUpdateToV0 cu = cuAction = cu.action } -conversationUpdateFromV0 :: ConversationUpdateV0 -> ConversationUpdate -conversationUpdateFromV0 cu = +conversationUpdateFromV1 :: ConversationUpdateV1 -> ConversationUpdate +conversationUpdateFromV1 cu = ConversationUpdate { time = cu.cuTime, origUserId = cu.cuOrigUserId, diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs index d855c2abb01..e095682ee61 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs @@ -26,4 +26,4 @@ makeConversationUpdateBundle :: ConversationUpdate -> FedQueueClient 'Galley (PayloadBundle 'Galley) makeConversationUpdateBundle update = - (<>) <$> makeBundle update <*> makeBundle (conversationUpdateToV0 update) + (<>) <$> makeBundle update <*> makeBundle (conversationUpdateToV1 update) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 25cc9925f5e..91e133dc0c8 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -22,6 +22,7 @@ module Wire.API.Federation.Version Version (..), V0Sym0, V1Sym0, + V2Sym0, versionInt, supportedVersions, VersionInfo (..), @@ -50,13 +51,14 @@ import Data.Singletons.Base.TH import Imports import Wire.API.VersionInfo -data Version = V0 | V1 +data Version = V0 | V1 | V2 deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (FromJSON, ToJSON) via (Schema Version) versionInt :: Version -> Int versionInt V0 = 0 versionInt V1 = 1 +versionInt V2 = 2 intToVersion :: Int -> Maybe Version intToVersion intV = find (\v -> versionInt v == intV) [minBound ..] @@ -65,7 +67,8 @@ instance ToSchema Version where schema = enum @Integer "Version" . mconcat $ [ element 0 V0, - element 1 V1 + element 1 V1, + element 2 V2 ] supportedVersions :: Set Version diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 9f8e7084340..6d0e0bd79c7 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -121,8 +121,8 @@ federationSitemap = :<|> Named @"on-client-removed" onClientRemoved :<|> Named @"on-message-sent" onMessageSent :<|> Named @"on-mls-message-sent" onMLSMessageSent - :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 - :<|> Named @(Versioned 'V1 "on-conversation-updated") onConversationUpdated + :<|> Named @(Versioned 'V1 "on-conversation-updated") onConversationUpdatedV1 + :<|> Named @"on-conversation-updated" onConversationUpdated :<|> Named @"on-user-deleted-conversations" onUserDeleted onClientRemoved :: @@ -228,7 +228,7 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse -onConversationUpdatedV0 :: +onConversationUpdatedV1 :: ( Member BrigAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -237,10 +237,10 @@ onConversationUpdatedV0 :: Member P.TinyLog r ) => Domain -> - ConversationUpdateV0 -> + ConversationUpdateV1 -> Sem r EmptyResponse -onConversationUpdatedV0 domain cu = - onConversationUpdated domain (conversationUpdateFromV0 cu) +onConversationUpdatedV1 domain cu = + onConversationUpdated domain (conversationUpdateFromV1 cu) -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index fe82a00480d..11251ee3b5c 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -91,9 +91,7 @@ import Wire.API.Event.Conversation import Wire.API.Event.LeaveReason import Wire.API.Federation.API import Wire.API.Federation.API.Galley -import Wire.API.Federation.Endpoint import Wire.API.Federation.Error -import Wire.API.Federation.Version import Wire.API.Provider.Service hiding (Service) import Wire.API.Routes.API import Wire.API.Routes.Internal.Galley @@ -420,7 +418,7 @@ rmUser lusr conn = do action = SomeConversationAction (sing @'ConversationLeaveTag) () } -- TODO: use notification - let rpc = fedClient @'Galley @(Versioned 'V1 "on-conversation-updated") convUpdate + let rpc = fedClient @'Galley @"on-conversation-updated" convUpdate runFederatedEither remotes rpc >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 7a9bd5acb9e..94dcaa803de 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -108,8 +108,6 @@ import Wire.API.Team.Member qualified as Teams import Wire.API.User import Wire.API.User.Client import Wire.API.UserMap (UserMap (..)) -import qualified Wire.API.Federation.Endpoint as F -import qualified Wire.API.Federation.Version as F tests :: IO TestSetup -> TestTree tests s = @@ -1875,7 +1873,7 @@ paginateConvListIds = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient chadDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1891,7 +1889,7 @@ paginateConvListIds = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient deeDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu -- 1 Proteus self conv + 1 MLS self conv + 2 convs with bob and eve + 196 -- local convs + 25 convs on chad.example.com + 31 on dee.example = 256 convs. @@ -1936,7 +1934,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient chadDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient chadDomain cu remoteDee <- randomId let deeDomain = Domain "dee.example.com" @@ -1954,7 +1952,7 @@ paginateConvListIdsPageEndingAtLocalsAndDomain = do alreadyPresentUsers = [], action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qAlice) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient deeDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient deeDomain cu foldM_ (getChunkedConvs 16 0 alice) Nothing [4, 3, 2, 1, 0 :: Int] @@ -3213,7 +3211,7 @@ putRemoteConvMemberOk update = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu -- Expected member state let memberAlice = @@ -3358,7 +3356,7 @@ putRemoteReceiptModeOk = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireAdmin) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAddAlice + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAlice -- add another user adam as member qadam <- randomQualifiedUser @@ -3373,7 +3371,7 @@ putRemoteReceiptModeOk = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qadam) roleNameWireMember) } - void $ runFedClient @(F.Versioned 'F.V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAddAdam + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAddAdam let newReceiptMode = ReceiptMode 42 let action = ConversationReceiptModeUpdate newReceiptMode diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index a5c078e7ff9..e6bd8eea883 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -58,8 +58,6 @@ import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Federation.API.Galley qualified as FedGalley import Wire.API.Federation.Component -import Wire.API.Federation.Endpoint -import Wire.API.Federation.Version import Wire.API.Internal.Notification import Wire.API.Message import Wire.API.Routes.Internal.Galley.ConversationsIntra @@ -251,7 +249,7 @@ addLocalUser = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qalice :| [qdee]) roleNameWireMember) } WS.bracketRN c [alice, charlie, dee] $ \[wsA, wsC, wsD] -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ wsAssertMemberJoinWithRole qconv qbob [qalice] roleNameWireMember @@ -305,7 +303,7 @@ addUnconnectedUsersOnly = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qCharlie :| []) roleNameWireMember) } -- Alice receives no notifications from this - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cu + void $ runFedClient @("on-conversation-updated") fedGalleyClient remoteDomain cu WS.assertNoEvent (5 # Second) [wsA] -- | This test invokes the federation endpoint: @@ -350,9 +348,9 @@ removeLocalUser = do connectWithRemoteUser alice qBob WS.bracketR c alice $ \ws -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cuAdd + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuAdd afterAddition <- listRemoteConvs remoteDomain alice - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain cuRemove + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain cuRemove liftIO $ do void . WS.assertMatch (3 # Second) ws $ wsAssertMemberJoinWithRole qconv qBob [qAlice] roleNameWireMember @@ -415,21 +413,21 @@ removeRemoteUser = do } WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qEve) + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qEve) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qEve] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qDee) + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qDee) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA, wsD] $ wsAssertMembersLeave qconv qBob [qDee] WS.assertNoEvent (1 # Second) [wsC, wsF] WS.bracketRN c [alice, charlie, dee, flo] $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient remoteDomain (cuRemove qFlo) + void $ runFedClient @"on-conversation-updated" fedGalleyClient remoteDomain (cuRemove qFlo) liftIO $ do WS.assertMatchN_ (3 # Second) [wsA] $ wsAssertMembersLeave qconv qBob [qFlo] @@ -466,7 +464,7 @@ notifyUpdate extras action etype edata = do FedGalley.action = action } WS.bracketR2 c alice charlie $ \(wsA, wsC) -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -511,7 +509,7 @@ notifyUpdateUnavailable extras action etype edata = do ((), _fedRequests) <- withTempMockFederator' (throw $ MockErrorResponse Http.status500 "Down for maintenance") $ void $ - runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu + runFedClient @"on-conversation-updated" fedGalleyClient bdom cu liftIO $ do WS.assertMatch_ (5 # Second) wsA $ \n -> do let e = List1.head (WS.unpackPayload n) @@ -643,7 +641,7 @@ notifyDeletedConversation = do FedGalley.alreadyPresentUsers = [alice], FedGalley.action = SomeConversationAction (sing @'ConversationDeleteTag) () } - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bobDomain cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient bobDomain cu liftIO $ do WS.assertMatch_ (5 # Second) wsAlice $ \n -> do @@ -701,7 +699,7 @@ addRemoteUser = do SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qdee :| [qeve, qflo]) roleNameWireMember) } WS.bracketRN c (map qUnqualified [qalice, qcharlie, qdee, qflo]) $ \[wsA, wsC, wsD, wsF] -> do - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu void . liftIO $ do WS.assertMatchN_ (5 # Second) [wsA, wsD] $ wsAssertMemberJoinWithRole qconv qbob [qeve, qdee] roleNameWireMember @@ -783,7 +781,7 @@ onMessageSent = do FedGalley.action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @(Versioned 'V1 "on-conversation-updated") fedGalleyClient bdom cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu let txt = "Hello from another backend" msg client = Map.fromList [(client, txt)] diff --git a/services/galley/test/integration/API/MLS.hs b/services/galley/test/integration/API/MLS.hs index 7754db14f39..d998d891fc7 100644 --- a/services/galley/test/integration/API/MLS.hs +++ b/services/galley/test/integration/API/MLS.hs @@ -65,8 +65,6 @@ import Wire.API.MLS.SubConversation import Wire.API.Message import Wire.API.Routes.MultiTablePaging import Wire.API.Routes.Version -import Wire.API.Federation.Endpoint -import qualified Wire.API.Federation.Version as F tests :: IO TestSetup -> TestTree tests s = @@ -889,7 +887,7 @@ testRemoteToRemoteInSub = do action = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (pure qalice) roleNameWireMember) } - void $ runFedClient @(Versioned 'F.V1 "on-conversation-updated") fedGalleyClient bdom cu + void $ runFedClient @"on-conversation-updated" fedGalleyClient bdom cu let txt = "Hello from another backend" rcpts = Map.fromList [(alice, aliceC1 :| [aliceC2]), (eve, eveC :| [])] diff --git a/services/galley/test/integration/API/MLS/Util.hs b/services/galley/test/integration/API/MLS/Util.hs index 3a88350c81d..d979556e596 100644 --- a/services/galley/test/integration/API/MLS/Util.hs +++ b/services/galley/test/integration/API/MLS/Util.hs @@ -72,8 +72,6 @@ import Wire.API.Conversation.Protocol import Wire.API.Conversation.Role (roleNameWireMember) import Wire.API.Event.Conversation import Wire.API.Federation.API.Galley -import Wire.API.Federation.Endpoint -import Wire.API.Federation.Version import Wire.API.MLS.CipherSuite (SignatureSchemeTag (Ed25519)) import Wire.API.MLS.CommitBundle import Wire.API.MLS.Credential @@ -981,7 +979,7 @@ receiveOnConvUpdated conv origUser joiner = do } void $ runFedClient - @(Versioned 'V1 "on-conversation-updated") + @"on-conversation-updated" client (qDomain conv) cu From 68a2060096c3d8fdd59833e60bab699365f3b0bc Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 14 Feb 2024 16:54:02 +0100 Subject: [PATCH 38/52] Test conversation update on V0 --- deploy/dockerephemeral/federation-v0.yaml | 2 ++ integration/test/Test/Conversation.hs | 14 ++++++++++++++ integration/test/Testlib/Env.hs | 4 ++++ .../src/Wire/BackendNotificationPusher.hs | 1 + 4 files changed, 21 insertions(+) diff --git a/deploy/dockerephemeral/federation-v0.yaml b/deploy/dockerephemeral/federation-v0.yaml index 1342056cac5..8ed1179b048 100644 --- a/deploy/dockerephemeral/federation-v0.yaml +++ b/deploy/dockerephemeral/federation-v0.yaml @@ -182,6 +182,8 @@ services: networks: - demo_wire - coredns + extra_hosts: + - "host.docker.internal.:host-gateway" ports: - '127.0.0.1:21097:8080' - '127.0.0.1:21098:8081' diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index 9ff4641bbcc..b10668554d0 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -850,3 +850,17 @@ testGuestLinksExpired = do liftIO $ threadDelay (1_100_000) bindResponse (getJoinCodeConv tm k v) $ \resp -> do resp.status `shouldMatchInt` 404 + +testConversationWithV0 :: HasCallStack => App () +testConversationWithV0 = do + alice <- randomUser OwnDomain def + bob <- randomUser FedV0Domain def + withAPIVersion 4 $ connectTwoUsers alice bob + + conv <- + postConversation alice (defProteus {qualifiedUsers = [bob]}) + >>= getJSON 201 + + withWebSocket bob $ \ws -> do + void $ changeConversationName alice conv "foobar" >>= getJSON 200 + void $ awaitMatch isConvNameChangeNotif ws diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index f85f1d0934a..4becf8eb9a3 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -4,6 +4,7 @@ module Testlib.Env where import Control.Monad.Codensity import Control.Monad.IO.Class +import Control.Monad.Reader import Data.Default import Data.Function ((&)) import Data.Functor @@ -184,3 +185,6 @@ mkMLSState = Codensity $ \k -> ciphersuite = def, protocol = MLSProtocolMLS } + +withAPIVersion :: Int -> App a -> App a +withAPIVersion v = local $ \e -> e {defaultAPIVersion = v} diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 36ded2f1a6e..ad7d9e094fa 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -150,6 +150,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do . Log.field "error" (displayException e) throwM e Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi + -- TODO: clean this up case mostRecentTuple bodyVersions (notifications bundle) remoteVersions of Nothing -> Log.fatal $ From 1c0bfd0030368964bf0df6f69f568e3288cb3315 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 14 Feb 2024 16:57:39 +0100 Subject: [PATCH 39/52] Parse remote versions liberally We cannot parse the supported versions returned by a remote federator using our own `Version` type, because this breaks forward compatibility. Instead, use integers and convert later, ignoring any version that doesn't exist locally. --- .../src/Wire/API/Federation/API/Brig.hs | 2 +- .../src/Wire/API/Federation/Client.hs | 6 ++++-- .../src/Wire/API/Federation/Version.hs | 13 +++++++------ 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 9d099271406..0f1d386373f 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -76,7 +76,7 @@ instance ToSchema SearchResponse -- | For conventions see /docs/developer/federation-api-conventions.md type BrigApi = - FedEndpoint "api-version" () VersionInfo + FedEndpoint "api-version" () (VersionInfo Version) :<|> FedEndpoint "get-user-by-handle" Handle (Maybe UserProfile) :<|> FedEndpoint "get-users-by-ids" [UserId] [UserProfile] :<|> FedEndpoint "claim-prekey" (UserId, ClientId) (Maybe ClientPrekey) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 3fc876335f7..37444a6a49e 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -357,9 +357,11 @@ versionNegotiation localVersions = } in withHTTP2StreamingRequest @'Brig HTTP.statusIsSuccessful req $ \resp -> do body <- toLazyByteString <$> streamingResponseStrictBody resp - remoteVersions <- case Aeson.decode body of + allRemoteVersions <- case Aeson.decode body of Nothing -> E.throw (FederatorClientVersionNegotiationError InvalidVersionInfo) - Just info -> pure (Set.fromList (vinfoSupported info)) + Just info -> pure (vinfoSupported info) + -- ignore versions that don't even exist locally + let remoteVersions = Set.fromList $ Imports.mapMaybe intToVersion allRemoteVersions case Set.lookupMax (Set.intersection remoteVersions localVersions) of Just v -> pure v Nothing -> diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 91e133dc0c8..9042bb7d083 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -23,6 +23,7 @@ module Wire.API.Federation.Version V0Sym0, V1Sym0, V2Sym0, + intToVersion, versionInt, supportedVersions, VersionInfo (..), @@ -74,24 +75,24 @@ instance ToSchema Version where supportedVersions :: Set Version supportedVersions = Set.fromList [minBound .. maxBound] -data VersionInfo = VersionInfo - { vinfoSupported :: [Version] +data VersionInfo v = VersionInfo + { vinfoSupported :: [v] } - deriving (FromJSON, ToJSON, S.ToSchema) via (Schema VersionInfo) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema (VersionInfo v)) -instance ToSchema VersionInfo where +instance ToSchema v => ToSchema (VersionInfo v) where schema = objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ VersionInfo <$> vinfoSupported .= vinfoObjectSchema schema where - example :: VersionInfo + example :: VersionInfo Version example = VersionInfo { vinfoSupported = toList supportedVersions } -versionInfo :: VersionInfo +versionInfo :: VersionInfo Version versionInfo = VersionInfo (toList supportedVersions) ---------------------------------------------------------------------- From d3c28e4b91049e39d4e5cebe67c5077b62d32fa5 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 15 Feb 2024 15:34:17 +0100 Subject: [PATCH 40/52] Support broken fed API version negotiation Old backends are not able to parse version lists containing newer versions. This commit changes the JSON format of the response of the `api-version` federation endpoint, and leaves a hardcoded value for the legacy field that old backends are able to parse. This means that version negotiation running within an old backend will return a bogus result, but since those old backends were not actually making use of federation API versioning, that is not a problem. --- .../src/Wire/API/Federation/API/Brig.hs | 2 +- .../src/Wire/API/Federation/Version.hs | 27 ++++++++++++------- .../src/Wire/BackendNotificationPusher.hs | 2 +- .../brig/test/integration/API/Federation.hs | 2 +- 4 files changed, 20 insertions(+), 13 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs index 0f1d386373f..9d099271406 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Brig.hs @@ -76,7 +76,7 @@ instance ToSchema SearchResponse -- | For conventions see /docs/developer/federation-api-conventions.md type BrigApi = - FedEndpoint "api-version" () (VersionInfo Version) + FedEndpoint "api-version" () VersionInfo :<|> FedEndpoint "get-user-by-handle" Handle (Maybe UserProfile) :<|> FedEndpoint "get-users-by-ids" [UserId] [UserProfile] :<|> FedEndpoint "claim-prekey" (UserId, ClientId) (Maybe ClientPrekey) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 9042bb7d083..8fc97b5ab7c 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -50,7 +50,6 @@ import Data.Schema import Data.Set qualified as Set import Data.Singletons.Base.TH import Imports -import Wire.API.VersionInfo data Version = V0 | V1 | V2 deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) @@ -75,25 +74,33 @@ instance ToSchema Version where supportedVersions :: Set Version supportedVersions = Set.fromList [minBound .. maxBound] -data VersionInfo v = VersionInfo - { vinfoSupported :: [v] +data VersionInfo = VersionInfo + { vinfoSupported :: [Int] } - deriving (FromJSON, ToJSON, S.ToSchema) via (Schema (VersionInfo v)) + deriving (FromJSON, ToJSON, S.ToSchema) via (Schema VersionInfo) -instance ToSchema v => ToSchema (VersionInfo v) where +instance ToSchema VersionInfo where schema = objectWithDocModifier "VersionInfo" (S.schema . S.example ?~ toJSON example) $ VersionInfo - <$> vinfoSupported .= vinfoObjectSchema schema + -- if the supported_versions field does not exist, assume an old backend + -- that only supports V0 + <$> vinfoSupported + .= fmap + (fromMaybe [0]) + (optField "supported_versions" (array schema)) + -- legacy field to support older versions of the backend with broken + -- version negotiation + <* const [0 :: Int, 1] .= field "supported" (array schema) where - example :: VersionInfo Version + example :: VersionInfo example = VersionInfo - { vinfoSupported = toList supportedVersions + { vinfoSupported = map versionInt (toList supportedVersions) } -versionInfo :: VersionInfo Version -versionInfo = VersionInfo (toList supportedVersions) +versionInfo :: VersionInfo +versionInfo = VersionInfo (map versionInt (toList supportedVersions)) ---------------------------------------------------------------------- diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index ad7d9e094fa..65195a993c0 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -149,7 +149,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do . Log.field "domain" (domainText targetDomain) . Log.field "error" (displayException e) throwM e - Right vi -> pure . Set.fromList . fmap versionInt . vinfoSupported $ vi + Right vi -> pure . Set.fromList . vinfoSupported $ vi -- TODO: clean this up case mostRecentTuple bodyVersions (notifications bundle) remoteVersions of Nothing -> diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index 2f0def2baef..3b5829f1c5a 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -373,4 +373,4 @@ testGetUserClientsNotFound fedBrigClient = do testAPIVersion :: Brig -> FedClient 'Brig -> Http () testAPIVersion _brig fedBrigClient = do vinfo <- runFedClient @"api-version" fedBrigClient (Domain "far-away.example.com") () - liftIO $ vinfoSupported vinfo @?= toList supportedVersions + liftIO $ vinfoSupported vinfo @?= map versionInt (toList supportedVersions) From 1235397c24d52ddb6c022f40eeaa7633b8feb525 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Feb 2024 14:43:01 +0100 Subject: [PATCH 41/52] Turn on-conversation-updated uses into notifs --- .../API/Federation/BackendNotifications.hs | 1 - services/galley/src/Galley/API/Action.hs | 35 +++++++--------- services/galley/src/Galley/API/Clients.hs | 34 +++++++-------- services/galley/src/Galley/API/Federation.hs | 3 ++ services/galley/src/Galley/API/Internal.hs | 27 ++---------- .../Galley/API/MLS/Commit/ExternalCommit.hs | 4 +- services/galley/src/Galley/API/MLS/Message.hs | 5 --- .../galley/src/Galley/API/MLS/Propagate.hs | 37 +++++++++-------- .../galley/src/Galley/API/MLS/Proposal.hs | 2 + services/galley/src/Galley/API/MLS/Removal.hs | 14 +++++-- .../src/Galley/API/MLS/SubConversation.hs | 1 + services/galley/src/Galley/API/Message.hs | 41 ++++++++++--------- services/galley/src/Galley/API/Teams.hs | 11 ++--- services/galley/src/Galley/API/Update.hs | 34 ++++++--------- services/galley/src/Galley/API/Util.hs | 3 +- .../Effects/BackendNotificationQueueAccess.hs | 41 ++++++++++++++++++- 16 files changed, 156 insertions(+), 137 deletions(-) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs index 06893daed63..43849c716da 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/BackendNotifications.hs @@ -93,7 +93,6 @@ newtype PayloadBundle (c :: Component) = PayloadBundle deriving (A.ToJSON, A.FromJSON) via (Schema (PayloadBundle c)) deriving newtype (Semigroup) --- TODO(md): automatically derive this instance instance ToSchema (PayloadBundle c) where schema = object "PayloadBundle" $ diff --git a/services/galley/src/Galley/API/Action.hs b/services/galley/src/Galley/API/Action.hs index 51eec49ead5..063b985fd52 100644 --- a/services/galley/src/Galley/API/Action.hs +++ b/services/galley/src/Galley/API/Action.hs @@ -720,7 +720,6 @@ updateLocalConversation :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (Logger (Log.Msg -> Log.Msg)) r, HasConversationActionEffects tag r, SingI tag ) => @@ -760,7 +759,6 @@ updateLocalConversationUnchecked :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (Logger (Log.Msg -> Log.Msg)) r, HasConversationActionEffects tag r ) => Local Conversation -> @@ -861,9 +859,9 @@ notifyConversationAction :: forall tag r. ( Member BackendNotificationQueueAccess r, Member ExternalAccess r, + Member (Error FederationError) r, Member NotificationSubsystem r, - Member (Input UTCTime) r, - Member (Logger (Log.Msg -> Log.Msg)) r + Member (Input UTCTime) r ) => Sing tag -> Qualified UserId -> @@ -884,24 +882,19 @@ notifyConversationAction tag quid notifyOrigDomain con lconv targets action = do (tUnqualified lcnv) uids (SomeConversationAction tag action) - handleError :: FederationError -> Sem r (Maybe ConversationUpdate) - handleError fedErr = - logRemoteNotificationError @"on-conversation-updated" fedErr $> Nothing - update <- - fmap (fromMaybe (mkUpdate [])) - . (either handleError (pure . asum . map tUnqualified)) - <=< enqueueNotificationsConcurrently Q.Persistent (toList (bmRemotes targets)) - $ \ruids -> do - let update = mkUpdate (tUnqualified ruids) - -- if notifyOrigDomain is false, filter out user from quid's domain, - -- because quid's backend will update local state and notify its users - -- itself using the ConversationUpdate returned by this function - if notifyOrigDomain || tDomain ruids /= qDomain quid - then do - makeConversationUpdateBundle update >>= sendBundle - pure Nothing - else pure (Just update) + fmap (fromMaybe (mkUpdate []) . asum . map tUnqualified) $ + enqueueNotificationsConcurrently Q.Persistent (toList (bmRemotes targets)) $ + \ruids -> do + let update = mkUpdate (tUnqualified ruids) + -- if notifyOrigDomain is false, filter out user from quid's domain, + -- because quid's backend will update local state and notify its users + -- itself using the ConversationUpdate returned by this function + if notifyOrigDomain || tDomain ruids /= qDomain quid + then do + makeConversationUpdateBundle update >>= sendBundle + pure Nothing + else pure (Just update) -- notify local participants and bots pushConversationEvent con e (qualifyAs lcnv (bmLocals targets)) (bmBots targets) diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index c4077dbf228..cfb18cd320a 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -50,6 +50,7 @@ import Polysemy.TinyLog qualified as P import Wire.API.Conversation hiding (Member) import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error import Wire.API.Routes.MultiTablePaging import Wire.NotificationSubsystem import Wire.Sem.Paging.Cassandra (CassandraPaging) @@ -91,23 +92,22 @@ addClientH (usr ::: clt) = do rmClientH :: forall p1 r. ( p1 ~ CassandraPaging, - ( Member ClientStore r, - Member ConversationStore r, - Member ExternalAccess r, - Member BackendNotificationQueueAccess r, - Member FederatorAccess r, - Member NotificationSubsystem r, - Member (Input Env) r, - Member (Input (Local ())) r, - Member (Input UTCTime) r, - Member (ListItems p1 ConvId) r, - Member (ListItems p1 (Remote ConvId)) r, - Member MemberStore r, - Member (Error InternalError) r, - Member ProposalStore r, - Member SubConversationStore r, - Member P.TinyLog r - ) + Member ClientStore r, + Member ConversationStore r, + Member (Error FederationError) r, + Member ExternalAccess r, + Member BackendNotificationQueueAccess r, + Member NotificationSubsystem r, + Member (Input Env) r, + Member (Input (Local ())) r, + Member (Input UTCTime) r, + Member (ListItems p1 ConvId) r, + Member (ListItems p1 (Remote ConvId)) r, + Member MemberStore r, + Member (Error InternalError) r, + Member ProposalStore r, + Member SubConversationStore r, + Member P.TinyLog r ) => UserId ::: ClientId -> Sem r Response diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 6d0e0bd79c7..f83d41a6a27 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -129,6 +129,7 @@ onClientRemoved :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, Member ExternalAccess r, + Member (Error FederationError) r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input (Local ())) r, @@ -395,6 +396,7 @@ onUserDeleted :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, Member FireAndForget r, + Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, Member (Input (Local ())) r, @@ -679,6 +681,7 @@ getSubConversationForRemoteUser domain GetSubConversationsRequest {..} = leaveSubConversation :: ( HasLeaveSubConversationEffects r, + Member (Error FederationError) r, Member (Input (Local ())) r, Member Resource r ) => diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 11251ee3b5c..15d0107d009 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -56,7 +56,6 @@ import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess import Galley.Effects.ClientStore import Galley.Effects.ConversationStore -import Galley.Effects.FederatorAccess import Galley.Effects.LegalHoldStore as LegalHoldStore import Galley.Effects.MemberStore qualified as E import Galley.Effects.TeamStore @@ -303,9 +302,9 @@ rmUser :: Member ClientStore r, Member ConversationStore r, Member (Error DynError) r, + Member (Error FederationError) r, Member (Error InternalError) r, Member ExternalAccess r, - Member FederatorAccess r, Member NotificationSubsystem r, Member (Input Env) r, Member (Input Opts) r, @@ -417,10 +416,9 @@ rmUser lusr conn = do alreadyPresentUsers = tUnqualified remotes, action = SomeConversationAction (sing @'ConversationLeaveTag) () } - -- TODO: use notification - let rpc = fedClient @'Galley @"on-conversation-updated" convUpdate - runFederatedEither remotes rpc - >>= logAndIgnoreError "Error in onConversationUpdated call" (qUnqualified qUser) + enqueueNotification Q.Persistent remotes $ do + makeConversationUpdateBundle convUpdate + >>= sendBundle leaveRemoteConversations :: Range 1 UserDeletedNotificationMaxConvs [Remote ConvId] -> Sem r () leaveRemoteConversations cids = @@ -429,23 +427,6 @@ rmUser lusr conn = do let rpc = fedQueueClient @'OnUserDeletedConversationsTag userDelete enqueueNotification Q.Persistent remoteConvs rpc - -- FUTUREWORK: Add a retry mechanism if there are federation errrors. - -- See https://wearezeta.atlassian.net/browse/SQCORE-1091 - logAndIgnoreError :: Text -> UserId -> Either FederationError a -> Sem r () - logAndIgnoreError message usr res = do - case res of - Left federationError -> - P.err - ( Log.msg - ( "Federation error while notifying remote backends of a user deletion (Galley). " - <> message - <> " " - <> (cs . show $ federationError) - ) - . Log.field "user" (show usr) - ) - Right _ -> pure () - deleteLoop :: App () deleteLoop = do q <- view deleteQueue diff --git a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs index 907e9ecb36d..484f5812332 100644 --- a/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs +++ b/services/galley/src/Galley/API/MLS/Commit/ExternalCommit.hs @@ -41,6 +41,7 @@ import Polysemy.State import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Federation.Error import Wire.API.MLS.Commit import Wire.API.MLS.Credential import Wire.API.MLS.LeafNode @@ -121,7 +122,8 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do processExternalCommit :: forall r. - ( Member (ErrorS 'MLSStaleMessage) r, + ( Member (Error FederationError) r, + Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSSubConvClientNotInParent) r, Member Resource r, HasProposalActionEffects r diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index 3afffb4d0a3..e49bd404de0 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -115,7 +115,6 @@ type MLSBundleStaticErrors = postMLSMessageFromLocalUser :: ( HasProposalEffects r, - Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvMemberNotFound) r, Member (ErrorS 'ConvNotFound) r, @@ -149,7 +148,6 @@ postMLSMessageFromLocalUser lusr c conn smsg = do postMLSCommitBundle :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, - Member (Error FederationError) r, Member Resource r, Member SubConversationStore r ) => @@ -171,7 +169,6 @@ postMLSCommitBundle loc qusr c ctype qConvOrSub conn bundle = postMLSCommitBundleFromLocalUser :: ( HasProposalEffects r, Members MLSBundleStaticErrors r, - Member (Error FederationError) r, Member Resource r, Member SubConversationStore r ) => @@ -318,7 +315,6 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle ctype rConvOrSubId = do postMLSMessage :: ( HasProposalEffects r, - Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvMemberNotFound) r, Member (ErrorS 'ConvNotFound) r, @@ -417,7 +413,6 @@ postMLSMessageToLocalConv qusr c con msg ctype convOrSubId = do postMLSMessageToRemoteConv :: ( Members MLSMessageStaticErrors r, - Member (Error FederationError) r, HasProposalEffects r ) => Local x -> diff --git a/services/galley/src/Galley/API/MLS/Propagate.hs b/services/galley/src/Galley/API/MLS/Propagate.hs index 3a99fa9783d..b0fe16e6c8c 100644 --- a/services/galley/src/Galley/API/MLS/Propagate.hs +++ b/services/galley/src/Galley/API/MLS/Propagate.hs @@ -27,7 +27,6 @@ import Data.Qualified import Data.Time import Galley.API.MLS.Types import Galley.API.Push -import Galley.API.Util import Galley.Data.Services import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess @@ -36,11 +35,13 @@ import Gundeck.Types.Push.V2 (RecipientClients (..)) import Imports import Network.AMQP qualified as Q import Polysemy +import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog hiding (trace) import Wire.API.Event.Conversation import Wire.API.Federation.API import Wire.API.Federation.API.Galley +import Wire.API.Federation.Error import Wire.API.MLS.Credential import Wire.API.MLS.Message import Wire.API.MLS.Serialisation @@ -53,6 +54,7 @@ import Wire.NotificationSubsystem -- a requirement from Core Crypto and the clients. propagateMessage :: ( Member BackendNotificationQueueAccess r, + Member (Error FederationError) r, Member ExternalAccess r, Member (Input UTCTime) r, Member TinyLog r, @@ -87,22 +89,23 @@ propagateMessage qusr mSenderClient lConvOrSub con msg cm = do newMessagePush botMap con mm (lmems >>= toList . localMemberRecipient mlsConv) e -- send to remotes - (either (logRemoteNotificationError @"on-mls-message-sent") (const (pure ())) <=< enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems)) $ - \rs -> - fedQueueClient - @'OnMLSMessageSentTag - RemoteMLSMessage - { time = now, - sender = qusr, - metadata = mm, - conversation = qUnqualified qcnv, - subConversation = sconv, - recipients = - Map.fromList $ - tUnqualified rs - >>= toList . remoteMemberMLSClients, - message = Base64ByteString msg.raw - } + void $ + enqueueNotificationsConcurrently Q.Persistent (map remoteMemberQualify rmems) $ + \rs -> + fedQueueClient + @'OnMLSMessageSentTag + RemoteMLSMessage + { time = now, + sender = qusr, + metadata = mm, + conversation = qUnqualified qcnv, + subConversation = sconv, + recipients = + Map.fromList $ + tUnqualified rs + >>= toList . remoteMemberMLSClients, + message = Base64ByteString msg.raw + } where cmWithoutSender = maybe cm (flip cmRemoveClient cm . mkClientIdentity qusr) mSenderClient diff --git a/services/galley/src/Galley/API/MLS/Proposal.hs b/services/galley/src/Galley/API/MLS/Proposal.hs index 39d56406b4c..9047db2a946 100644 --- a/services/galley/src/Galley/API/MLS/Proposal.hs +++ b/services/galley/src/Galley/API/MLS/Proposal.hs @@ -58,6 +58,7 @@ import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Protocol import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Federation.Error import Wire.API.MLS.AuthenticatedContent import Wire.API.MLS.Credential import Wire.API.MLS.KeyPackage @@ -116,6 +117,7 @@ type HasProposalEffects r = Member ConversationStore r, Member NotificationSubsystem r, Member (Error InternalError) r, + Member (Error FederationError) r, Member (Error MLSProposalFailure) r, Member (Error MLSProtocolError) r, Member (ErrorS 'MLSClientMismatch) r, diff --git a/services/galley/src/Galley/API/MLS/Removal.hs b/services/galley/src/Galley/API/MLS/Removal.hs index f48631e7d23..f8491cdba47 100644 --- a/services/galley/src/Galley/API/MLS/Removal.hs +++ b/services/galley/src/Galley/API/MLS/Removal.hs @@ -44,10 +44,12 @@ import Galley.Env import Galley.Types.Conversations.Members import Imports hiding (cs) import Polysemy +import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import System.Logger qualified as Log import Wire.API.Conversation.Protocol +import Wire.API.Federation.Error import Wire.API.MLS.AuthenticatedContent import Wire.API.MLS.Credential import Wire.API.MLS.LeafNode @@ -59,7 +61,8 @@ import Wire.NotificationSubsystem -- | Send remove proposals for a set of clients to clients in the ClientMap. createAndSendRemoveProposals :: - ( Member (Input UTCTime) r, + ( Member (Error FederationError) r, + Member (Input UTCTime) r, Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, @@ -106,7 +109,8 @@ createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do propagateMessage qusr Nothing lConvOrSubConv Nothing msg cm removeClientsWithClientMapRecursively :: - ( Member (Input UTCTime) r, + ( Member (Error FederationError) r, + Member (Input UTCTime) r, Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, @@ -138,7 +142,8 @@ removeClientsWithClientMapRecursively lMlsConv getClients qusr = do removeClientsFromSubConvs lMlsConv getClients qusr removeClientsFromSubConvs :: - ( Member (Input UTCTime) r, + ( Member (Error FederationError) r, + Member (Input UTCTime) r, Member TinyLog r, Member BackendNotificationQueueAccess r, Member ExternalAccess r, @@ -177,6 +182,7 @@ removeClientsFromSubConvs lMlsConv getClients qusr = do -- | Send remove proposals for a single client of a user to the local conversation. removeClient :: ( Member BackendNotificationQueueAccess r, + Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, Member (Input Env) r, @@ -212,6 +218,7 @@ data RemoveUserIncludeMain -- | Send remove proposals for all clients of the user to the local conversation. removeUser :: ( Member BackendNotificationQueueAccess r, + Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, Member (Input Env) r, @@ -257,6 +264,7 @@ listSubConversations' cid = do -- | Send remove proposals for clients of users that are not part of a conversation removeExtraneousClients :: ( Member BackendNotificationQueueAccess r, + Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, Member (Input Env) r, diff --git a/services/galley/src/Galley/API/MLS/SubConversation.hs b/services/galley/src/Galley/API/MLS/SubConversation.hs index 7841a718396..ba13a24757b 100644 --- a/services/galley/src/Galley/API/MLS/SubConversation.hs +++ b/services/galley/src/Galley/API/MLS/SubConversation.hs @@ -377,6 +377,7 @@ leaveLocalSubConversation :: Member (Error MLSProtocolError) r, Member (ErrorS 'MLSStaleMessage) r, Member (ErrorS 'MLSNotEnabled) r, + Member (Error FederationError) r, Member Resource r, Members LeaveSubConversationStaticErrors r ) => diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index e28839f0f95..d4941d191c2 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -680,25 +680,28 @@ sendRemoteMessages :: MessageMetadata -> Map (UserId, ClientId) Text -> Sem r (Set (UserId, ClientId)) -sendRemoteMessages domain now sender senderClient lcnv metadata messages = (handle =<<) $ do - let rcpts = - foldr - (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) - mempty - (Map.assocs messages) - rm = - RemoteMessage - { time = now, - _data = mmData metadata, - sender = sender, - senderClient = senderClient, - conversation = tUnqualified lcnv, - priority = mmNativePriority metadata, - push = mmNativePush metadata, - transient = mmTransient metadata, - recipients = UserClientMap rcpts - } - enqueueNotification Q.Persistent domain (fedQueueClient @'OnMessageSentTag rm) +sendRemoteMessages domain now sender senderClient lcnv metadata messages = + -- FUTUREWORK: a FederationError here just means that queueing did not work. + -- It should not result in clients ending up in failedToSend. + (handle =<<) . runError $ do + let rcpts = + foldr + (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) + mempty + (Map.assocs messages) + rm = + RemoteMessage + { time = now, + _data = mmData metadata, + sender = sender, + senderClient = senderClient, + conversation = tUnqualified lcnv, + priority = mmNativePriority metadata, + push = mmNativePush metadata, + transient = mmTransient metadata, + recipients = UserClientMap rcpts + } + enqueueNotification Q.Persistent domain (fedQueueClient @'OnMessageSentTag rm) where handle :: Either FederationError a -> Sem r (Set (UserId, ClientId)) handle (Right _) = pure mempty diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 95272e6a832..f8a44b29b0a 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -122,7 +122,6 @@ import Polysemy.Input import Polysemy.Output import Polysemy.TinyLog qualified as P import SAML2.WebSSO qualified as SAML -import System.Logger (Msg) import System.Logger qualified as Log import Wire.API.Conversation (ConversationRemoveMembers (..)) import Wire.API.Conversation.Role (wireConvRoles) @@ -885,6 +884,7 @@ deleteTeamMember :: Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, @@ -913,6 +913,7 @@ deleteNonBindingTeamMember :: Member BrigAccess r, Member ConversationStore r, Member (Error AuthenticationError) r, + Member (Error FederationError) r, Member (Error InvalidInput) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, @@ -942,6 +943,7 @@ deleteTeamMember' :: Member ConversationStore r, Member (Error AuthenticationError) r, Member (Error InvalidInput) r, + Member (Error FederationError) r, Member (ErrorS 'AccessDenied) r, Member (ErrorS 'TeamMemberNotFound) r, Member (ErrorS 'TeamNotFound) r, @@ -1009,9 +1011,9 @@ uncheckedDeleteTeamMember :: ( Member BackendNotificationQueueAccess r, Member ConversationStore r, Member NotificationSubsystem r, + Member (Error FederationError) r, Member ExternalAccess r, Member (Input UTCTime) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, Member MemberStore r, Member TeamStore r ) => @@ -1059,10 +1061,10 @@ removeFromConvsAndPushConvLeaveEvent :: forall r. ( Member BackendNotificationQueueAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (P.Logger (Log.Msg -> Log.Msg)) r, Member MemberStore r, Member TeamStore r ) => @@ -1149,8 +1151,7 @@ deleteTeamConversation :: Member NotificationSubsystem r, Member (Input UTCTime) r, Member SubConversationStore r, - Member TeamStore r, - Member (P.Logger (Msg -> Msg)) r + Member TeamStore r ) => Local UserId -> ConnId -> diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index ddc89b92164..809f0376188 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -120,7 +120,6 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog -import System.Logger (Msg) import Wire.API.Conversation hiding (Member) import Wire.API.Conversation.Action import Wire.API.Conversation.Code @@ -400,8 +399,7 @@ updateConversationMessageTimer :: Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, - Member (Input UTCTime) r, - Member (Logger (Msg -> Msg)) r + Member (Input UTCTime) r ) => Local UserId -> ConnId -> @@ -433,8 +431,7 @@ updateConversationMessageTimerUnqualified :: Member (Error FederationError) r, Member ExternalAccess r, Member NotificationSubsystem r, - Member (Input UTCTime) r, - Member (Logger (Msg -> Msg)) r + Member (Input UTCTime) r ) => Local UserId -> ConnId -> @@ -460,8 +457,7 @@ deleteLocalConversation :: Member MemberStore r, Member ProposalStore r, Member (Input UTCTime) r, - Member TeamStore r, - Member (Logger (Msg -> Msg)) r + Member TeamStore r ) => Local UserId -> ConnId -> @@ -723,6 +719,7 @@ joinConversationByReusableCode :: Member BrigAccess r, Member CodeStore r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'CodeNotFound) r, Member (ErrorS 'InvalidConversationPassword) r, Member (ErrorS 'ConvAccessDenied) r, @@ -737,8 +734,7 @@ joinConversationByReusableCode :: Member (Input UTCTime) r, Member MemberStore r, Member TeamStore r, - Member TeamFeatureStore r, - Member (Logger (Msg -> Msg)) r + Member TeamFeatureStore r ) => Local UserId -> ConnId -> @@ -755,6 +751,7 @@ joinConversationById :: ( Member BackendNotificationQueueAccess r, Member BrigAccess r, Member ConversationStore r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'ConvNotFound) r, Member (ErrorS 'InvalidOperation) r, @@ -765,8 +762,7 @@ joinConversationById :: Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, - Member TeamStore r, - Member (Logger (Msg -> Msg)) r + Member TeamStore r ) => Local UserId -> ConnId -> @@ -780,6 +776,7 @@ joinConversation :: forall r. ( Member BackendNotificationQueueAccess r, Member BrigAccess r, + Member (Error FederationError) r, Member (ErrorS 'ConvAccessDenied) r, Member (ErrorS 'InvalidOperation) r, Member (ErrorS 'NotATeamMember) r, @@ -789,8 +786,7 @@ joinConversation :: Member (Input Opts) r, Member (Input UTCTime) r, Member MemberStore r, - Member TeamStore r, - Member (Logger (Msg -> Msg)) r + Member TeamStore r ) => Local UserId -> ConnId -> @@ -1017,8 +1013,7 @@ updateOtherMemberLocalConv :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member MemberStore r, - Member (Logger (Msg -> Msg)) r + Member MemberStore r ) => Local ConvId -> Local UserId -> @@ -1044,8 +1039,7 @@ updateOtherMemberUnqualified :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member MemberStore r, - Member (Logger (Msg -> Msg)) r + Member MemberStore r ) => Local UserId -> ConnId -> @@ -1070,8 +1064,7 @@ updateOtherMember :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member MemberStore r, - Member (Logger (Msg -> Msg)) r + Member MemberStore r ) => Local UserId -> ConnId -> @@ -1402,7 +1395,6 @@ updateConversationName :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (Logger (Msg -> Msg)) r, Member TeamStore r ) => Local UserId -> @@ -1429,7 +1421,6 @@ updateUnqualifiedConversationName :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (Logger (Msg -> Msg)) r, Member TeamStore r ) => Local UserId -> @@ -1452,7 +1443,6 @@ updateLocalConversationName :: Member ExternalAccess r, Member NotificationSubsystem r, Member (Input UTCTime) r, - Member (Logger (Msg -> Msg)) r, Member TeamStore r ) => Local UserId -> diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 4f77e38f01f..0c8d4df22fb 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -876,9 +876,8 @@ registerRemoteConversationMemberships now lusr lc = deleteOnUnreachable $ do ) joined - r <- enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> + void $ enqueueNotificationsConcurrentlyBuckets Q.Persistent joinedCoupled $ \z -> makeConversationUpdateBundle (convUpdateJoin z) >>= sendBundle - either throw (void . pure) r where creator :: Maybe UserId creator = cnvmCreator . DataTypes.convMetadata . tUnqualified $ lc diff --git a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs index 93e01126c9f..c9e44385e22 100644 --- a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs +++ b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs @@ -6,6 +6,7 @@ import Data.Qualified import Imports import Network.AMQP qualified as Q import Polysemy +import Polysemy.Error import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Component import Wire.API.Federation.Error @@ -30,4 +31,42 @@ data BackendNotificationQueueAccess m a where (Remote x -> FedQueueClient c a) -> BackendNotificationQueueAccess m (Either FederationError [Remote a]) -makeSem ''BackendNotificationQueueAccess +enqueueNotification :: + ( KnownComponent c, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r + ) => + Q.DeliveryMode -> + Remote x -> + FedQueueClient c a -> + Sem r a +enqueueNotification m r q = send (EnqueueNotification m r q) >>= either throw pure + +enqueueNotificationsConcurrently :: + ( KnownComponent c, + Foldable f, + Functor f, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r + ) => + Q.DeliveryMode -> + f (Remote x) -> + (Remote [x] -> FedQueueClient c a) -> + Sem r [Remote a] +enqueueNotificationsConcurrently m r q = + send (EnqueueNotificationsConcurrently m r q) + >>= either throw pure + +enqueueNotificationsConcurrentlyBuckets :: + ( KnownComponent c, + Foldable f, + Functor f, + Member (Error FederationError) r, + Member BackendNotificationQueueAccess r + ) => + Q.DeliveryMode -> + f (Remote x) -> + (Remote x -> FedQueueClient c a) -> + Sem r [Remote a] +enqueueNotificationsConcurrentlyBuckets m r q = + send (EnqueueNotificationsConcurrentlyBuckets m r q) >>= either throw pure From 68c38c1f9288090ab337f82b5d2ca889ecc764ed Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Feb 2024 15:38:38 +0100 Subject: [PATCH 42/52] Refactor notification version negotiation --- .../src/Wire/API/Federation/Version.hs | 35 +++++++--------- .../Test/Wire/API/Federation/VersionSpec.hs | 40 ------------------- .../wire-api-federation.cabal | 2 - .../src/Wire/BackendNotificationPusher.hs | 16 +++++--- 4 files changed, 26 insertions(+), 67 deletions(-) delete mode 100644 libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 8fc97b5ab7c..5c875d809a1 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -38,13 +38,12 @@ module Wire.API.Federation.Version latestCommonVersion, rangeFromVersion, rangeUntilVersion, - mostRecentTuple, + enumVersionRange, ) where import Control.Lens (makeLenses, (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.List.NonEmpty qualified as NE import Data.OpenApi qualified as S import Data.Schema import Data.Set qualified as Set @@ -154,6 +153,10 @@ instance Semigroup VersionRange where VersionRange from1 to1 <> VersionRange from2 to2 = VersionRange (max from1 from2) (min to1 to2) +inVersionRange :: VersionRange -> Version -> Bool +inVersionRange (VersionRange a b) v = + v >= a && VersionUpperBound v < b + rangeFromVersion :: Version -> VersionRange rangeFromVersion v = VersionRange v Unbounded @@ -171,24 +174,16 @@ enumVersionRange = -- remote versions are given as integers as the range of versions supported by -- the remote backend can include a version unknown to the local backend. If -- there is no version in common, the return value is 'Nothing'. -latestCommonVersion :: VersionRange -> Set Int -> Maybe Version -latestCommonVersion (Set.map versionInt . enumVersionRange -> localVersions) remoteVersions = - intToVersion =<< Set.lookupMax (Set.intersection localVersions remoteVersions) - -mostRecentTuple :: forall a. (a -> Maybe VersionRange) -> NE.NonEmpty a -> Set Int -> Maybe (a, Version) -mostRecentTuple pr (NE.toList -> as) remoteVersions = foldl' combine Nothing as - where - combine :: Maybe (a, Version) -> a -> Maybe (a, Version) - combine greatest a = - let notifGreatest = pr a >>= flip latestCommonVersion remoteVersions - in case (greatest, notifGreatest) of - (Nothing, Nothing) -> Nothing - (Nothing, Just v) -> Just (a, v) - (Just (gn, gv), Nothing) -> Just (gn, gv) - (Just (gn, gv), Just v) -> - if v > gv - then Just (a, v) - else Just (gn, gv) +latestCommonVersion :: Foldable f => VersionRange -> f Int -> Maybe Version +latestCommonVersion localVersions = + safeMaximum + . filter (inVersionRange localVersions) + . mapMaybe intToVersion + . toList + +safeMaximum :: Ord a => [a] -> Maybe a +safeMaximum [] = Nothing +safeMaximum as = Just (maximum as) $(genSingletons [''Version]) diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs deleted file mode 100644 index 386b88825de..00000000000 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/VersionSpec.hs +++ /dev/null @@ -1,40 +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 Test.Wire.API.Federation.VersionSpec where - -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Set qualified as Set -import Imports -import Test.Hspec -import Wire.API.Federation.Version - -spec :: Spec -spec = do - describe "mostRecentTuple" $ do - let mostRecent = mostRecentTuple Just - -- FUTUREWORK: once we have more Version values, we may want to add some tests here. - it "[..] + [] = null" $ do - mostRecent (pure allVersions) (Set.fromList []) `shouldBe` Nothing - it "[0] + [1] = null" $ do - mostRecent (pure $ VersionRange V0 (VersionUpperBound V1)) (Set.fromList []) `shouldBe` Nothing - it "[1] + [0, 1] = 1" $ do - fmap snd (mostRecent (pure $ VersionRange V1 Unbounded) (Set.fromList [0, 1])) `shouldBe` Just V1 - it "[0] + [0, 1] = 0" $ do - fmap snd (mostRecent (pure $ VersionRange V0 (VersionUpperBound V1)) (Set.fromList [0, 1])) `shouldBe` Just V0 - it "[..] + [1] = 1" $ do - fmap snd (mostRecent (VersionRange V0 (VersionUpperBound V1) :| [VersionRange V1 Unbounded]) (Set.fromList [1])) `shouldBe` Just V1 diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index bf8fa429e5e..f27c2fb751b 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -139,8 +139,6 @@ test-suite spec Test.Wire.API.Federation.Golden.NewConnectionRequest Test.Wire.API.Federation.Golden.NewConnectionResponse Test.Wire.API.Federation.Golden.Runner - Test.Wire.API.Federation.Version - Test.Wire.API.Federation.VersionSpec hs-source-dirs: test default-extensions: diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 65195a993c0..a006af4ad71 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -3,6 +3,7 @@ module Wire.BackendNotificationPusher where +import Control.Arrow import Control.Monad.Catch import Control.Retry import Data.Aeson qualified as A @@ -133,7 +134,6 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceOriginRequestId = fromMaybe (RequestId "N/A") . (.requestId) . NE.head $ bundle.notifications } - -- TODO(md): pull this out into a separate function for redability and testability remoteVersions :: Set Int <- liftIO -- use versioned client with no version set: since we are manually @@ -150,13 +150,15 @@ pushNotification runningFlag targetDomain (msg, envelope) = do . Log.field "error" (displayException e) throwM e Right vi -> pure . Set.fromList . vinfoSupported $ vi - -- TODO: clean this up - case mostRecentTuple bodyVersions (notifications bundle) remoteVersions of - Nothing -> + + -- compute the best usable version in a notification + let bestVersion = bodyVersions >=> flip latestCommonVersion remoteVersions + case pairedMaximumOn bestVersion (toList (notifications bundle)) of + (_, Nothing) -> Log.fatal $ Log.msg (Log.val "No federation API version in common, the notification will be ignored") . Log.field "domain" (domainText targetDomain) - Just (notif, Just -> cveVersion) -> do + (notif, cveVersion) -> do ceFederator <- asks (.federatorInternal) ceHttp2Manager <- asks http2Manager let ceOriginDomain = notif.ownDomain @@ -170,6 +172,10 @@ pushNotification runningFlag targetDomain (msg, envelope) = do withLabel metrics.pushedCounter (domainText targetDomain) incCounter withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) +-- | Find the pair that maximises b. +pairedMaximumOn :: Ord b => (a -> b) -> [a] -> (a, b) +pairedMaximumOn f = maximumBy (compare `on` snd) . map (id &&& f) + -- FUTUREWORK: Recosider using 1 channel for many consumers. It shouldn't matter -- for a handful of remote domains. -- Consumers is passed in explicitly so that cleanup code has a reference to the consumer tags. From 9ef54e8687080a39f2f6baf3464268b4b4dc5b7a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 2 Feb 2024 14:05:24 +0100 Subject: [PATCH 43/52] Add CHANGELOG entries --- changelog.d/6-federation/on-conversation-updated-async | 3 +++ changelog.d/6-federation/wpb-183-versioned-async-b2b | 2 ++ 2 files changed, 5 insertions(+) create mode 100644 changelog.d/6-federation/on-conversation-updated-async create mode 100644 changelog.d/6-federation/wpb-183-versioned-async-b2b diff --git a/changelog.d/6-federation/on-conversation-updated-async b/changelog.d/6-federation/on-conversation-updated-async new file mode 100644 index 00000000000..24885094cf6 --- /dev/null +++ b/changelog.d/6-federation/on-conversation-updated-async @@ -0,0 +1,3 @@ +The on-conversation-updated notification is now queued instead of being sent directly. A new version of the notification has been introduced with a different JSON format for the body, mostly for testing purposes of the versioning system. + +Since the notification is now sent asynchronously, some error conditions in case of unreachable backends cannot be triggered anymore. diff --git a/changelog.d/6-federation/wpb-183-versioned-async-b2b b/changelog.d/6-federation/wpb-183-versioned-async-b2b new file mode 100644 index 00000000000..c33245c5ccd --- /dev/null +++ b/changelog.d/6-federation/wpb-183-versioned-async-b2b @@ -0,0 +1,2 @@ +Versioning of backend to backend notifications. Notifications are now stored in "bundles" containing a serialised payload for each supported version. The background worker then dynamically selects the best version to use and sends only the notification corresponding to that version. + From 521e13fec2d0b762bfc2f1457515f90d6f69d892 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Feb 2024 16:12:21 +0100 Subject: [PATCH 44/52] Lint --- services/galley/src/Galley/API/Message.hs | 2 +- .../src/Galley/Effects/BackendNotificationQueueAccess.hs | 2 -- services/galley/test/integration/API.hs | 4 ++-- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index d4941d191c2..b436ea62250 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -683,7 +683,7 @@ sendRemoteMessages :: sendRemoteMessages domain now sender senderClient lcnv metadata messages = -- FUTUREWORK: a FederationError here just means that queueing did not work. -- It should not result in clients ending up in failedToSend. - (handle =<<) . runError $ do + (handle <=< runError) $ do let rcpts = foldr (\((u, c), t) -> Map.insertWith (<>) u (Map.singleton c t)) diff --git a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs index c9e44385e22..9c2fe5d4004 100644 --- a/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs +++ b/services/galley/src/Galley/Effects/BackendNotificationQueueAccess.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} - module Galley.Effects.BackendNotificationQueueAccess where import Data.Qualified diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 94dcaa803de..b3bbbebd906 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -3639,10 +3639,10 @@ removeUser = do bConvUpdatesA2 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA2) bConvUpdates bConvUpdatesA2.origUserId @?= alexDel bConvUpdatesA2.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () - bConvUpdatesA2.alreadyPresentUsers @?= [qUnqualified berta] + bConvUpdatesA2.alreadyPresentUsers @?= [qUnqualified berta] bConvUpdatesA4 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA4) bConvUpdates - bConvUpdatesA4.origUserId @?= alexDel + bConvUpdatesA4.origUserId @?= alexDel bConvUpdatesA4.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () bConvUpdatesA4.alreadyPresentUsers @?= [qUnqualified bart] From 4a7795bb0f602c231742c8b41c0278d8a106381f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 16 Feb 2024 16:43:45 +0100 Subject: [PATCH 45/52] Fix ConversationUpdate golden tests --- .../Federation/Golden/ConversationUpdate.hs | 34 +++++++++++++++++-- .../Wire/API/Federation/Golden/GoldenSpec.hs | 4 +++ .../testObject_ConversationUpdate1.json | 12 +++---- .../testObject_ConversationUpdate1V1.json | 26 ++++++++++++++ .../testObject_ConversationUpdate2.json | 12 +++---- .../testObject_ConversationUpdate2V1.json | 17 ++++++++++ 6 files changed, 91 insertions(+), 14 deletions(-) create mode 100644 libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json create mode 100644 libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index f2a3dd76342..9d70674b377 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -16,7 +16,9 @@ -- with this program. If not, see . module Test.Wire.API.Federation.Golden.ConversationUpdate - ( testObject_ConversationUpdate1, + ( testObject_ConversationUpdate1V1, + testObject_ConversationUpdate2V1, + testObject_ConversationUpdate1, testObject_ConversationUpdate2, ) where @@ -31,7 +33,7 @@ import Imports import Wire.API.Conversation import Wire.API.Conversation.Action import Wire.API.Conversation.Role (roleNameWireAdmin) -import Wire.API.Federation.API.Galley (ConversationUpdate (..)) +import Wire.API.Federation.API.Galley qAlice, qBob :: Qualified UserId qAlice = @@ -47,6 +49,34 @@ chad, dee :: UserId chad = Id (fromJust (UUID.fromString "00000fff-0000-0000-0000-000100005007")) dee = Id (fromJust (UUID.fromString "00000fff-0000-aaaa-0000-000100005007")) +testObject_ConversationUpdate1V1 :: ConversationUpdateV1 +testObject_ConversationUpdate1V1 = + ConversationUpdateV1 + { cuTime = read "1864-04-12 12:22:43.673 UTC", + cuOrigUserId = + Qualified + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000007"))) + (Domain "golden.example.com"), + cuConvId = + Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), + cuAlreadyPresentUsers = [], + cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qAlice :| [qBob]) roleNameWireAdmin) + } + +testObject_ConversationUpdate2V1 :: ConversationUpdateV1 +testObject_ConversationUpdate2V1 = + ConversationUpdateV1 + { cuTime = read "1864-04-12 12:22:43.673 UTC", + cuOrigUserId = + Qualified + (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000007"))) + (Domain "golden.example.com"), + cuConvId = + Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")), + cuAlreadyPresentUsers = [chad, dee], + cuAction = SomeConversationAction (sing @'ConversationLeaveTag) () + } + testObject_ConversationUpdate1 :: ConversationUpdate testObject_ConversationUpdate1 = ConversationUpdate diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index b436775494e..50efc309ae5 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -46,6 +46,10 @@ spec = (MLSMessageSendingStatus.testObject_MLSMessageSendingStatus3, "testObject_MLSMessageSendingStatus3.json") ] testObjects [(LeaveConversationRequest.testObject_LeaveConversationRequest1, "testObject_LeaveConversationRequest1.json")] + testObjects + [ (ConversationUpdate.testObject_ConversationUpdate1V1, "testObject_ConversationUpdate1V1.json"), + (ConversationUpdate.testObject_ConversationUpdate2V1, "testObject_ConversationUpdate2V1.json") + ] testObjects [ (ConversationUpdate.testObject_ConversationUpdate1, "testObject_ConversationUpdate1.json"), (ConversationUpdate.testObject_ConversationUpdate2, "testObject_ConversationUpdate2.json") diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json index 0c5ff9a27f2..a559d4197e5 100644 --- a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json @@ -1,5 +1,5 @@ { - "cuAction": { + "action": { "action": { "role": "wire_admin", "users": [ @@ -15,11 +15,11 @@ }, "tag": "ConversationJoinTag" }, - "cuAlreadyPresentUsers": [], - "cuConvId": "00000000-0000-0000-0000-000100000006", - "cuOrigUserId": { + "alreadyPresentUsers": [], + "convId": "00000000-0000-0000-0000-000100000006", + "origUserId": { "domain": "golden.example.com", "id": "00000000-0000-0000-0000-000100000007" }, - "cuTime": "1864-04-12T12:22:43.673Z" -} \ No newline at end of file + "time": "1864-04-12T12:22:43.673Z" +} diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json new file mode 100644 index 00000000000..89e99c41c09 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json @@ -0,0 +1,26 @@ +{ + "cuAction": { + "action": { + "role": "wire_admin", + "users": [ + { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100004007" + }, + { + "domain": "golden2.example.com", + "id": "00000000-0000-0000-0000-000100005007" + } + ] + }, + "tag": "ConversationJoinTag" + }, + "cuAlreadyPresentUsers": [], + "cuConvId": "00000000-0000-0000-0000-000100000006", + "cuOrigUserId": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + }, + "cuTime": "1864-04-12T12:22:43.673Z" +} + diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json index 8b443934beb..fea5fc43ecb 100644 --- a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2.json @@ -1,16 +1,16 @@ { - "cuAction": { + "action": { "action": {}, "tag": "ConversationLeaveTag" }, - "cuAlreadyPresentUsers": [ + "alreadyPresentUsers": [ "00000fff-0000-0000-0000-000100005007", "00000fff-0000-aaaa-0000-000100005007" ], - "cuConvId": "00000000-0000-0000-0000-000100000006", - "cuOrigUserId": { + "convId": "00000000-0000-0000-0000-000100000006", + "origUserId": { "domain": "golden.example.com", "id": "00000000-0000-0000-0000-000100000007" }, - "cuTime": "1864-04-12T12:22:43.673Z" -} \ No newline at end of file + "time": "1864-04-12T12:22:43.673Z" +} diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json new file mode 100644 index 00000000000..df533d7bad9 --- /dev/null +++ b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json @@ -0,0 +1,17 @@ +{ + "cuAction": { + "action": {}, + "tag": "ConversationLeaveTag" + }, + "cuAlreadyPresentUsers": [ + "00000fff-0000-0000-0000-000100005007", + "00000fff-0000-aaaa-0000-000100005007" + ], + "cuConvId": "00000000-0000-0000-0000-000100000006", + "cuOrigUserId": { + "domain": "golden.example.com", + "id": "00000000-0000-0000-0000-000100000007" + }, + "cuTime": "1864-04-12T12:22:43.673Z" +} + From 4f464db005a31208676f5d47a20c826750828e59 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 19 Feb 2024 10:30:19 +0100 Subject: [PATCH 46/52] Remove federation version V2 It was introduced to accommodate older backends that were already claiming to support V1. However, now that the version negotiation system is bypassing the old one, there is no need for the extra version bump. --- .../Federation/API/Galley/Notifications.hs | 34 +++++++++---------- .../src/Wire/API/Federation/API/Util.hs | 2 +- .../src/Wire/API/Federation/Version.hs | 7 ++-- .../Federation/Golden/ConversationUpdate.hs | 16 ++++----- .../Wire/API/Federation/Golden/GoldenSpec.hs | 4 +-- ... => testObject_ConversationUpdate1V0.json} | 0 ... => testObject_ConversationUpdate2V0.json} | 0 services/galley/src/Galley/API/Federation.hs | 10 +++--- 8 files changed, 35 insertions(+), 38 deletions(-) rename libs/wire-api-federation/test/golden/{testObject_ConversationUpdate1V1.json => testObject_ConversationUpdate1V0.json} (100%) rename libs/wire-api-federation/test/golden/{testObject_ConversationUpdate2V1.json => testObject_ConversationUpdate2V0.json} (100%) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs index 3a432852fbb..0318e84d666 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley/Notifications.hs @@ -45,7 +45,7 @@ data GalleyNotificationTag = OnClientRemovedTag | OnMessageSentTag | OnMLSMessageSentTag - | OnConversationUpdatedTagV1 + | OnConversationUpdatedTagV0 | OnConversationUpdatedTag | OnUserDeletedConversationsTag deriving (Show, Eq, Generic, Bounded, Enum) @@ -69,16 +69,16 @@ instance HasNotificationEndpoint 'OnMLSMessageSentTag where -- used by the backend that owns a conversation to inform this backend of -- changes to the conversation -instance HasNotificationEndpoint 'OnConversationUpdatedTagV1 where - type Payload 'OnConversationUpdatedTagV1 = ConversationUpdateV1 - type NotificationPath 'OnConversationUpdatedTagV1 = "on-conversation-updated" - type NotificationVersionTag 'OnConversationUpdatedTagV1 = 'Just 'V1 - type NotificationMods 'OnConversationUpdatedTagV1 = '[Until 'V2] +instance HasNotificationEndpoint 'OnConversationUpdatedTagV0 where + type Payload 'OnConversationUpdatedTagV0 = ConversationUpdateV0 + type NotificationPath 'OnConversationUpdatedTagV0 = "on-conversation-updated" + type NotificationVersionTag 'OnConversationUpdatedTagV0 = 'Just 'V0 + type NotificationMods 'OnConversationUpdatedTagV0 = '[Until 'V1] instance HasNotificationEndpoint 'OnConversationUpdatedTag where type Payload 'OnConversationUpdatedTag = ConversationUpdate type NotificationPath 'OnConversationUpdatedTag = "on-conversation-updated" - type NotificationMods 'OnConversationUpdatedTag = '[From 'V2] + type NotificationMods 'OnConversationUpdatedTag = '[From 'V1] instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification @@ -89,7 +89,7 @@ type GalleyNotificationAPI = NotificationFedEndpoint 'OnClientRemovedTag :<|> NotificationFedEndpoint 'OnMessageSentTag :<|> NotificationFedEndpoint 'OnMLSMessageSentTag - :<|> NotificationFedEndpoint 'OnConversationUpdatedTagV1 + :<|> NotificationFedEndpoint 'OnConversationUpdatedTagV0 :<|> NotificationFedEndpoint 'OnConversationUpdatedTag :<|> NotificationFedEndpoint 'OnUserDeletedConversationsTag @@ -140,7 +140,7 @@ data RemoteMLSMessage = RemoteMLSMessage instance ToSchema RemoteMLSMessage -data ConversationUpdateV1 = ConversationUpdateV1 +data ConversationUpdateV0 = ConversationUpdateV0 { cuTime :: UTCTime, cuOrigUserId :: Qualified UserId, -- | The unqualified ID of the conversation where the update is happening. @@ -158,11 +158,11 @@ data ConversationUpdateV1 = ConversationUpdateV1 } deriving (Eq, Show, Generic) -instance ToJSON ConversationUpdateV1 +instance ToJSON ConversationUpdateV0 -instance FromJSON ConversationUpdateV1 +instance FromJSON ConversationUpdateV0 -instance ToSchema ConversationUpdateV1 +instance ToSchema ConversationUpdateV0 data ConversationUpdate = ConversationUpdate { time :: UTCTime, @@ -188,9 +188,9 @@ instance FromJSON ConversationUpdate instance ToSchema ConversationUpdate -conversationUpdateToV1 :: ConversationUpdate -> ConversationUpdateV1 -conversationUpdateToV1 cu = - ConversationUpdateV1 +conversationUpdateToV0 :: ConversationUpdate -> ConversationUpdateV0 +conversationUpdateToV0 cu = + ConversationUpdateV0 { cuTime = cu.time, cuOrigUserId = cu.origUserId, cuConvId = cu.convId, @@ -198,8 +198,8 @@ conversationUpdateToV1 cu = cuAction = cu.action } -conversationUpdateFromV1 :: ConversationUpdateV1 -> ConversationUpdate -conversationUpdateFromV1 cu = +conversationUpdateFromV0 :: ConversationUpdateV0 -> ConversationUpdate +conversationUpdateFromV0 cu = ConversationUpdate { time = cu.cuTime, origUserId = cu.cuOrigUserId, diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs index e095682ee61..d855c2abb01 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API/Util.hs @@ -26,4 +26,4 @@ makeConversationUpdateBundle :: ConversationUpdate -> FedQueueClient 'Galley (PayloadBundle 'Galley) makeConversationUpdateBundle update = - (<>) <$> makeBundle update <*> makeBundle (conversationUpdateToV1 update) + (<>) <$> makeBundle update <*> makeBundle (conversationUpdateToV0 update) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs index 5c875d809a1..a9055c7384b 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Version.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Version.hs @@ -22,7 +22,6 @@ module Wire.API.Federation.Version Version (..), V0Sym0, V1Sym0, - V2Sym0, intToVersion, versionInt, supportedVersions, @@ -50,14 +49,13 @@ import Data.Set qualified as Set import Data.Singletons.Base.TH import Imports -data Version = V0 | V1 | V2 +data Version = V0 | V1 deriving stock (Eq, Ord, Bounded, Enum, Show, Generic) deriving (FromJSON, ToJSON) via (Schema Version) versionInt :: Version -> Int versionInt V0 = 0 versionInt V1 = 1 -versionInt V2 = 2 intToVersion :: Int -> Maybe Version intToVersion intV = find (\v -> versionInt v == intV) [minBound ..] @@ -66,8 +64,7 @@ instance ToSchema Version where schema = enum @Integer "Version" . mconcat $ [ element 0 V0, - element 1 V1, - element 2 V2 + element 1 V1 ] supportedVersions :: Set Version diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs index 9d70674b377..568e6533b67 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/ConversationUpdate.hs @@ -16,8 +16,8 @@ -- with this program. If not, see . module Test.Wire.API.Federation.Golden.ConversationUpdate - ( testObject_ConversationUpdate1V1, - testObject_ConversationUpdate2V1, + ( testObject_ConversationUpdate1V0, + testObject_ConversationUpdate2V0, testObject_ConversationUpdate1, testObject_ConversationUpdate2, ) @@ -49,9 +49,9 @@ chad, dee :: UserId chad = Id (fromJust (UUID.fromString "00000fff-0000-0000-0000-000100005007")) dee = Id (fromJust (UUID.fromString "00000fff-0000-aaaa-0000-000100005007")) -testObject_ConversationUpdate1V1 :: ConversationUpdateV1 -testObject_ConversationUpdate1V1 = - ConversationUpdateV1 +testObject_ConversationUpdate1V0 :: ConversationUpdateV0 +testObject_ConversationUpdate1V0 = + ConversationUpdateV0 { cuTime = read "1864-04-12 12:22:43.673 UTC", cuOrigUserId = Qualified @@ -63,9 +63,9 @@ testObject_ConversationUpdate1V1 = cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qAlice :| [qBob]) roleNameWireAdmin) } -testObject_ConversationUpdate2V1 :: ConversationUpdateV1 -testObject_ConversationUpdate2V1 = - ConversationUpdateV1 +testObject_ConversationUpdate2V0 :: ConversationUpdateV0 +testObject_ConversationUpdate2V0 = + ConversationUpdateV0 { cuTime = read "1864-04-12 12:22:43.673 UTC", cuOrigUserId = Qualified diff --git a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs index 50efc309ae5..b691cd8e962 100644 --- a/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs +++ b/libs/wire-api-federation/test/Test/Wire/API/Federation/Golden/GoldenSpec.hs @@ -47,8 +47,8 @@ spec = ] testObjects [(LeaveConversationRequest.testObject_LeaveConversationRequest1, "testObject_LeaveConversationRequest1.json")] testObjects - [ (ConversationUpdate.testObject_ConversationUpdate1V1, "testObject_ConversationUpdate1V1.json"), - (ConversationUpdate.testObject_ConversationUpdate2V1, "testObject_ConversationUpdate2V1.json") + [ (ConversationUpdate.testObject_ConversationUpdate1V0, "testObject_ConversationUpdate1V0.json"), + (ConversationUpdate.testObject_ConversationUpdate2V0, "testObject_ConversationUpdate2V0.json") ] testObjects [ (ConversationUpdate.testObject_ConversationUpdate1, "testObject_ConversationUpdate1.json"), diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V0.json similarity index 100% rename from libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V1.json rename to libs/wire-api-federation/test/golden/testObject_ConversationUpdate1V0.json diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V0.json similarity index 100% rename from libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V1.json rename to libs/wire-api-federation/test/golden/testObject_ConversationUpdate2V0.json diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index f83d41a6a27..6bee0e21f14 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -121,7 +121,7 @@ federationSitemap = :<|> Named @"on-client-removed" onClientRemoved :<|> Named @"on-message-sent" onMessageSent :<|> Named @"on-mls-message-sent" onMLSMessageSent - :<|> Named @(Versioned 'V1 "on-conversation-updated") onConversationUpdatedV1 + :<|> Named @(Versioned 'V0 "on-conversation-updated") onConversationUpdatedV0 :<|> Named @"on-conversation-updated" onConversationUpdated :<|> Named @"on-user-deleted-conversations" onUserDeleted @@ -229,7 +229,7 @@ onConversationUpdated requestingDomain cu = do void $ updateLocalStateOfRemoteConv rcu Nothing pure EmptyResponse -onConversationUpdatedV1 :: +onConversationUpdatedV0 :: ( Member BrigAccess r, Member NotificationSubsystem r, Member ExternalAccess r, @@ -238,10 +238,10 @@ onConversationUpdatedV1 :: Member P.TinyLog r ) => Domain -> - ConversationUpdateV1 -> + ConversationUpdateV0 -> Sem r EmptyResponse -onConversationUpdatedV1 domain cu = - onConversationUpdated domain (conversationUpdateFromV1 cu) +onConversationUpdatedV0 domain cu = + onConversationUpdated domain (conversationUpdateFromV0 cu) -- as of now this will not generate the necessary events on the leaver's domain leaveConversation :: From d060253511eaef14af2c75792b3ada5ab3b623dc Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 20 Feb 2024 15:09:23 +0100 Subject: [PATCH 47/52] Remove obsolete tests from galley integration --- services/galley/test/integration/API.hs | 248 ------------------------ 1 file changed, 248 deletions(-) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index b3bbbebd906..ccff779599f 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -132,7 +132,6 @@ tests s = test s "metrics" metrics, test s "fetch conversation by qualified ID (v2)" testGetConvQualifiedV2, test s "create Proteus conversation" postProteusConvOk, - test s "create conversation with remote users all reachable" (postConvWithRemoteUsersOk $ Set.fromList [rb1, rb2]), test s "create conversation with remote users some unreachable" (postConvWithUnreachableRemoteUsers $ Set.fromList [rb1, rb2, rb3, rb4]), test s "get empty conversations" getConvsOk, test s "get conversations by ids" getConvsOk2, @@ -242,7 +241,6 @@ tests s = test s "existing has password, requested has password - 409" postCodeWithPasswordExistsWithPasswordRequested ], test s "remove user with only local convs" removeUserNoFederation, - test s "remove user with local and remote convs" removeUser, test s "iUpsertOne2OneConversation" testAllOne2OneConversationRequests, test s "post message - reject if missing client" postMessageRejectIfMissingClients, test s "post message - client that is not in group doesn't receive message" postMessageClientNotInGroupDoesNotReceiveMsg, @@ -412,121 +410,6 @@ postConvWithUnreachableRemoteUsers rbs = do groupConvs WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] -postConvWithRemoteUsersOk :: Set (Remote Backend) -> TestM () -postConvWithRemoteUsersOk rbs = do - c <- view tsCannon - (alice, qAlice) <- randomUserTuple - (alex, qAlex) <- randomUserTuple - (amy, qAmy) <- randomUserTuple - connectUsers alice (list1 alex [amy]) - (allRemotes, participatingRemotes) <- do - v <- forM (toList rbs) $ \rb -> do - users <- connectBackend alice rb - pure (users, participating rb users) - pure $ foldr (\(a, p) acc -> bimap ((<>) a) ((<>) p) acc) ([], []) v - liftIO $ - assertBool "Not every backend is reachable in the test" (allRemotes == participatingRemotes) - - let convName = "some chat" - otherLocals = [qAlex, qAmy] - WS.bracketR3 c alice alex amy $ \(wsAlice, wsAlex, wsAmy) -> do - let joiners = allRemotes <> otherLocals - unreachableBackends = - Set.fromList $ - foldMap - ( \rb -> - guard (rbReachable rb == BackendUnreachable) - $> tDomain rb - ) - rbs - (rsp, federatedRequests) <- - withTempMockFederator' - ( asum - [ getNotFullyConnectedBackendsMock, - mockUnreachableFor unreachableBackends, - "on-conversation-created" ~> EmptyResponse, - "on-conversation-updated" ~> EmptyResponse - ] - ) - $ postConvQualified - alice - Nothing - defNewProteusConv - { newConvName = checked convName, - newConvQualifiedUsers = joiners - } - minimalShouldBePresent) - qcid <- - assertConv - rsp - RegularConv - (Just alice) - qAlice - (otherLocals <> participatingRemotes) - (Just convName) - Nothing - let cid = qUnqualified qcid - cvs <- mapM (convView qcid) [alice, alex, amy] - liftIO $ - mapM_ WS.assertSuccess - =<< Async.mapConcurrently (checkWs qAlice) (zip cvs [wsAlice, wsAlex, wsAmy]) - - liftIO $ do - let expectedReqs = - Set.fromList $ - [ "on-conversation-created", - "on-conversation-updated" - ] - in assertBool "Some federated calls are missing" $ - expectedReqs `Set.isSubsetOf` Set.fromList (frRPC <$> federatedRequests) - - -- assertions on the conversation.create event triggering federation request - let fedReqsCreated = filter (\r -> frRPC r == "on-conversation-created") federatedRequests - fedReqCreatedBodies <- for fedReqsCreated $ assertRight . parseFedRequest - forM_ fedReqCreatedBodies $ \(fedReqCreatedBody :: ConversationCreated ConvId) -> liftIO $ do - fedReqCreatedBody.origUserId @?= alice - fedReqCreatedBody.cnvId @?= cid - fedReqCreatedBody.cnvType @?= RegularConv - fedReqCreatedBody.cnvAccess @?= [InviteAccess] - fedReqCreatedBody.cnvAccessRoles - @?= Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole, ServiceAccessRole] - fedReqCreatedBody.cnvName @?= Just convName - assertBool "Notifying an incorrect set of conversation members" $ - minimalShouldBePresentSet `Set.isSubsetOf` fedReqCreatedBody.nonCreatorMembers - fedReqCreatedBody.messageTimer @?= Nothing - fedReqCreatedBody.receiptMode @?= Nothing - - -- assertions on the conversation.member-join event triggering federation request - let fedReqsAdd = filter (\r -> frRPC r == "on-conversation-updated") federatedRequests - fedReqAddBodies <- for fedReqsAdd $ assertRight . parseFedRequest - forM_ fedReqAddBodies $ \(fedReqAddBody :: ConversationUpdate) -> liftIO $ do - fedReqAddBody.origUserId @?= qAlice - fedReqAddBody.convId @?= cid - -- This remote backend must already have their users in the conversation, - -- otherwise they should not be receiving the conversation update message - assertBool "The list of already present users should be non-empty" - . not - . null - $ fedReqAddBody.alreadyPresentUsers - case fedReqAddBody.action of - SomeConversationAction SConversationJoinTag _action -> pure () - _ -> assertFailure @() "Unexpected update action" - where - toOtherMember qid = OtherMember qid Nothing roleNameWireAdmin - convView cnv usr = - responseJsonError =<< getConvQualified usr cnv do - ntfTransient n @?= False - let e = List1.head (WS.unpackPayload n) - evtConv e @?= cnvQualifiedId cnv - evtType e @?= ConvCreate - evtFrom e @?= qalice - case evtData e of - EdConversation c' -> assertConvEquals cnv c' - _ -> assertFailure "Unexpected event data" - -- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies whether a message actually gets sent all the way to -- cannon. @@ -3553,137 +3436,6 @@ removeUserNoFederation = do (mems3 >>= other bob) @?= Nothing (mems3 >>= other carl) @?= Just (OtherMember carl Nothing roleNameWireAdmin) -removeUser :: TestM () -removeUser = do - c <- view tsCannon - [alice, alexDel, amy] <- replicateM 3 randomQualifiedUser - let [alice', alexDel', amy'] = qUnqualified <$> [alice, alexDel, amy] - - let bDomain = Domain "b.example.com" - bart <- randomQualifiedId bDomain - berta <- randomQualifiedId bDomain - - let cDomain = Domain "c.example.com" - carl <- randomQualifiedId cDomain - - let dDomain = Domain "d.example.com" - dwight <- randomQualifiedId dDomain - dory <- randomQualifiedId dDomain - - connectUsers alice' (list1 alexDel' [amy']) - connectWithRemoteUser alice' bart - connectWithRemoteUser alice' berta - connectWithRemoteUser alexDel' bart - connectWithRemoteUser alice' carl - connectWithRemoteUser alexDel' carl - connectWithRemoteUser alice' dwight - connectWithRemoteUser alexDel' dory - - qconvA1 <- decodeQualifiedConvId <$> postConv alice' [alexDel'] (Just "gossip") [] Nothing Nothing - qconvA2 <- decodeQualifiedConvId <$> postConvWithRemoteUsers alice' Nothing defNewProteusConv {newConvQualifiedUsers = [alexDel, amy, berta, dwight]} - qconvA3 <- decodeQualifiedConvId <$> postConv alice' [amy'] (Just "gossip3") [] Nothing Nothing - qconvA4 <- decodeQualifiedConvId <$> postConvWithRemoteUsers alice' Nothing defNewProteusConv {newConvQualifiedUsers = [alexDel, bart, carl]} - convB1 <- randomId -- a remote conversation at 'bDomain' that Alice, AlexDel and Bart will be in - convB2 <- randomId -- a remote conversation at 'bDomain' that AlexDel and Bart will be in - convC1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Carl will be in - convD1 <- randomId -- a remote conversation at 'cDomain' that AlexDel and Dory will be in - now <- liftIO getCurrentTime - fedGalleyClient <- view tsFedGalleyClient - let nc cid creator quids = - ConversationCreated - { time = now, - origUserId = qUnqualified creator, - cnvId = cid, - cnvType = RegularConv, - cnvAccess = [], - cnvAccessRoles = Set.fromList [], - cnvName = Just "gossip4", - nonCreatorMembers = Set.fromList $ createOtherMember <$> quids, - messageTimer = Nothing, - receiptMode = Nothing, - protocol = ProtocolProteus - } - void $ runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB1 bart [alice, alexDel] - void $ runFedClient @"on-conversation-created" fedGalleyClient bDomain $ nc convB2 bart [alexDel] - void $ runFedClient @"on-conversation-created" fedGalleyClient cDomain $ nc convC1 carl [alexDel] - void $ runFedClient @"on-conversation-created" fedGalleyClient dDomain $ nc convD1 dory [alexDel] - - WS.bracketR3 c alice' alexDel' amy' $ \(wsAlice, wsAlexDel, wsAmy) -> do - let handler = do - d <- frTargetDomain <$> getRequest - asum - [ do - guard (d == dDomain) - throw (DiscoveryFailureSrvNotAvailable "dDomain"), - do - guard (d `elem` [bDomain, cDomain]) - "leave-conversation" ~> LeaveConversationResponse (Right mempty) - ] - (_, fedRequests) <- - withTempMockFederator' handler $ - deleteUser alexDel' !!! const 200 === statusCode - - liftIO $ do - assertEqual ("expect exactly 4 federated requests in : " <> show fedRequests) 4 (length fedRequests) - - liftIO $ do - WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel] $ - wsAssertMembersLeave qconvA1 alexDel [alexDel] - WS.assertMatchN_ (5 # Second) [wsAlice, wsAlexDel, wsAmy] $ - wsAssertMembersLeave qconvA2 alexDel [alexDel] - - liftIO $ do - let bConvUpdateRPCs = filter (matchFedRequest bDomain "on-conversation-updated") fedRequests - bConvUpdates :: [ConversationUpdate] <- mapM (assertRight . eitherDecode . frBody) bConvUpdateRPCs - - bConvUpdatesA2 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA2) bConvUpdates - bConvUpdatesA2.origUserId @?= alexDel - bConvUpdatesA2.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () - bConvUpdatesA2.alreadyPresentUsers @?= [qUnqualified berta] - - bConvUpdatesA4 <- assertOne $ filter (\cu -> cu.convId == qUnqualified qconvA4) bConvUpdates - bConvUpdatesA4.origUserId @?= alexDel - bConvUpdatesA4.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () - bConvUpdatesA4.alreadyPresentUsers @?= [qUnqualified bart] - - liftIO $ do - cConvUpdateRPC <- assertOne $ filter (matchFedRequest cDomain "on-conversation-updated") fedRequests - Right (convUpdate :: ConversationUpdate) <- pure . eitherDecode . frBody $ cConvUpdateRPC - convUpdate.convId @?= qUnqualified qconvA4 - convUpdate.origUserId @?= alexDel - convUpdate.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () - convUpdate.alreadyPresentUsers @?= [qUnqualified carl] - - liftIO $ do - dConvUpdateRPC <- assertOne $ filter (matchFedRequest dDomain "on-conversation-updated") fedRequests - Right (convUpdate :: ConversationUpdate) <- pure . eitherDecode . frBody $ dConvUpdateRPC - convUpdate.convId @?= qUnqualified qconvA2 - convUpdate.origUserId @?= alexDel - convUpdate.action @?= SomeConversationAction (sing @'ConversationLeaveTag) () - convUpdate.alreadyPresentUsers @?= [qUnqualified dwight] - - -- Check memberships - mems1 <- fmap cnvMembers . responseJsonError =<< getConvQualified alice' qconvA1 - mems2 <- fmap cnvMembers . responseJsonError =<< getConvQualified alice' qconvA2 - mems3 <- fmap cnvMembers . responseJsonError =<< getConvQualified alice' qconvA3 - mems4 <- fmap cnvMembers . responseJsonError =<< getConvQualified alice' qconvA4 - let findOther u = find ((== u) . omQualifiedId) . cmOthers - liftIO $ do - findOther alexDel mems1 @?= Nothing - findOther alexDel mems2 @?= Nothing - findOther amy mems2 @?= Just (OtherMember amy Nothing roleNameWireAdmin) - findOther alexDel mems3 @?= Nothing - findOther amy mems3 @?= Just (OtherMember amy Nothing roleNameWireAdmin) - findOther alexDel mems4 @?= Nothing - where - createOtherMember :: Qualified UserId -> OtherMember - createOtherMember quid = - OtherMember - { omQualifiedId = quid, - omService = Nothing, - omConvRoleName = roleNameWireAdmin - } - testAllOne2OneConversationRequests :: TestM () testAllOne2OneConversationRequests = do for_ [LocalActor, RemoteActor] $ \actor -> From 2aad7993162d97fe44fded3afe4296faf42ebc0f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 29 Feb 2024 11:12:10 +0100 Subject: [PATCH 48/52] Remove commented out code Co-authored-by: Akshay Mankar --- services/background-worker/src/Wire/BackendNotificationPusher.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index a006af4ad71..859290c05bf 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -82,7 +82,6 @@ pushNotification runningFlag targetDomain (msg, envelope) = do UnliftIO.bracket_ (takeMVar runningFlag) (putMVar runningFlag ()) go where go :: AppT IO () - -- go = case A.eitherDecode @BackendNotification (Q.msgBody msg) of go = case A.eitherDecode @(PayloadBundle _) (Q.msgBody msg) of Left e -> do case A.eitherDecode @BackendNotification (Q.msgBody msg) of From af44567e731a6c74552d73fc75218547f24e0f54 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 1 Mar 2024 10:53:58 +0100 Subject: [PATCH 49/52] Refactor mock federator arguments --- .../background-worker/background-worker.cabal | 1 + services/background-worker/default.nix | 2 + .../Wire/BackendNotificationPusherSpec.hs | 12 +++--- .../brig/test/integration/Federation/Util.hs | 4 +- services/brig/test/integration/Util.hs | 4 +- services/cargohold/cargohold.cabal | 1 + services/cargohold/default.nix | 2 + .../cargohold/test/integration/API/Util.hs | 3 +- services/federator/default.nix | 1 + services/federator/federator.cabal | 1 + .../federator/src/Federator/MockServer.hs | 40 ++++++++++++------- .../test/unit/Test/Federator/Client.hs | 26 +++++------- services/galley/test/integration/API/Util.hs | 10 +++-- 13 files changed, 62 insertions(+), 45 deletions(-) diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index 35113550d00..ca464c1f75d 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -177,6 +177,7 @@ test-suite background-worker-test , base , bytestring , containers + , data-default , extended , federator , hspec diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index 2ff9f6086e3..a54a95e3419 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -8,6 +8,7 @@ , base , bytestring , containers +, data-default , exceptions , extended , federator @@ -80,6 +81,7 @@ mkDerivation { base bytestring containers + data-default extended federator hspec diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 838359d0da0..405a6a3ab8e 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -9,6 +9,7 @@ import Control.Monad.Trans.Except import Data.Aeson qualified as Aeson import Data.ByteString.Builder qualified as Builder import Data.ByteString.Lazy qualified as LBS +import Data.Default import Data.Domain import Data.Id import Data.Range @@ -52,7 +53,6 @@ spec :: Spec spec = do describe "pushNotification" $ do it "should push notifications" $ do - let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) let origDomain = Domain "origin.example.com" targetDomain = Domain "target.example.com" -- Just using 'arbitrary' could generate a very big list, making tests very @@ -76,7 +76,7 @@ spec = do } runningFlag <- newMVar () (env, fedReqs) <- - withTempMockFederator [] returnSuccess . runTestAppT $ do + withTempMockFederator def . runTestAppT $ do wait =<< pushNotification runningFlag targetDomain (msg, envelope) ask @@ -95,7 +95,6 @@ spec = do `shouldReturn` [(domainText targetDomain, 1)] it "should push notification bundles" $ do - let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) let origDomain = Domain "origin.example.com" targetDomain = Domain "target.example.com" -- Just using 'arbitrary' could generate a very big list, making tests very @@ -113,7 +112,7 @@ spec = do } runningFlag <- newMVar () (env, fedReqs) <- - withTempMockFederator [] returnSuccess . runTestAppT $ do + withTempMockFederator def . runTestAppT $ do wait =<< pushNotification runningFlag targetDomain (msg, envelope) ask @@ -132,7 +131,6 @@ spec = do `shouldReturn` [(domainText targetDomain, 1)] it "should reject invalid notifications" $ do - let returnSuccess _ = pure ("application/json", Aeson.encode EmptyResponse) envelope <- newMockEnvelope let msg = Q.newMsg @@ -141,7 +139,7 @@ spec = do } runningFlag <- newMVar () (env, fedReqs) <- - withTempMockFederator [] returnSuccess . runTestAppT $ do + withTempMockFederator def . runTestAppT $ do wait =<< pushNotification runningFlag (Domain "target.example.com") (msg, envelope) ask @@ -182,7 +180,7 @@ spec = do runningFlag <- newMVar () env <- testEnv pushThread <- - async $ withTempMockFederator [] mockRemote . runTestAppTWithEnv env $ do + async $ withTempMockFederator def {handler = mockRemote} . runTestAppTWithEnv env $ do wait =<< pushNotification runningFlag targetDomain (msg, envelope) -- Wait for two calls, so we can be sure that the metric about stuck diff --git a/services/brig/test/integration/Federation/Util.hs b/services/brig/test/integration/Federation/Util.hs index cb0eb3e35bb..4a1376e8686 100644 --- a/services/brig/test/integration/Federation/Util.hs +++ b/services/brig/test/integration/Federation/Util.hs @@ -35,6 +35,7 @@ import Data.Aeson (FromJSON, Value, decode, (.=)) import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS import Data.ByteString.Conversion (toByteString') +import Data.Default import Data.Domain (Domain (Domain)) import Data.Handle (fromHandle) import Data.Id @@ -79,8 +80,7 @@ import Wire.API.User.Client.Prekey withTempMockFederator :: Opt.Opts -> LByteString -> Session a -> IO (a, [Mock.FederatedRequest]) withTempMockFederator opts resp action = Mock.withTempMockFederator - [("Content-Type", "application/json")] - (const (pure ("application" // "json", resp))) + def {Mock.handler = const (pure ("application" // "json", resp))} $ \mockPort -> do let opts' = opts diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index 91cd6b674b6..46b8aa917c3 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -50,6 +50,7 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Char8 (pack) import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Conversion +import Data.Default import Data.Domain (Domain (..), domainText, mkDomain) import Data.Handle (Handle (..)) import Data.Id @@ -1231,8 +1232,7 @@ withMockedFederatorAndGalley opts _domain fedResp galleyHandler action = do result <- assertRight <=< runExceptT $ withTempMockedService initState galleyHandler $ \galleyMockState -> Mock.withTempMockFederator - [("Content-Type", "application/json")] - ((\r -> pure ("application" // "json", r)) <=< fedResp) + def {Mock.handler = (\r -> pure ("application" // "json", r)) <=< fedResp} $ \fedMockPort -> do let opts' = opts diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal index 7723b5814f9..f3c5ad95c44 100644 --- a/services/cargohold/cargohold.cabal +++ b/services/cargohold/cargohold.cabal @@ -269,6 +269,7 @@ executable cargohold-integration , cargohold , cargohold-types , containers + , data-default , federator , http-api-data , http-client >=0.7 diff --git a/services/cargohold/default.nix b/services/cargohold/default.nix index 9c9c13d493b..58b2e770a30 100644 --- a/services/cargohold/default.nix +++ b/services/cargohold/default.nix @@ -19,6 +19,7 @@ , conduit-extra , containers , crypton +, data-default , errors , exceptions , extended @@ -138,6 +139,7 @@ mkDerivation { bytestring-conversion cargohold-types containers + data-default federator HsOpenSSL http-api-data diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index 1c9e1057248..2c51dc9b29f 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -42,6 +42,7 @@ import Data.ByteString.Builder import qualified Data.ByteString.Char8 as C import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy +import Data.Default import Data.Id import Data.Qualified import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -223,7 +224,7 @@ withMockFederator :: TestM a -> TestM (a, [FederatedRequest]) withMockFederator respond action = do - withTempMockFederator [] respond $ \p -> + withTempMockFederator def {handler = respond} $ \p -> withSettingsOverrides (federator . _Just %~ setLocalEndpoint (fromIntegral p)) action diff --git a/services/federator/default.nix b/services/federator/default.nix index 0871b678a85..af4aa3d502b 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -88,6 +88,7 @@ mkDerivation { containers crypton-x509 crypton-x509-validation + data-default dns dns-util exceptions diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index fe6fa823004..dec1a6d01e1 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -115,6 +115,7 @@ library , containers , crypton-x509 , crypton-x509-validation + , data-default , dns , dns-util , exceptions diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index 81b657d9760..df461ab0473 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -19,6 +19,7 @@ module Federator.MockServer ( -- * Federator mock server + MockFederator (..), MockException (..), withTempMockFederator, FederatedRequest (..), @@ -44,6 +45,7 @@ import Control.Monad.Catch hiding (fromException) import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson qualified as Aeson +import Data.Default import Data.Domain import Data.Text qualified as Text import Data.Text.Lazy qualified as LText @@ -66,6 +68,7 @@ import Servant.API import Servant.Server (Tagged (..)) import Servant.Server.Generic import Wire.API.Federation.API (Component) +import Wire.API.Federation.API.Common import Wire.API.Federation.Domain import Wire.API.Federation.Version import Wire.Sem.Logger.TinyLog @@ -104,16 +107,15 @@ mockServer :: Member (Error ValidationError) r ) => IORef [FederatedRequest] -> - [HTTP.Header] -> - (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> + MockFederator -> (Sem r Wai.Response -> IO Wai.Response) -> API AsServer -mockServer remoteCalls headers resp interpreter = +mockServer remoteCalls mock interpreter = Federator.InternalServer.API { status = const $ pure NoContent, internalRequest = \_mReqId targetDomain component rpc -> Tagged $ \req respond -> - respond =<< interpreter (mockInternalRequest remoteCalls headers resp targetDomain component rpc req) + respond =<< interpreter (mockInternalRequest remoteCalls mock targetDomain component rpc req) } mockInternalRequest :: @@ -123,14 +125,13 @@ mockInternalRequest :: Member (Error ValidationError) r ) => IORef [FederatedRequest] -> - [HTTP.Header] -> - (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> + MockFederator -> Domain -> Component -> RPC -> Wai.Request -> Sem r Wai.Response -mockInternalRequest remoteCalls headers resp targetDomain component (RPC path) req = do +mockInternalRequest remoteCalls mock targetDomain component (RPC path) req = do domainTxt <- note NoOriginDomain $ lookup originDomainHeaderName (Wai.requestHeaders req) originDomain <- parseDomain domainTxt reqBody <- embed $ Wai.lazyRequestBody req @@ -150,15 +151,27 @@ mockInternalRequest remoteCalls headers resp targetDomain component (RPC path) r modifyIORef remoteCalls (<> [fedRequest]) fromException @MockException . handle (throw . handleException) - $ resp fedRequest - let headers' = ("Content-Type", HTTP.renderHeader ct) : headers - pure $ Wai.responseLBS HTTP.status200 headers' resBody + $ mock.handler fedRequest + let headers = ("Content-Type", HTTP.renderHeader ct) : mock.headers + pure $ Wai.responseLBS HTTP.status200 headers resBody where handleException :: SomeException -> MockException handleException e = case Exception.fromException e of Just mockE -> mockE Nothing -> MockErrorResponse HTTP.status500 (LText.pack (displayException e)) +data MockFederator = MockFederator + { headers :: [HTTP.Header], + handler :: FederatedRequest -> IO (HTTP.MediaType, LByteString) + } + +instance Default MockFederator where + def = + MockFederator + { headers = [], + handler = \_ -> pure ("application/json", Aeson.encode EmptyResponse) + } + -- | Spawn a mock federator on a random port and run an action while it is running. -- -- A mock federator is a web application that parses requests of the same form @@ -166,11 +179,10 @@ mockInternalRequest remoteCalls headers resp targetDomain component (RPC path) r -- forwarding them to a remote federator. withTempMockFederator :: (MonadIO m, MonadMask m) => - [HTTP.Header] -> - (FederatedRequest -> IO (HTTP.MediaType, LByteString)) -> + MockFederator -> (Warp.Port -> m a) -> m (a, [FederatedRequest]) -withTempMockFederator headers resp action = do +withTempMockFederator mock action = do remoteCalls <- newIORef [] let interpreter = runM @@ -180,7 +192,7 @@ withTempMockFederator headers resp action = do ServerError, MockException ] - app = genericServe (mockServer remoteCalls headers resp interpreter) + app = genericServe (mockServer remoteCalls mock interpreter) result <- bracket (liftIO (startMockServer Nothing app)) diff --git a/services/federator/test/unit/Test/Federator/Client.hs b/services/federator/test/unit/Test/Federator/Client.hs index 2b79f8ab2a1..6100252dbbe 100644 --- a/services/federator/test/unit/Test/Federator/Client.hs +++ b/services/federator/test/unit/Test/Federator/Client.hs @@ -26,6 +26,7 @@ import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import Data.ByteString.Lazy qualified as LBS +import Data.Default import Data.Domain import Data.Id import Data.Proxy @@ -60,9 +61,6 @@ targetDomain = Domain "target.example.com" originDomain :: Domain originDomain = Domain "origin.example.com" -defaultHeaders :: [HTTP.Header] -defaultHeaders = [("Content-Type", "application/json")] - tests :: TestTree tests = testGroup @@ -87,11 +85,10 @@ newtype ResponseFailure = ResponseFailure Wai.Error deriving (Show) withMockFederatorClient :: - [HTTP.Header] -> - (FederatedRequest -> IO (MediaType, LByteString)) -> + MockFederator -> FederatorClient c a -> IO (Either ResponseFailure a, [FederatedRequest]) -withMockFederatorClient headers resp action = withTempMockFederator headers resp $ \port -> do +withMockFederatorClient mock action = withTempMockFederator mock $ \port -> do mgr <- defaultHttp2Manager let env = FederatorClientEnv @@ -114,8 +111,7 @@ testClientSuccess = do (actualResponse, sentRequests) <- withMockFederatorClient - defaultHeaders - (const (pure ("application/json", Aeson.encode (Just expectedResponse)))) + def {handler = const (pure ("application/json", Aeson.encode (Just expectedResponse)))} $ fedClient @'Brig @"get-user-by-handle" handle sentRequests @@ -157,8 +153,7 @@ testClientFailure = do (actualResponse, _) <- withMockFederatorClient - defaultHeaders - (const (throw (MockErrorResponse HTTP.status422 "wrong domain"))) + def {handler = const (throw (MockErrorResponse HTTP.status422 "wrong domain"))} $ do fedClient @'Brig @"get-user-by-handle" handle @@ -174,8 +169,7 @@ testFederatorFailure = do (actualResponse, _) <- withMockFederatorClient - defaultHeaders - (const (throw (MockErrorResponse HTTP.status403 "invalid path"))) + def {handler = const (throw (MockErrorResponse HTTP.status403 "invalid path"))} $ do fedClient @'Brig @"get-user-by-handle" handle @@ -190,7 +184,7 @@ testClientExceptions = do handle <- generate arbitrary (response, _) <- - withMockFederatorClient defaultHeaders (const (evaluate (error "unhandled exception"))) $ + withMockFederatorClient def {handler = const (evaluate (error "unhandled exception"))} $ fedClient @'Brig @"get-user-by-handle" handle case response of @@ -218,8 +212,10 @@ testClientConnectionError = do testResponseHeaders :: IO () testResponseHeaders = do (r, _) <- withTempMockFederator - [("X-Foo", "bar")] - (const $ pure ("application" // "json", mempty)) + def + { headers = [("X-Foo", "bar")], + handler = const $ pure ("application" // "json", mempty) + } $ \port -> do let req = HTTP2.requestBuilder diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index b6227da8967..4de8b00e8df 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2676,11 +2676,13 @@ withTempMockFederator' :: m b -> m (b, [FederatedRequest]) withTempMockFederator' resp action = do - let mock = runMock (assertFailure . Text.unpack) $ do - r <- resp - pure ("application" // "json", r) + let mock = + def + { handler = runMock (assertFailure . Text.unpack) $ do + r <- resp + pure ("application" // "json", r) + } Mock.withTempMockFederator - [("Content-Type", "application/json")] mock $ \mockPort -> do withSettingsOverrides (\opts -> opts & Opts.federator ?~ Endpoint "127.0.0.1" (fromIntegral mockPort)) action From 0caa42d889a30b14cdeefdb9fb68bb08a4e21a3c Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 4 Mar 2024 09:42:31 +0100 Subject: [PATCH 50/52] Unit-test pusher version negotiation --- .../Wire/BackendNotificationPusherSpec.hs | 46 +++++++++++++++++++ .../federator/src/Federator/MockServer.hs | 8 ++-- 2 files changed, 51 insertions(+), 3 deletions(-) diff --git a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs index 405a6a3ab8e..472f02d1f2e 100644 --- a/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs +++ b/services/background-worker/test/Test/Wire/BackendNotificationPusherSpec.hs @@ -38,6 +38,7 @@ import Test.QuickCheck import Test.Wire.Util import UnliftIO.Async import Util.Options +import Wire.API.Conversation.Action import Wire.API.Federation.API import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Common @@ -130,6 +131,51 @@ spec = do getVectorWith env.backendNotificationMetrics.pushedCounter getCounter `shouldReturn` [(domainText targetDomain, 1)] + it "should negotiate the best version" $ do + let origDomain = Domain "origin.example.com" + targetDomain = Domain "target.example.com" + update <- generate $ do + now <- arbitrary + user <- arbitrary + convId <- arbitrary + pure + ConversationUpdate + { time = now, + origUserId = user, + convId = convId, + alreadyPresentUsers = [], + action = SomeConversationAction SConversationLeaveTag () + } + let update0 = conversationUpdateToV0 update + let bundle = + toBundle (RequestId "N/A") origDomain update + <> toBundle (RequestId "N/A") origDomain update0 + envelope <- newMockEnvelope + let msg = + Q.newMsg + { Q.msgBody = Aeson.encode bundle, + Q.msgContentType = Just "application/json" + } + runningFlag <- newMVar () + (env, fedReqs) <- + withTempMockFederator def {versions = [0, 2]} . runTestAppT $ do + wait =<< pushNotification runningFlag targetDomain (msg, envelope) + ask + + readIORef envelope.acks `shouldReturn` 1 + readIORef envelope.rejections `shouldReturn` [] + fedReqs + `shouldBe` [ FederatedRequest + { frTargetDomain = targetDomain, + frOriginDomain = origDomain, + frComponent = Galley, + frRPC = "on-conversation-updated", + frBody = Aeson.encode update0 + } + ] + getVectorWith env.backendNotificationMetrics.pushedCounter getCounter + `shouldReturn` [(domainText targetDomain, 1)] + it "should reject invalid notifications" $ do envelope <- newMockEnvelope let msg = diff --git a/services/federator/src/Federator/MockServer.hs b/services/federator/src/Federator/MockServer.hs index df461ab0473..463967531ba 100644 --- a/services/federator/src/Federator/MockServer.hs +++ b/services/federator/src/Federator/MockServer.hs @@ -146,7 +146,7 @@ mockInternalRequest remoteCalls mock targetDomain component (RPC path) req = do ) (ct, resBody) <- if path == "api-version" - then pure ("application/json", Aeson.encode versionInfo) + then pure ("application/json", Aeson.encode (VersionInfo mock.versions)) else do modifyIORef remoteCalls (<> [fedRequest]) fromException @MockException @@ -162,14 +162,16 @@ mockInternalRequest remoteCalls mock targetDomain component (RPC path) req = do data MockFederator = MockFederator { headers :: [HTTP.Header], - handler :: FederatedRequest -> IO (HTTP.MediaType, LByteString) + handler :: FederatedRequest -> IO (HTTP.MediaType, LByteString), + versions :: [Int] } instance Default MockFederator where def = MockFederator { headers = [], - handler = \_ -> pure ("application/json", Aeson.encode EmptyResponse) + handler = \_ -> pure ("application/json", Aeson.encode EmptyResponse), + versions = map versionInt (toList supportedVersions) } -- | Spawn a mock federator on a random port and run an action while it is running. From 83dcf79f08693cd42251d730506c7b4bf34b0352 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 4 Mar 2024 11:04:29 +0100 Subject: [PATCH 51/52] Ignore version mismatches when pushing This prevents the background worker from getting stuck when a remote backend is running an incompatible or broken instance. --- .../background-worker/background-worker.cabal | 1 + services/background-worker/default.nix | 1 + .../src/Wire/BackendNotificationPusher.hs | 25 ++++++++++++++++--- 3 files changed, 24 insertions(+), 3 deletions(-) diff --git a/services/background-worker/background-worker.cabal b/services/background-worker/background-worker.cabal index ca464c1f75d..36e566299da 100644 --- a/services/background-worker/background-worker.cabal +++ b/services/background-worker/background-worker.cabal @@ -50,6 +50,7 @@ library , types-common , unliftio , wai-utilities + , wire-api , wire-api-federation default-extensions: diff --git a/services/background-worker/default.nix b/services/background-worker/default.nix index a54a95e3419..31ce1fae0eb 100644 --- a/services/background-worker/default.nix +++ b/services/background-worker/default.nix @@ -72,6 +72,7 @@ mkDerivation { types-common unliftio wai-utilities + wire-api wire-api-federation ]; executableHaskellDepends = [ HsOpenSSL imports types-common ]; diff --git a/services/background-worker/src/Wire/BackendNotificationPusher.hs b/services/background-worker/src/Wire/BackendNotificationPusher.hs index 859290c05bf..7dfad1390f1 100644 --- a/services/background-worker/src/Wire/BackendNotificationPusher.hs +++ b/services/background-worker/src/Wire/BackendNotificationPusher.hs @@ -24,7 +24,9 @@ import UnliftIO import Wire.API.Federation.API import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client +import Wire.API.Federation.Error import Wire.API.Federation.Version +import Wire.API.RawJson import Wire.BackgroundWorker.Env import Wire.BackgroundWorker.Options import Wire.BackgroundWorker.Util @@ -116,7 +118,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do cveEnv = FederatorClientEnv {..} cveVersion = Just V0 -- V0 is assumed for non-versioned queue messages fcEnv = FederatorClientVersionedEnv {..} - liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body + sendNotificationIgnoringVersionMismatch fcEnv notif.targetComponent notif.path notif.body lift $ ack envelope metrics <- asks backendNotificationMetrics withLabel metrics.pushedCounter (domainText targetDomain) incCounter @@ -144,7 +146,7 @@ pushNotification runningFlag targetDomain (msg, envelope) = do >>= \case Left e -> do Log.err $ - Log.msg (Log.val "Failed to get supported API versions, the notification will be ignored") + Log.msg (Log.val "Failed to get supported API versions") . Log.field "domain" (domainText targetDomain) . Log.field "error" (displayException e) throwM e @@ -165,12 +167,29 @@ pushNotification runningFlag targetDomain (msg, envelope) = do ceOriginRequestId = fromMaybe (RequestId "N/A") notif.requestId cveEnv = FederatorClientEnv {..} fcEnv = FederatorClientVersionedEnv {..} - liftIO $ either throwM pure =<< sendNotification fcEnv notif.targetComponent notif.path notif.body + sendNotificationIgnoringVersionMismatch fcEnv notif.targetComponent notif.path notif.body lift $ ack envelope metrics <- asks backendNotificationMetrics withLabel metrics.pushedCounter (domainText targetDomain) incCounter withLabel metrics.stuckQueuesGauge (domainText targetDomain) (flip setGauge 0) +sendNotificationIgnoringVersionMismatch :: + FederatorClientVersionedEnv -> + Component -> + Text -> + RawJson -> + AppT IO () +sendNotificationIgnoringVersionMismatch env comp path body = + liftIO (sendNotification env comp path body) >>= \case + Left (FederatorClientVersionNegotiationError v) -> do + Log.fatal $ + Log.msg (Log.val "Federator version negotiation error") + . Log.field "domain" (domainText env.cveEnv.ceTargetDomain) + . Log.field "error" (show v) + pure () + Left e -> throwM e + Right () -> pure () + -- | Find the pair that maximises b. pairedMaximumOn :: Ord b => (a -> b) -> [a] -> (a, b) pairedMaximumOn f = maximumBy (compare `on` snd) . map (id &&& f) From f70d71370819befadbd7bf5b0194deb5942087ed Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 6 Mar 2024 13:35:16 +0100 Subject: [PATCH 52/52] Rename test case --- integration/test/Test/Conversation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/integration/test/Test/Conversation.hs b/integration/test/Test/Conversation.hs index b10668554d0..1d5587f40ae 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -851,8 +851,8 @@ testGuestLinksExpired = do bindResponse (getJoinCodeConv tm k v) $ \resp -> do resp.status `shouldMatchInt` 404 -testConversationWithV0 :: HasCallStack => App () -testConversationWithV0 = do +testConversationWithFedV0 :: HasCallStack => App () +testConversationWithFedV0 = do alice <- randomUser OwnDomain def bob <- randomUser FedV0Domain def withAPIVersion 4 $ connectTwoUsers alice bob