[FS-925] Add endpoint to create MLS self-conversation

changelog.d/1-api-changes/mls-self-conversation

@@ -0,0 +1 @@
+Support MLS self-conversations via a new endpoint `PUT /conversations/mls-self`

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

@@ -44,6 +44,7 @@ module Wire.API.Conversation
     pattern ConversationPagingState,
     ConversationsResponse (..),
     GroupId (..),
+    mlsSelfConvId,
 
     -- * Conversation properties
     Access (..),
@@ -97,6 +98,7 @@ import Control.Applicative
 import Control.Lens (at, (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as LBS
 import Data.Id
 import Data.List.Extra (disjointOrd)
 import Data.List.NonEmpty (NonEmpty)
@@ -110,6 +112,8 @@ import qualified Data.Set as Set
 import Data.String.Conversions (cs)
 import qualified Data.Swagger as S
 import qualified Data.Swagger.Build.Api as Doc
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V5 as UUIDV5
 import Imports
 import System.Random (randomRIO)
 import Wire.API.Conversation.Member
@@ -934,3 +938,14 @@ instance ToSchema ConversationMemberUpdate where
       $ ConversationMemberUpdate
         <$> cmuTarget .= field "target" schema
         <*> cmuUpdate .= field "update" schema
+
+-- | The id of the MLS self conversation for a given user
+mlsSelfConvId :: UserId -> ConvId
+mlsSelfConvId uid =
+  let inputBytes = LBS.unpack . UUID.toByteString . toUUID $ uid
+   in Id (UUIDV5.generateNamed namespaceMLSSelfConv inputBytes)
+
+namespaceMLSSelfConv :: UUID.UUID
+namespaceMLSSelfConv =
+  -- a V5 uuid created with the nil namespace
+  fromJust . UUID.fromString $ "3eac2a2c-3850-510b-bd08-8a98e80dd4d9"

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

@@ -75,9 +75,9 @@ type ConversationResponse = ResponseForExistedCreated Conversation
 
 type ConversationHeaders = '[DescHeader "Location" "Conversation ID" ConvId]
 
-type ConversationVerb =
+type ConversationVerbWithMethod (m :: StdMethod) =
   MultiVerb
-    'POST
+    m
     '[JSON]
     '[ WithHeaders
          ConversationHeaders
@@ -90,6 +90,10 @@ type ConversationVerb =
      ]
     ConversationResponse
 
+type ConversationVerb = ConversationVerbWithMethod 'POST
+
+type ConversationPutVerb = ConversationVerbWithMethod 'PUT
+
 type CreateConversationCodeVerb =
   MultiVerb
     'POST
@@ -366,6 +370,15 @@ type ConversationAPI =
                :> "self"
                :> ConversationVerb
            )
+    :<|> Named
+           "create-mls-self-conversation"
+           ( Summary "Create the user's MLS self-conversation"
+               :> ZLocalUser
+               :> "conversations"
+               :> "mls-self"
+               :> ZClient
+               :> ConversationPutVerb
+           )
     -- This endpoint can lead to the following events being sent:
     -- - ConvCreate event to members
     -- TODO: add note: "On 201, the conversation ID is the `Location` header"

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

@@ -24,7 +24,8 @@
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 module Galley.API.Create
   ( createGroupConversation,
-    createSelfConversation,
+    createProteusSelfConversation,
+    createMLSSelfConversation,
     createOne2OneConversation,
     createConnectConversation,
   )
@@ -117,8 +118,7 @@ createGroupConversation lusr conn newConv = do
 
   case newConvProtocol newConv of
     ProtocolMLSTag -> do
-      haveKey <- isJust <$> getMLSRemovalKey
-      unless haveKey $
+      unlessM (isJust <$> getMLSRemovalKey) $
         -- We fail here to notify users early about this misconfiguration
         throw (InternalErrorWithDescription "No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Refusing to create MLS conversation.")
     ProtocolProteusTag -> pure ()
@@ -193,12 +193,12 @@ checkCreateConvPermissions lusr newConv (Just tinfo) allUsers = do
 ----------------------------------------------------------------------------
 -- Other kinds of conversations
 
-createSelfConversation ::
+createProteusSelfConversation ::
   forall r.
   Members '[ConversationStore, Error InternalError, P.TinyLog] r =>
   Local UserId ->
   Sem r ConversationResponse
-createSelfConversation lusr = do
+createProteusSelfConversation lusr = do
   let lcnv = fmap Data.selfConv lusr
   c <- E.getConversation (tUnqualified lcnv)
   maybe (create lcnv) (conversationExisted lusr) c
@@ -214,6 +214,42 @@ createSelfConversation lusr = do
       c <- E.createConversation lcnv nc
       conversationCreated lusr c
 
+createMLSSelfConversation ::
+  forall r.
+  Members
+    '[ ConversationStore,
+       Error InternalError,
+       MemberStore,
+       P.TinyLog,
+       Input Env
+     ]
+    r =>
+  Local UserId ->
+  ClientId ->
+  Sem r ConversationResponse
+createMLSSelfConversation lusr clientId = do
+  let selfConvId = mlsSelfConvId <$> lusr
+  mconv <- E.getConversation (tUnqualified selfConvId)
+  maybe (create selfConvId) (conversationExisted lusr) mconv
+  where
+    create :: Local ConvId -> Sem r ConversationResponse
+    create lcnv = do
+      unlessM (isJust <$> getMLSRemovalKey) $
+        throw (InternalErrorWithDescription "No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Refusing to create MLS conversation.")
+      let nc =
+            NewConversation
+              { ncMetadata =
+                  (defConversationMetadata (tUnqualified lusr))
+                    { cnvmType = SelfConv
+                    },
+                ncUsers = ulFromLocals [toUserRole (tUnqualified lusr)],
+                ncProtocol = ProtocolMLSTag
+              }
+      conv <- E.createConversation lcnv nc
+      -- TODO: remove this. we are planning to remove the need for a nullKeyPackageRef
+      E.addMLSClients lcnv (qUntagged lusr) (Set.singleton (clientId, nullKeyPackageRef))
+      conversationCreated lusr conv
+
 createOne2OneConversation ::
   forall r.
   Members
@@ -535,13 +571,6 @@ conversationCreated ::
   Sem r ConversationResponse
 conversationCreated lusr cnv = Created <$> conversationView lusr cnv
 
-conversationExisted ::
-  Members '[Error InternalError, P.TinyLog] r =>
-  Local UserId ->
-  Data.Conversation ->
-  Sem r ConversationResponse
-conversationExisted lusr cnv = Existed <$> conversationView lusr cnv
-
 notifyCreatedConversation ::
   Members '[Error InternalError, FederatorAccess, GundeckAccess, Input UTCTime, P.TinyLog] r =>
   Maybe UTCTime ->

services/galley/src/Galley/API/Public/Servant.hs

@@ -59,7 +59,8 @@ servantSitemap =
         <@> mkNamedAPI @"list-conversations" listConversations
         <@> mkNamedAPI @"get-conversation-by-reusable-code" (getConversationByReusableCode @Cassandra)
         <@> mkNamedAPI @"create-group-conversation" createGroupConversation
-        <@> mkNamedAPI @"create-self-conversation" createSelfConversation
+        <@> mkNamedAPI @"create-self-conversation" createProteusSelfConversation
+        <@> mkNamedAPI @"create-mls-self-conversation" createMLSSelfConversation
         <@> mkNamedAPI @"create-one-to-one-conversation" createOne2OneConversation
         <@> mkNamedAPI @"add-members-to-conversation-unqualified" addMembersUnqualified
         <@> mkNamedAPI @"add-members-to-conversation-unqualified2" addMembersUnqualifiedV2

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

@@ -90,10 +90,9 @@ import Polysemy.Error
 import Polysemy.Input
 import qualified Polysemy.TinyLog as P
 import qualified System.Logger.Class as Logger
-import Wire.API.Conversation (Access (CodeAccess), Conversation, ConversationCoverView (..), ConversationList (ConversationList), ConversationMetadata, convHasMore, convList)
+import Wire.API.Conversation hiding (Member)
 import qualified Wire.API.Conversation as Public
 import Wire.API.Conversation.Code
-import Wire.API.Conversation.Member hiding (Member)
 import Wire.API.Conversation.Role
 import qualified Wire.API.Conversation.Role as Public
 import Wire.API.Error

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

@@ -36,6 +36,7 @@ import Data.Singletons
 import qualified Data.Text as T
 import Data.Time
 import Galley.API.Error
+import Galley.API.Mapping
 import qualified Galley.Data.Conversation as Data
 import Galley.Data.Services (BotMember, newBotMember)
 import qualified Galley.Data.Types as DataTypes
@@ -63,6 +64,7 @@ import qualified Network.Wai.Utilities as Wai
 import Polysemy
 import Polysemy.Error
 import Polysemy.Input
+import qualified Polysemy.TinyLog as P
 import Wire.API.Connection
 import Wire.API.Conversation hiding (Member)
 import qualified Wire.API.Conversation as Public
@@ -74,6 +76,8 @@ import Wire.API.Event.Conversation
 import Wire.API.Federation.API
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Error
+import Wire.API.Routes.Public.Galley
+import Wire.API.Routes.Public.Util
 import Wire.API.Team.Member
 import Wire.API.Team.Role
 import Wire.API.User (VerificationAction)
@@ -838,6 +842,13 @@ ensureMemberLimit old new = do
   when (length old + length new > maxSize) $
     throwS @'TooManyMembers
 
+conversationExisted ::
+  Members '[Error InternalError, P.TinyLog] r =>
+  Local UserId ->
+  Data.Conversation ->
+  Sem r ConversationResponse
+conversationExisted lusr cnv = Existed <$> conversationView lusr cnv
+
 --------------------------------------------------------------------------------
 -- Handling remote errors
 

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

@@ -182,8 +182,14 @@ tests s =
       testGroup
         "CommitBundle"
         [ test s "add user with a commit bundle" testAddUserWithBundle,
-          test s "add user with a commit bundle to a remote conversation" testAddUserToRemoveConvWithBundle,
+          test s "add user with a commit bundle to a remote conversation" testAddUserToRemoteConvWithBundle,
           test s "remote user posts commit bundle" testRemoteUserPostsCommitBundle
+        ],
+      testGroup
+        "Self conversation"
+        [ test s "create a self conversation" testSelfConversation,
+          test s "attempt to add another user to a conversation fails" testSelfConversationOtherUser,
+          test s "attempt to leave fails" testSelfConversationLeave
         ]
     ]
 
@@ -1993,8 +1999,8 @@ testDeleteMLSConv = do
     deleteTeamConv tid (qUnqualified qcnv) aliceUnq
       !!! statusCode === const 200
 
-testAddUserToRemoveConvWithBundle :: TestM ()
-testAddUserToRemoveConvWithBundle = do
+testAddUserToRemoteConvWithBundle :: TestM ()
+testAddUserToRemoteConvWithBundle = do
   let aliceDomain = Domain "faraway.example.com"
   [alice, bob, charlie] <- createAndConnectUsers [Just (domainText aliceDomain), Nothing, Nothing]
 
@@ -2076,3 +2082,49 @@ testRemoteUserPostsCommitBundle = do
         MLSMessageResponseError MLSUnsupportedProposal <- runFedClient @"send-mls-commit-bundle" fedGalleyClient (Domain bobDomain) msr
 
         pure ()
+
+testSelfConversation :: TestM ()
+testSelfConversation = do
+  alice <- randomQualifiedUser
+  runMLSTest $ do
+    creator : others <- traverse createMLSClient (replicate 3 alice)
+    traverse_ uploadNewKeyPackage others
+    void $ setupMLSSelfGroup creator
+    commit <- createAddCommit creator [alice]
+    welcome <- assertJust (mpWelcome commit)
+    mlsBracket others $ \wss -> do
+      void $ sendAndConsumeCommit commit
+      WS.assertMatchN_ (5 # Second) wss $
+        wsAssertMLSWelcome alice welcome
+      WS.assertNoEvent (1 # WS.Second) wss
+
+testSelfConversationOtherUser :: TestM ()
+testSelfConversationOtherUser = do
+  users@[_alice, bob] <- createAndConnectUsers [Nothing, Nothing]
+  runMLSTest $ do
+    [alice1, bob1] <- traverse createMLSClient users
+    void $ uploadNewKeyPackage bob1
+    void $ setupMLSSelfGroup alice1
+    commit <- createAddCommit alice1 [bob]
+    mlsBracket [alice1, bob1] $ \wss -> do
+      postMessage (ciUser (mpSender commit)) (mpMessage commit)
+        !!! do
+          const 403 === statusCode
+          const (Just "invalid-op") === fmap Wai.label . responseJsonError
+      WS.assertNoEvent (1 # WS.Second) wss
+
+testSelfConversationLeave :: TestM ()
+testSelfConversationLeave = do
+  alice <- randomQualifiedUser
+  runMLSTest $ do
+    clients@(creator : others) <- traverse createMLSClient (replicate 3 alice)
+    traverse_ uploadNewKeyPackage others
+    (_, qcnv) <- setupMLSSelfGroup creator
+    void $ createAddCommit creator [alice] >>= sendAndConsumeCommit
+    mlsBracket clients $ \wss -> do
+      liftTest $
+        deleteMemberQualified (qUnqualified alice) alice qcnv
+          !!! do
+            const 403 === statusCode
+            const (Just "invalid-op") === fmap Wai.label . responseJsonError
+      WS.assertNoEvent (1 # WS.Second) wss

services/galley/test/integration/API/MLS/Util.hs

@@ -392,26 +392,50 @@ setGroupState cid state = do
   fp <- nextGroupFile cid
   liftIO $ BS.writeFile fp state
 
--- | Create conversation and corresponding group.
-setupMLSGroup :: HasCallStack => ClientIdentity -> MLSTest (GroupId, Qualified ConvId)
-setupMLSGroup creator = do
+-- | Create a conversation from a provided action and then create a
+-- corresponding group.
+setupMLSGroupWithConv ::
+  HasCallStack =>
+  MLSTest Conversation ->
+  ClientIdentity ->
+  MLSTest (GroupId, Qualified ConvId)
+setupMLSGroupWithConv convAction creator = do
   ownDomain <- liftTest viewFederationDomain
   liftIO $ assertEqual "creator is not local" (ciDomain creator) ownDomain
-  conv <-
-    responseJsonError
-      =<< liftTest
-        ( postConvQualified
-            (ciUser creator)
-            (defNewMLSConv (ciClient creator))
-        )
-        <!! const 201 === statusCode
+  conv <- convAction
   let groupId =
         fromJust
           (preview (to cnvProtocol . _ProtocolMLS . to cnvmlsGroupId) conv)
 
   createGroup creator groupId
   pure (groupId, cnvQualifiedId conv)
 
+-- | Create conversation and corresponding group.
+setupMLSGroup :: HasCallStack => ClientIdentity -> MLSTest (GroupId, Qualified ConvId)
+setupMLSGroup creator = setupMLSGroupWithConv action creator
+  where
+    action =
+      responseJsonError
+        =<< liftTest
+          ( postConvQualified
+              (ciUser creator)
+              (defNewMLSConv (ciClient creator))
+          )
+          <!! const 201 === statusCode
+
+-- | Create self-conversation and corresponding group.
+setupMLSSelfGroup :: HasCallStack => ClientIdentity -> MLSTest (GroupId, Qualified ConvId)
+setupMLSSelfGroup creator = setupMLSGroupWithConv action creator
+  where
+    action =
+      responseJsonError
+        =<< liftTest
+          ( putSelfConv
+              (ciUser creator)
+              (ciClient creator)
+          )
+          <!! const 201 === statusCode
+
 createGroup :: ClientIdentity -> GroupId -> MLSTest ()
 createGroup cid gid = do
   State.gets mlsGroupId >>= \case
@@ -999,3 +1023,17 @@ getGroupInfo sender qcnv = do
         . zUser sender
         . zConn "conn"
     )
+
+putSelfConv ::
+  UserId ->
+  ClientId ->
+  TestM ResponseLBS
+putSelfConv u c = do
+  g <- viewGalley
+  put $
+    g
+      . paths ["/conversations", "mls-self"]
+      . zUser u
+      . zClient c
+      . zConn "conn"
+      . zType "access"