Refactor protocol update as conversation actions

changelog.d/5-internal/mixed-protocol

@@ -0,0 +1 @@
+Add intermediate "mixed" protocol for migrating from Proteus to MLS

integration/test/Test/MLS.hs

@@ -10,19 +10,29 @@ import SetupHelpers
 import Testlib.Prelude
 
 testMixedProtocolUpgrade :: HasCallStack => App ()
-testMixedProtocolUpgrade = do
-  [alice, bob] <- createAndConnectUsers [ownDomain, ownDomain]
+testMixedProtocolUpgrade = ptestMixedProtocolUpgrade ownDomain
+
+testMixedProtocolUpgradeFed :: HasCallStack => App ()
+testMixedProtocolUpgradeFed = ptestMixedProtocolUpgrade otherDomain
+
+ptestMixedProtocolUpgrade :: (HasCallStack, MakesValue domain) => domain -> App ()
+ptestMixedProtocolUpgrade secondDomain = do
+  [alice, bob, charlie] <- do
+    d <- ownDomain
+    d2 <- secondDomain & asString
+    createAndConnectUsers [d, d2, d2]
 
   qcnv <- postConversation alice defProteus {qualifiedUsers = [bob]} >>= getJSON 201
 
-  withWebSocket alice $ \wsAlice -> do
+  withWebSockets [alice, charlie] $ \websockets -> do
     bindResponse (putConversationProtocol bob qcnv "mixed") $ \resp -> do
       resp.status `shouldMatchInt` 200
       resp.json %. "conversation" `shouldMatch` (qcnv %. "id")
       resp.json %. "data.protocol" `shouldMatch` "mixed"
 
-    n <- awaitMatch 3 (\value -> nPayload value %. "type" `isEqual` "conversation.protocol-update") wsAlice
-    nPayload n %. "data.protocol" `shouldMatch` "mixed"
+    for_ websockets $ \ws -> do
+      n <- awaitMatch 3 (\value -> nPayload value %. "type" `isEqual` "conversation.protocol-update") ws
+      nPayload n %. "data.protocol" `shouldMatch` "mixed"
 
   bindResponse (getConversation alice qcnv) $ \resp -> do
     resp.status `shouldMatchInt` 200

libs/wire-api/src/Wire/API/Conversation/Action.hs

@@ -46,6 +46,7 @@ import Data.Time.Clock
 import Imports
 import Wire.API.Conversation
 import Wire.API.Conversation.Action.Tag
+import Wire.API.Conversation.Protocol (ProtocolTag)
 import Wire.API.Conversation.Role
 import Wire.API.Event.Conversation
 import Wire.API.MLS.SubConversation
@@ -63,6 +64,7 @@ type family ConversationAction (tag :: ConversationActionTag) :: Type where
   ConversationAction 'ConversationReceiptModeUpdateTag = ConversationReceiptModeUpdate
   ConversationAction 'ConversationAccessDataTag = ConversationAccessData
   ConversationAction 'ConversationRemoveMembersTag = NonEmptyList.NonEmpty (Qualified UserId)
+  ConversationAction 'ConversationUpdateProtocolTag = ProtocolTag
 
 data SomeConversationAction where
   SomeConversationAction :: Sing tag -> ConversationAction tag -> SomeConversationAction
@@ -105,6 +107,7 @@ conversationActionSchema SConversationRenameTag = schema
 conversationActionSchema SConversationMessageTimerUpdateTag = schema
 conversationActionSchema SConversationReceiptModeUpdateTag = schema
 conversationActionSchema SConversationAccessDataTag = schema
+conversationActionSchema SConversationUpdateProtocolTag = schema
 
 instance FromJSON SomeConversationAction where
   parseJSON = A.withObject "SomeConversationAction" $ \ob -> do
@@ -136,6 +139,7 @@ $( singletons
        conversationActionPermission ConversationMessageTimerUpdateTag = ModifyConversationMessageTimer
        conversationActionPermission ConversationReceiptModeUpdateTag = ModifyConversationReceiptMode
        conversationActionPermission ConversationAccessDataTag = ModifyConversationAccess
+       conversationActionPermission ConversationUpdateProtocolTag = LeaveConversation
        |]
  )
 
@@ -166,4 +170,5 @@ conversationActionToEvent tag now quid qcnv subconv action =
         SConversationMessageTimerUpdateTag -> EdConvMessageTimerUpdate action
         SConversationReceiptModeUpdateTag -> EdConvReceiptModeUpdate action
         SConversationAccessDataTag -> EdConvAccessUpdate action
+        SConversationUpdateProtocolTag -> EdProtocolUpdate action
    in Event qcnv subconv quid now edata

libs/wire-api/src/Wire/API/Conversation/Action/Tag.hs

@@ -38,6 +38,7 @@ data ConversationActionTag
   | ConversationMessageTimerUpdateTag
   | ConversationReceiptModeUpdateTag
   | ConversationAccessDataTag
+  | ConversationUpdateProtocolTag
   deriving (Show, Eq, Generic, Bounded, Enum)
 
 instance Arbitrary ConversationActionTag where
@@ -55,7 +56,8 @@ instance ToSchema ConversationActionTag where
           element "ConversationRenameTag" ConversationRenameTag,
           element "ConversationMessageTimerUpdateTag" ConversationMessageTimerUpdateTag,
           element "ConversationReceiptModeUpdateTag" ConversationReceiptModeUpdateTag,
-          element "ConversationAccessDataTag" ConversationAccessDataTag
+          element "ConversationAccessDataTag" ConversationAccessDataTag,
+          element "ConversationUpdateProtocolTag" ConversationUpdateProtocolTag
         ]
 
 instance ToJSON ConversationActionTag where

libs/wire-api/src/Wire/API/Event/Conversation.hs

@@ -81,6 +81,7 @@ import qualified Test.QuickCheck as QC
 import URI.ByteString ()
 import Wire.API.Conversation
 import Wire.API.Conversation.Code (ConversationCode (..), ConversationCodeInfo)
+import Wire.API.Conversation.Protocol (ProtocolUpdate (unProtocolUpdate))
 import qualified Wire.API.Conversation.Protocol as P
 import Wire.API.Conversation.Role
 import Wire.API.Conversation.Typing
@@ -179,7 +180,7 @@ data EventData
   | EdOtrMessage OtrMessage
   | EdMLSMessage ByteString
   | EdMLSWelcome ByteString
-  | EdProtocolUpdate P.ProtocolUpdate
+  | EdProtocolUpdate P.ProtocolTag
   deriving stock (Eq, Show, Generic)
 
 genEventData :: EventType -> QC.Gen EventData
@@ -400,7 +401,7 @@ taggedEventDataSchema =
       Typing -> tag _EdTyping (unnamed schema)
       ConvCodeDelete -> tag _EdConvCodeDelete null_
       ConvDelete -> tag _EdConvDelete null_
-      ProtocolUpdate -> tag _EdProtocolUpdate (unnamed schema)
+      ProtocolUpdate -> tag _EdProtocolUpdate (unnamed (unProtocolUpdate <$> P.ProtocolUpdate .= schema))
 
 instance ToSchema Event where
   schema = object "Event" eventObjectSchema

libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs

@@ -1253,7 +1253,8 @@ type ConversationAPI =
                :> Description "**Note**: Only proteus->mixed upgrade is supported."
                :> CanThrow 'ConvNotFound
                :> CanThrow 'ConvInvalidProtocolTransition
-               :> CanThrow 'ConvMemberNotFound
+               :> CanThrow ('ActionDenied 'LeaveConversation)
+               :> CanThrow 'InvalidOperation
                :> ZLocalUser
                :> ZConn
                :> "conversations"

libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/ConversationEvent.hs

@@ -44,5 +44,5 @@ testObject_Event_conversation_manual_2 =
       evtSubConv = Nothing,
       evtFrom = Qualified {qUnqualified = Id (fromJust (UUID.fromString "a471447c-aa30-4592-81b0-dec6c1c02bca")), qDomain = Domain {_domainText = "example.com"}},
       evtTime = UTCTime {utctDay = ModifiedJulianDay 58119, utctDayTime = 0},
-      evtData = EdProtocolUpdate (P.ProtocolUpdate P.ProtocolMixedTag)
+      evtData = EdProtocolUpdate P.ProtocolMixedTag
     }

services/galley/src/Galley/API/Action.hs

@@ -98,6 +98,7 @@ import Wire.API.Event.Conversation
 import Wire.API.Federation.API (Component (Galley), fedClient)
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Error
+import Wire.API.MLS.CipherSuite
 import Wire.API.Team.LegalHold
 import Wire.API.Team.Member
 import qualified Wire.API.User as User
@@ -209,6 +210,11 @@ type family HasConversationActionEffects (tag :: ConversationActionTag) r :: Con
     ( Member ConversationStore r,
       Member (Error NoChanges) r
     )
+  HasConversationActionEffects 'ConversationUpdateProtocolTag r =
+    ( Member ConversationStore r,
+      Member (ErrorS 'ConvInvalidProtocolTransition) r,
+      Member (Error NoChanges) r
+    )
 
 type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) :: EffectRow where
   HasConversationActionGalleyErrors 'ConversationJoinTag =
@@ -266,6 +272,12 @@ type family HasConversationActionGalleyErrors (tag :: ConversationActionTag) ::
        ErrorS 'InvalidTargetAccess,
        ErrorS 'ConvNotFound
      ]
+  HasConversationActionGalleyErrors 'ConversationUpdateProtocolTag =
+    '[ ErrorS ('ActionDenied 'LeaveConversation),
+       ErrorS 'InvalidOperation,
+       ErrorS 'ConvNotFound,
+       ErrorS 'ConvInvalidProtocolTransition
+     ]
 
 noChanges :: Member (Error NoChanges) r => Sem r a
 noChanges = throw NoChanges
@@ -384,6 +396,18 @@ performAction tag origUser lconv action = do
     SConversationAccessDataTag -> do
       (bm, act) <- performConversationAccessData origUser lconv action
       pure (bm, act)
+    SConversationUpdateProtocolTag -> do
+      case (protocolTag (convProtocol (tUnqualified lconv)), action) of
+        (ProtocolProteusTag, ProtocolMixedTag) -> do
+          E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519
+          pure (mempty, action)
+        (ProtocolProteusTag, ProtocolProteusTag) ->
+          noChanges
+        (ProtocolMixedTag, ProtocolMixedTag) ->
+          noChanges
+        (ProtocolMLSTag, ProtocolMLSTag) ->
+          noChanges
+        (_, _) -> throwS @'ConvInvalidProtocolTransition
 
 performConversationJoin ::
   ( HasConversationActionEffects 'ConversationJoinTag r

services/galley/src/Galley/API/Federation.hs

@@ -522,6 +522,11 @@ updateConversation origDomain updateRequest = do
           @(HasConversationActionGalleyErrors 'ConversationAccessDataTag)
           . fmap lcuUpdate
           $ updateLocalConversation @'ConversationAccessDataTag lcnv (tUntagged rusr) Nothing action
+      SConversationUpdateProtocolTag ->
+        mapToGalleyError
+          @(HasConversationActionGalleyErrors 'ConversationUpdateProtocolTag)
+          . fmap lcuUpdate
+          $ updateLocalConversation @'ConversationUpdateProtocolTag lcnv (tUntagged rusr) Nothing action
   where
     mkResponse = fmap toResponse . runError @GalleyError . runError @NoChanges
 

services/galley/src/Galley/API/Update.hs

@@ -133,7 +133,6 @@ import Wire.API.Connection (Relation (Accepted))
 import Wire.API.Conversation hiding (Member)
 import Wire.API.Conversation.Action
 import Wire.API.Conversation.Code
-import Wire.API.Conversation.Protocol (ProtocolTag (..), protocolTag)
 import qualified Wire.API.Conversation.Protocol as P
 import Wire.API.Conversation.Role
 import Wire.API.Conversation.Typing
@@ -144,7 +143,6 @@ import Wire.API.Federation.API
 import Wire.API.Federation.API.Galley
 import qualified Wire.API.Federation.API.Galley as F
 import Wire.API.Federation.Error
-import Wire.API.MLS.CipherSuite
 import Wire.API.Message
 import Wire.API.Password (mkSafePassword)
 import Wire.API.Provider.Service (ServiceRef)
@@ -355,7 +353,9 @@ updateConversationReceiptMode lusr zcon qcnv update =
             (Just zcon)
             update
     )
-    (\rcnv -> updateRemoteConversation @'ConversationReceiptModeUpdateTag rcnv lusr zcon update)
+    ( \rcnv ->
+        updateRemoteConversation @'ConversationReceiptModeUpdateTag rcnv lusr zcon update
+    )
     qcnv
 
 updateRemoteConversation ::
@@ -367,7 +367,7 @@ updateRemoteConversation ::
     Member (Input (Local ())) r,
     Member MemberStore r,
     Member TinyLog r,
-    RethrowErrors (HasConversationActionGalleyErrors tag) (Error NoChanges : r),
+    RethrowErrors (HasConversationActionGalleyErrors tag) r,
     SingI tag
   ) =>
   Remote ConvId ->
@@ -385,7 +385,7 @@ updateRemoteConversation rcnv lusr conn action = getUpdateResult $ do
   response <- E.runFederated rcnv (fedClient @'Galley @"update-conversation" updateRequest)
   convUpdate <- case response of
     ConversationUpdateResponseNoChanges -> throw NoChanges
-    ConversationUpdateResponseError err' -> rethrowErrors @(HasConversationActionGalleyErrors tag) err'
+    ConversationUpdateResponseError err' -> raise $ rethrowErrors @(HasConversationActionGalleyErrors tag) err'
     ConversationUpdateResponseUpdate convUpdate -> pure convUpdate
 
   updateLocalStateOfRemoteConv (tDomain rcnv) convUpdate
@@ -697,59 +697,40 @@ updateConversationProtocolWithLocalUser ::
   forall r.
   ( Member (ErrorS 'ConvNotFound) r,
     Member (ErrorS 'ConvInvalidProtocolTransition) r,
-    Member (ErrorS 'ConvMemberNotFound) r,
+    Member (ErrorS ('ActionDenied 'LeaveConversation)) r,
+    Member (ErrorS 'InvalidOperation) r,
     Member (Error FederationError) r,
     Member (Input UTCTime) r,
+    Member (Input (Local ())) r,
+    Member BrigAccess r,
+    Member MemberStore r,
+    Member TinyLog r,
     Member GundeckAccess r,
     Member ExternalAccess r,
+    Member FederatorAccess r,
+    Member SubConversationStore r,
     Member ConversationStore r
   ) =>
   Local UserId ->
   ConnId ->
   Qualified ConvId ->
   P.ProtocolUpdate ->
   Sem r (UpdateResult Event)
-updateConversationProtocolWithLocalUser lusr conn qcnv update =
+updateConversationProtocolWithLocalUser lusr conn qcnv (P.ProtocolUpdate newProtocol) =
   foldQualified
     lusr
-    (\lcnv -> updateLocalConversationProtocol (tUntagged lusr) (Just conn) lcnv update)
-    (\_rcnv -> throw FederationNotImplemented)
+    ( \lcnv -> do
+        fmap (maybe Unchanged (Updated . lcuEvent) . hush)
+          . runError @NoChanges
+          . updateLocalConversation @'ConversationUpdateProtocolTag lcnv (tUntagged lusr) (Just conn)
+          $ newProtocol
+    )
+    ( \rcnv ->
+        updateRemoteConversation @'ConversationUpdateProtocolTag rcnv lusr conn $
+          newProtocol
+    )
     qcnv
 
-updateLocalConversationProtocol ::
-  forall r.
-  ( Member (ErrorS 'ConvNotFound) r,
-    Member (ErrorS 'ConvInvalidProtocolTransition) r,
-    Member (ErrorS 'ConvMemberNotFound) r,
-    Member (Input UTCTime) r,
-    Member GundeckAccess r,
-    Member ExternalAccess r,
-    Member ConversationStore r
-  ) =>
-  Qualified UserId ->
-  Maybe ConnId ->
-  Local ConvId ->
-  P.ProtocolUpdate ->
-  Sem r (UpdateResult Event)
-updateLocalConversationProtocol qusr mconn lcnv protocolUpdate@(P.ProtocolUpdate newProtocol) = do
-  conv <- E.getConversation (tUnqualified lcnv) >>= noteS @'ConvNotFound
-  void $ ensureOtherMember lcnv qusr conv
-  case (protocolTag (convProtocol conv), newProtocol) of
-    (ProtocolProteusTag, ProtocolMixedTag) -> do
-      E.updateToMixedProtocol lcnv MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519
-      let (bots, users) = localBotsAndUsers $ Data.convLocalMembers conv
-      now <- input
-      let e = Event (tUntagged lcnv) Nothing qusr now (EdProtocolUpdate protocolUpdate)
-      pushConversationEvent mconn e (qualifyAs lcnv (map lmId users)) bots
-      pure (Updated e)
-    (ProtocolProteusTag, ProtocolProteusTag) ->
-      pure Unchanged
-    (ProtocolMixedTag, ProtocolMixedTag) ->
-      pure Unchanged
-    (ProtocolMLSTag, ProtocolMLSTag) ->
-      pure Unchanged
-    (_, _) -> throwS @'ConvInvalidProtocolTransition
-
 joinConversationByReusableCode ::
   forall db r.
   ( Member BrigAccess r,
@@ -1750,6 +1731,7 @@ updateLocalStateOfRemoteConv requestingDomain cu = do
       SConversationMessageTimerUpdateTag -> pure (Just sca, [])
       SConversationReceiptModeUpdateTag -> pure (Just sca, [])
       SConversationAccessDataTag -> pure (Just sca, [])
+      SConversationUpdateProtocolTag -> pure (Just sca, [])
 
   unless allUsersArePresent $
     P.warn $

services/galley/test/integration/API/Federation.hs

@@ -1247,3 +1247,5 @@ getConvAction tquery (SomeConversationAction tag action) =
     (SConversationAccessDataTag, _) -> Nothing
     (SConversationRemoveMembersTag, SConversationRemoveMembersTag) -> Just action
     (SConversationRemoveMembersTag, _) -> Nothing
+    (SConversationUpdateProtocolTag, SConversationUpdateProtocolTag) -> Just action
+    (SConversationUpdateProtocolTag, _) -> Nothing