Refactor conversation actions to enable dedicated effect sets for eac…

…h action (#2173) Use a tagged existential type and a type family to provide a dedicated list of effects for each conversation action. Previously, actions were represented by a sum type. The replacement is a (logical) pair of a tag and an accompanying action type. Co-authored-by: Sven Tennie <[email protected]> Co-authored-by: Paolo Capriotti <[email protected]>
wireapp · Mar 18, 2022 · 2209bfa · 2209bfa
1 parent f37e36f
commit 2209bfa
Show file tree

Hide file tree

Showing 21 changed files with 835 additions and 573 deletions.
diff --git a/changelog.d/6-federation/refactor-federated-conversation-actions b/changelog.d/6-federation/refactor-federated-conversation-actions
@@ -0,0 +1,8 @@
+Refactor conversation actions to an existential type consisting of a singleton
+tag (identifying the action) and a dedicated type for the action itself.
+Previously, actions were represented by a big sum type. The new approach
+enables us to describe the needed effects of an action much more precisely.
+The existential type is initialized by the Servant endpoints in a way to
+mimic the previous behavior. However, the messages between services changed.
+Thus, all federated backends need to run the same (new) version. The
+deployment order itself does not matter.
diff --git a/libs/wire-api-federation/package.yaml b/libs/wire-api-federation/package.yaml
@@ -34,6 +34,7 @@ dependencies:
 - servant-client
 - servant-client-core
 - servant-server
+- singletons
 - sop-core
 - streaming-commons
 - template-haskell

diff --git a/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs b/libs/wire-api-federation/src/Wire/API/Federation/API/Galley.hs
@@ -138,11 +138,13 @@ data ConversationUpdate = ConversationUpdate
     -- conversation to users.
     cuAlreadyPresentUsers :: [UserId],
     -- | Information on the specific action that caused the update.
-    cuAction :: ConversationAction
+    cuAction :: SomeConversationAction
   }
-  deriving stock (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform ConversationUpdate)
-  deriving (ToJSON, FromJSON) via (CustomEncoded ConversationUpdate)
+  deriving (Eq, Show, Generic)
+
+instance ToJSON ConversationUpdate
+
+instance FromJSON ConversationUpdate
 
 data LeaveConversationRequest = LeaveConversationRequest
   { -- | The conversation is assumed to be owned by the target domain, which

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
@@ -25,8 +25,10 @@ import Data.Domain (Domain (Domain))
 import Data.Id (Id (Id), UserId)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Qualified (Qualified (Qualified))
+import Data.Singletons (sing)
 import qualified Data.UUID as UUID
 import Imports
+import Wire.API.Conversation
 import Wire.API.Conversation.Action
 import Wire.API.Conversation.Role (roleNameWireAdmin)
 import Wire.API.Federation.API.Galley (ConversationUpdate (..))
@@ -56,7 +58,7 @@ testObject_ConversationUpdate1 =
       cuConvId =
         Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")),
       cuAlreadyPresentUsers = [],
-      cuAction = ConversationActionAddMembers (qAlice :| [qBob]) roleNameWireAdmin
+      cuAction = SomeConversationAction (sing @'ConversationJoinTag) (ConversationJoin (qAlice :| [qBob]) roleNameWireAdmin)
     }
 
 testObject_ConversationUpdate2 :: ConversationUpdate
@@ -70,5 +72,5 @@ testObject_ConversationUpdate2 =
       cuConvId =
         Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000006")),
       cuAlreadyPresentUsers = [chad, dee],
-      cuAction = ConversationActionRemoveMembers (pure qAlice)
+      cuAction = SomeConversationAction (sing @'ConversationLeaveTag) (pure qAlice)
     }
diff --git a/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json b/libs/wire-api-federation/test/golden/testObject_ConversationUpdate1.json
@@ -1,14 +1,8 @@
 {
-    "orig_user_id": {
-        "domain": "golden.example.com",
-        "id": "00000000-0000-0000-0000-000100000007"
-    },
-    "already_present_users": [],
-    "time": "1864-04-12T12:22:43.673Z",
-    "action": {
-        "tag": "ConversationActionAddMembers",
-        "contents": [
-            [
+    "cuAction": {
+        "action": {
+            "role": "wire_admin",
+            "users": [
                 {
                     "domain": "golden.example.com",
                     "id": "00000000-0000-0000-0000-000100004007"
@@ -17,9 +11,15 @@
                     "domain": "golden2.example.com",
                     "id": "00000000-0000-0000-0000-000100005007"
                 }
-            ],
-            "wire_admin"
-        ]
+            ]
+        },
+        "tag": "ConversationJoinTag"
+    },
+    "cuAlreadyPresentUsers": [],
+    "cuConvId": "00000000-0000-0000-0000-000100000006",
+    "cuOrigUserId": {
+        "domain": "golden.example.com",
+        "id": "00000000-0000-0000-0000-000100000007"
     },
-    "conv_id": "00000000-0000-0000-0000-000100000006"
+    "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
@@ -1,21 +1,23 @@
 {
-    "orig_user_id": {
-        "domain": "golden.example.com",
-        "id": "00000000-0000-0000-0000-000100000007"
+    "cuAction": {
+        "action": {
+            "users": [
+                {
+                    "domain": "golden.example.com",
+                    "id": "00000000-0000-0000-0000-000100004007"
+                }
+            ]
+        },
+        "tag": "ConversationLeaveTag"
     },
-    "already_present_users": [
+    "cuAlreadyPresentUsers": [
         "00000fff-0000-0000-0000-000100005007",
         "00000fff-0000-aaaa-0000-000100005007"
     ],
-    "time": "1864-04-12T12:22:43.673Z",
-    "action": {
-        "tag": "ConversationActionRemoveMembers",
-        "contents": [
-            {
-                "domain": "golden.example.com",
-                "id": "00000000-0000-0000-0000-000100004007"
-            }
-        ]
+    "cuConvId": "00000000-0000-0000-0000-000100000006",
+    "cuOrigUserId": {
+        "domain": "golden.example.com",
+        "id": "00000000-0000-0000-0000-000100000007"
     },
-    "conv_id": "00000000-0000-0000-0000-000100000006"
+    "cuTime": "1864-04-12T12:22:43.673Z"
 }
diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal
@@ -97,6 +97,7 @@ library
     , servant-client
     , servant-client-core
     , servant-server
+    , singletons
     , sop-core
     , streaming-commons
     , template-haskell
@@ -197,6 +198,7 @@ test-suite spec
     , servant-client
     , servant-client-core
     , servant-server
+    , singletons
     , sop-core
     , streaming-commons
     , template-haskell

diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs
@@ -71,6 +71,8 @@ module Wire.API.Conversation
     ConversationAccessData (..),
     ConversationReceiptModeUpdate (..),
     ConversationMessageTimerUpdate (..),
+    ConversationJoin (..),
+    ConversationMemberUpdate (..),
 
     -- * re-exports
     module Wire.API.Conversation.Member,
@@ -897,3 +899,37 @@ modelConversationMessageTimerUpdate = Doc.defineModel "ConversationMessageTimerU
   Doc.description "Contains conversation properties to update"
   Doc.property "message_timer" Doc.int64' $
     Doc.description "Conversation message timer (in milliseconds); can be null"
+
+data ConversationJoin = ConversationJoin
+  { cjUsers :: NonEmpty (Qualified UserId),
+    cjRole :: RoleName
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform ConversationJoin)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationJoin
+
+instance ToSchema ConversationJoin where
+  schema =
+    objectWithDocModifier
+      "ConversationJoin"
+      (description ?~ "The action of some users joining a conversation")
+      $ ConversationJoin
+        <$> cjUsers .= field "users" (nonEmptyArray schema)
+        <*> cjRole .= field "role" schema
+
+data ConversationMemberUpdate = ConversationMemberUpdate
+  { cmuTarget :: Qualified UserId,
+    cmuUpdate :: OtherMemberUpdate
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform ConversationMemberUpdate)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema ConversationMemberUpdate
+
+instance ToSchema ConversationMemberUpdate where
+  schema =
+    objectWithDocModifier
+      "ConversationMemberUpdate"
+      (description ?~ "The action of promoting/demoting a member of a conversation")
+      $ ConversationMemberUpdate
+        <$> cmuTarget .= field "target" schema
+        <*> cmuUpdate .= field "update" schema