diff --git a/changelog.d/5-internal/notification-client-refactor b/changelog.d/5-internal/notification-client-refactor new file mode 100644 index 0000000000..7fa385dc64 --- /dev/null +++ b/changelog.d/5-internal/notification-client-refactor @@ -0,0 +1 @@ +Simplify the definition of the servant notification API 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 b1859df233..a5d7c71d03 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/API.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/API.hs @@ -40,12 +40,10 @@ import Data.Proxy import GHC.TypeLits import Imports import Network.AMQP -import Servant import Servant.Client import Servant.Client.Core import Wire.API.Federation.API.Brig import Wire.API.Federation.API.Cargohold -import Wire.API.Federation.API.Common import Wire.API.Federation.API.Galley import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Client @@ -71,20 +69,6 @@ type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name) -- you to forget about some federated calls. type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi comp) name --- | Constrains which endpoints can be used with FedQueueClient. --- --- Since the servant client implementation underlying FedQueueClient is --- returning a "fake" response consisting of an empty object, we need to make --- sure that an API type is compatible with an empty response if we want to --- invoke it using `fedQueueClient` -class HasEmptyResponse api - -instance HasEmptyResponse (Post '[JSON] EmptyResponse) - -instance HasEmptyResponse api => HasEmptyResponse (x :> api) - -instance HasEmptyResponse api => HasEmptyResponse (UntypedNamed name api) - -- | Return a client for a named endpoint. -- -- This function introduces an 'AddAnnotation' constraint, which is @@ -99,18 +83,14 @@ fedClient :: fedClient = clientIn (Proxy @api) (Proxy @m) fedQueueClient :: - forall tag api. + forall {k} (tag :: k). ( HasNotificationEndpoint tag, - -- FUTUREWORK: Include this API constraint and get it working - -- api ~ NotificationAPI tag (NotificationComponent tag), - HasEmptyResponse api, KnownSymbol (NotificationPath tag), - KnownComponent (NotificationComponent tag), - ToJSON (Payload tag), - HasFedEndpoint (NotificationComponent tag) api (NotificationPath tag) + KnownComponent (NotificationComponent k), + ToJSON (Payload tag) ) => Payload tag -> - FedQueueClient (NotificationComponent tag) () + FedQueueClient (NotificationComponent k) () fedQueueClient payload = do env <- ask let notif = fedNotifToBackendNotif @tag env.originDomain payload 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 884b0c485e..931febcf4b 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 @@ -43,17 +43,15 @@ data UserDeletedConnectionsNotification = UserDeletedConnectionsNotification data BrigNotificationTag = OnUserDeletedConnectionsTag deriving (Show, Eq, Generic, Bounded, Enum) +instance IsNotificationTag BrigNotificationTag where + type NotificationComponent _ = 'Brig + instance HasNotificationEndpoint 'OnUserDeletedConnectionsTag where type Payload 'OnUserDeletedConnectionsTag = UserDeletedConnectionsNotification type NotificationPath 'OnUserDeletedConnectionsTag = "on-user-deleted-connections" - type NotificationComponent 'OnUserDeletedConnectionsTag = 'Brig - type - NotificationAPI 'OnUserDeletedConnectionsTag 'Brig = - NotificationFedEndpoint 'OnUserDeletedConnectionsTag instance ToSchema UserDeletedConnectionsNotification -- | All the notification endpoints return an 'EmptyResponse'. type BrigNotificationAPI = - -- FUTUREWORK: Use NotificationAPI 'OnUserDeletedConnectionsTag 'Brig instead NotificationFedEndpoint 'OnUserDeletedConnectionsTag 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 3485a60c1c..9f9e1ee589 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 @@ -35,7 +35,6 @@ import Wire.API.Federation.Component import Wire.API.Federation.Endpoint import Wire.API.Federation.HasNotificationEndpoint import Wire.API.MLS.SubConversation -import Wire.API.MakesFederatedCall import Wire.API.Message import Wire.API.Util.Aeson import Wire.Arbitrary @@ -48,63 +47,40 @@ data GalleyNotificationTag | OnUserDeletedConversationsTag deriving (Show, Eq, Generic, Bounded, Enum) +instance IsNotificationTag GalleyNotificationTag where + type NotificationComponent _ = 'Galley + instance HasNotificationEndpoint 'OnClientRemovedTag where type Payload 'OnClientRemovedTag = ClientRemovedRequest type NotificationPath 'OnClientRemovedTag = "on-client-removed" - type NotificationComponent 'OnClientRemovedTag = 'Galley - type - NotificationAPI 'OnClientRemovedTag 'Galley = - NotificationFedEndpointWithMods - '[ MakesFederatedCall 'Galley "on-mls-message-sent" - ] - (NotificationPath 'OnClientRemovedTag) - (Payload 'OnClientRemovedTag) +-- 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" - type NotificationComponent 'OnMessageSentTag = 'Galley - - -- used to notify this backend that a new message has been posted to a - -- remote conversation - type NotificationAPI 'OnMessageSentTag 'Galley = NotificationFedEndpoint 'OnMessageSentTag instance HasNotificationEndpoint 'OnMLSMessageSentTag where type Payload 'OnMLSMessageSentTag = RemoteMLSMessage type NotificationPath 'OnMLSMessageSentTag = "on-mls-message-sent" - type NotificationComponent 'OnMLSMessageSentTag = 'Galley - type NotificationAPI 'OnMLSMessageSentTag 'Galley = NotificationFedEndpoint 'OnMLSMessageSentTag +-- 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" - type NotificationComponent 'OnConversationUpdatedTag = 'Galley - - -- used by the backend that owns a conversation to inform this backend of - -- changes to the conversation - type NotificationAPI 'OnConversationUpdatedTag 'Galley = NotificationFedEndpoint 'OnConversationUpdatedTag instance HasNotificationEndpoint 'OnUserDeletedConversationsTag where type Payload 'OnUserDeletedConversationsTag = UserDeletedConversationsNotification type NotificationPath 'OnUserDeletedConversationsTag = "on-user-deleted-conversations" - type NotificationComponent 'OnUserDeletedConversationsTag = 'Galley - type - NotificationAPI 'OnUserDeletedConversationsTag 'Galley = - NotificationFedEndpointWithMods - '[ MakesFederatedCall 'Galley "on-mls-message-sent", - MakesFederatedCall 'Galley "on-conversation-updated", - MakesFederatedCall 'Brig "api-version" - ] - (NotificationPath 'OnUserDeletedConversationsTag) - (Payload 'OnUserDeletedConversationsTag) -- | All the notification endpoints return an 'EmptyResponse'. type GalleyNotificationAPI = - NotificationAPI 'OnClientRemovedTag 'Galley - :<|> NotificationAPI 'OnMessageSentTag 'Galley - :<|> NotificationAPI 'OnMLSMessageSentTag 'Galley - :<|> NotificationAPI 'OnConversationUpdatedTag 'Galley - :<|> NotificationAPI 'OnUserDeletedConversationsTag 'Galley + NotificationFedEndpoint 'OnClientRemovedTag + :<|> NotificationFedEndpoint 'OnMessageSentTag + :<|> NotificationFedEndpoint 'OnMLSMessageSentTag + :<|> NotificationFedEndpoint 'OnConversationUpdatedTag + :<|> NotificationFedEndpoint 'OnUserDeletedConversationsTag data ClientRemovedRequest = ClientRemovedRequest { user :: UserId, 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 d9d147b6fc..c698d39c14 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/HasNotificationEndpoint.hs @@ -28,6 +28,9 @@ import Wire.API.Federation.BackendNotifications import Wire.API.Federation.Component import Wire.API.RawJson +class IsNotificationTag k where + type NotificationComponent k = (c :: Component) | c -> k + class HasNotificationEndpoint t where -- | The type of the payload for this endpoint type Payload t :: Type @@ -36,18 +39,12 @@ class HasNotificationEndpoint t where -- "on-conversation-updated". type NotificationPath t :: Symbol - -- | The server component this endpoint is associated with - type NotificationComponent t :: Component - - -- | The Servant API endpoint type - type NotificationAPI t (c :: Component) :: Type - -- | Convert a federation endpoint to a backend notification to be enqueued to a -- RabbitMQ queue. fedNotifToBackendNotif :: - forall tag. + forall {k} (tag :: k). KnownSymbol (NotificationPath tag) => - KnownComponent (NotificationComponent tag) => + KnownComponent (NotificationComponent k) => ToJSON (Payload tag) => Domain -> Payload tag -> @@ -61,7 +58,7 @@ fedNotifToBackendNotif ownDomain payload = toNotif path body = BackendNotification { ownDomain = ownDomain, - targetComponent = componentVal @(NotificationComponent tag), + targetComponent = componentVal @(NotificationComponent k), path = path, body = body } diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 23a7280bdf..68af385e8d 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -116,11 +116,11 @@ federationSitemap = :<|> Named @"delete-sub-conversation" (callsFed deleteSubConversationForRemoteUser) :<|> Named @"leave-sub-conversation" (callsFed leaveSubConversation) :<|> Named @"get-one2one-conversation" getOne2OneConversation - :<|> Named @"on-client-removed" (callsFed (exposeAnnotations onClientRemoved)) + :<|> Named @"on-client-removed" onClientRemoved :<|> Named @"on-message-sent" onMessageSent :<|> Named @"on-mls-message-sent" onMLSMessageSent :<|> Named @"on-conversation-updated" onConversationUpdated - :<|> Named @"on-user-deleted-conversations" (callsFed (exposeAnnotations onUserDeleted)) + :<|> Named @"on-user-deleted-conversations" onUserDeleted onClientRemoved :: ( Member BackendNotificationQueueAccess r,