[FS-925] Lazily create an MLS Self-conversation

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

@@ -0,0 +1 @@
+Support MLS self-conversations via a new endpoint `GET /conversations/mls-self`. This removes the `PUT` counterpart introduced in #2730

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

@@ -43,9 +43,9 @@ type ConversationResponse = ResponseForExistedCreated Conversation
 
 type ConversationHeaders = '[DescHeader "Location" "Conversation ID" ConvId]
 
-type ConversationVerbWithMethod (m :: StdMethod) =
+type ConversationVerb =
   MultiVerb
-    m
+    'POST
     '[JSON]
     '[ WithHeaders
          ConversationHeaders
@@ -58,10 +58,6 @@ type ConversationVerbWithMethod (m :: StdMethod) =
      ]
     ConversationResponse
 
-type ConversationVerb = ConversationVerbWithMethod 'POST
-
-type ConversationPutVerb = ConversationVerbWithMethod 'PUT
-
 type CreateConversationCodeVerb =
   MultiVerb
     'POST
@@ -275,13 +271,19 @@ type ConversationAPI =
                :> ConversationVerb
            )
     :<|> Named
-           "create-mls-self-conversation"
-           ( Summary "Create the user's MLS self-conversation"
+           "get-mls-self-conversation"
+           ( Summary "Get the user's MLS self-conversation"
                :> ZLocalUser
                :> "conversations"
                :> "mls-self"
-               :> ZClient
-               :> ConversationPutVerb
+               :> MultiVerb1
+                    'GET
+                    '[JSON]
+                    ( Respond
+                        200
+                        "The MLS self-conversation"
+                        Conversation
+                    )
            )
     -- This endpoint can lead to the following events being sent:
     -- - ConvCreate event to members

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

@@ -25,7 +25,6 @@
 module Galley.API.Create
   ( createGroupConversation,
     createProteusSelfConversation,
-    createMLSSelfConversation,
     createOne2OneConversation,
     createConnectConversation,
   )
@@ -214,42 +213,6 @@ createProteusSelfConversation 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
-      -- FUTUREWORK: 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

services/galley/src/Galley/API/MLS/Message.hs

@@ -441,7 +441,7 @@ getSenderIdentity qusr mc fmt msg = do
   -- one contained in the message. We throw an error if the two don't match.
   when (((==) <$> mc <*> mSender) == Just False) $
     throwS @'MLSClientSenderUserMismatch
-  pure (mkClientIdentity qusr <$> mSender)
+  pure (mkClientIdentity qusr <$> (mc <|> mSender))
 
 postMLSMessageToLocalConv ::
   ( HasProposalEffects r,
@@ -796,10 +796,29 @@ processInternalCommit qusr senderClient con lconv cm epoch groupId action sender
     postponedKeyPackageRefUpdate <-
       if epoch == Epoch 0
         then do
-          -- this is a newly created conversation, and it should contain exactly one
-          -- client (the creator)
-          case (self, cmAssocs cm) of
-            (Left lm, [(qu, (creatorClient, _))])
+          let cType = cnvmType . convMetadata . tUnqualified $ lconv
+          case (self, cType, cmAssocs cm) of
+            (Left _, SelfConv, []) -> do
+              creatorClient <-
+                note (mlsProtocolError "Missing the sender client") senderClient
+              creatorRef <-
+                maybe
+                  (pure senderRef)
+                  ( note (mlsProtocolError "Could not compute key package ref")
+                      . kpRef'
+                      . upLeaf
+                  )
+                  $ cPath commit
+              addMLSClients
+                (convId <$> lconv)
+                qusr
+                (Set.singleton (creatorClient, creatorRef))
+            (Left _, SelfConv, _) ->
+              throw . InternalErrorWithDescription $
+                "Unexpected creator client set in a self-conversation"
+            -- this is a newly created conversation, and it should contain exactly one
+            -- client (the creator)
+            (Left lm, _, [(qu, (creatorClient, _))])
               | qu == qUntagged (qualifyAs lconv (lmId lm)) -> do
                   -- use update path as sender reference and if not existing fall back to sender
                   senderRef' <-
@@ -813,9 +832,9 @@ processInternalCommit qusr senderClient con lconv cm epoch groupId action sender
                   -- register the creator client
                   updateKeyPackageMapping lconv qusr creatorClient Nothing senderRef'
             -- remote clients cannot send the first commit
-            (Right _, _) -> throwS @'MLSStaleMessage
+            (Right _, _, _) -> throwS @'MLSStaleMessage
             -- uninitialised conversations should contain exactly one client
-            (_, _) ->
+            (_, _, _) ->
               throw (InternalErrorWithDescription "Unexpected creator client set")
           pure $ pure () -- no key package ref update necessary
         else case upLeaf <$> cPath commit of

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

@@ -41,7 +41,7 @@ conversationAPI =
     <@> mkNamedAPI @"get-conversation-by-reusable-code" (getConversationByReusableCode @Cassandra)
     <@> mkNamedAPI @"create-group-conversation" createGroupConversation
     <@> mkNamedAPI @"create-self-conversation" createProteusSelfConversation
-    <@> mkNamedAPI @"create-mls-self-conversation" createMLSSelfConversation
+    <@> mkNamedAPI @"get-mls-self-conversation" getMLSSelfConversation
     <@> 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

@@ -50,6 +50,7 @@ module Galley.API.Query
     ensureGuestLinksEnabled,
     getConversationGuestLinksStatus,
     ensureConvAdmin,
+    getMLSSelfConversation,
   )
 where
 
@@ -66,9 +67,12 @@ import Data.Qualified
 import Data.Range
 import qualified Data.Set as Set
 import Galley.API.Error
+import Galley.API.MLS.Keys
+import Galley.API.Mapping
 import qualified Galley.API.Mapping as Mapping
 import Galley.API.Util
 import qualified Galley.Data.Conversation as Data
+import qualified Galley.Data.Conversation.Types as Data
 import Galley.Data.Types (Code (codeConversation))
 import Galley.Effects
 import qualified Galley.Effects.ConversationStore as E
@@ -77,9 +81,12 @@ import qualified Galley.Effects.ListItems as E
 import qualified Galley.Effects.MemberStore as E
 import Galley.Effects.TeamFeatureStore (FeaturePersistentConstraint)
 import qualified Galley.Effects.TeamFeatureStore as TeamFeatures
+import Galley.Env
 import Galley.Options
 import Galley.Types.Conversations.Members
 import Galley.Types.Teams
+import Galley.Types.ToUserRole
+import Galley.Types.UserList
 import Imports
 import Network.HTTP.Types
 import Network.Wai
@@ -93,6 +100,7 @@ import qualified System.Logger.Class as Logger
 import Wire.API.Conversation hiding (Member)
 import qualified Wire.API.Conversation as Public
 import Wire.API.Conversation.Code
+import Wire.API.Conversation.Protocol
 import Wire.API.Conversation.Role
 import qualified Wire.API.Conversation.Role as Public
 import Wire.API.Error
@@ -605,6 +613,48 @@ getConversationGuestLinksFeatureStatus mbTid = do
       mbLockStatus <- TeamFeatures.getFeatureLockStatus @db (Proxy @GuestLinksConfig) tid
       pure $ computeFeatureConfigForTeamUser mbConfigNoLock mbLockStatus defaultStatus
 
+-- | Get an MLS self conversation. In case it does not exist, it is partially
+-- created in the database. The part that is not written is the epoch number;
+-- the number is inserted only upon the first commit. With this we avoid race
+-- conditions where two clients concurrently try to create or update the self
+-- conversation, where the only thing that can be updated is bumping the epoch
+-- number.
+getMLSSelfConversation ::
+  forall r.
+  Members
+    '[ ConversationStore,
+       Error InternalError,
+       P.TinyLog,
+       Input Env
+     ]
+    r =>
+  Local UserId ->
+  Sem r Conversation
+getMLSSelfConversation lusr = do
+  let selfConvId = mlsSelfConvId usr
+  mconv <- E.getConversation selfConvId
+  cnv <- maybe create pure mconv
+  conversationView lusr cnv
+  where
+    usr = tUnqualified lusr
+    create :: Sem r Data.Conversation
+    create = do
+      unlessM (isJust <$> getMLSRemovalKey) $
+        throw (InternalErrorWithDescription noKeyMsg)
+      let nc =
+            Data.NewConversation
+              { ncMetadata =
+                  (defConversationMetadata usr)
+                    { cnvmType = SelfConv
+                    },
+                ncUsers = ulFromLocals [toUserRole usr],
+                ncProtocol = ProtocolMLSTag
+              }
+      E.createMLSSelfConversation lusr nc
+    noKeyMsg =
+      "No backend removal key is configured (See 'mlsPrivateKeyPaths'"
+        <> "in galley's config). Refusing to create MLS conversation."
+
 -------------------------------------------------------------------------------
 -- Helpers
 

services/galley/src/Galley/Cassandra/Conversation.hs

@@ -56,6 +56,66 @@ import Wire.API.MLS.CipherSuite
 import Wire.API.MLS.Group
 import Wire.API.MLS.PublicGroupState
 
+createMLSSelfConversation ::
+  Local UserId ->
+  NewConversation ->
+  Client Conversation
+createMLSSelfConversation lusr nc = do
+  let lcnv = mlsSelfConvId <$> lusr
+      meta = ncMetadata nc
+      (proto, mgid, mcs) = case ncProtocol nc of
+        ProtocolProteusTag -> (ProtocolProteus, Nothing, Nothing)
+        ProtocolMLSTag ->
+          let gid = convToGroupId lcnv
+              ep = Epoch 0
+              cs = MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519
+           in ( ProtocolMLS
+                  ConversationMLSData
+                    { cnvmlsGroupId = gid,
+                      cnvmlsEpoch = ep,
+                      cnvmlsCipherSuite = cs
+                    },
+                Just gid,
+                -- FUTUREWORK: Make the cipher suite be a record field in
+                -- 'NewConversation' instead of hard-coding it here.
+                --
+                -- 'CipherSuite 1' corresponds to
+                -- 'MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519'.
+                Just cs
+              )
+  retry x5 . batch $ do
+    setType BatchLogged
+    setConsistency LocalQuorum
+    addPrepQuery
+      Cql.insertMLSSelfConv
+      ( tUnqualified lcnv,
+        cnvmType meta,
+        cnvmCreator meta,
+        Cql.Set (cnvmAccess meta),
+        Cql.Set (toList (cnvmAccessRoles meta)),
+        cnvmName meta,
+        cnvmTeam meta,
+        cnvmMessageTimer meta,
+        cnvmReceiptMode meta,
+        mgid,
+        mcs
+      )
+    for_ (cnvmTeam meta) $ \tid ->
+      addPrepQuery Cql.insertTeamConv (tid, tUnqualified lcnv)
+    for_ mgid $ \g ->
+      addPrepQuery Cql.insertGroupId (g, tUnqualified lcnv, tDomain lcnv)
+
+  (lmems, rmems) <- addMembers (tUnqualified lcnv) (ncUsers nc)
+  pure
+    Conversation
+      { convId = tUnqualified lcnv,
+        convLocalMembers = lmems,
+        convRemoteMembers = rmems,
+        convDeleted = False,
+        convMetadata = meta,
+        convProtocol = proto
+      }
+
 createConversation :: Local ConvId -> NewConversation -> Client Conversation
 createConversation lcnv nc = do
   let meta = ncMetadata nc
@@ -266,7 +326,12 @@ toProtocol ::
 toProtocol Nothing _ _ _ = Just ProtocolProteus
 toProtocol (Just ProtocolProteusTag) _ _ _ = Just ProtocolProteus
 toProtocol (Just ProtocolMLSTag) mgid mepoch mcs =
-  ProtocolMLS <$> (ConversationMLSData <$> mgid <*> mepoch <*> mcs)
+  ProtocolMLS <$> (ConversationMLSData <$> mgid <*> mapEpoch mepoch <*> mcs)
+  where
+    -- If there is no epoch in the database, assume the epoch is 0 and this is a
+    -- self-conversation.
+    mapEpoch Nothing = Just (Epoch 0)
+    mapEpoch x = x
 
 toConv ::
   ConvId ->
@@ -314,6 +379,7 @@ interpretConversationStoreToCassandra ::
 interpretConversationStoreToCassandra = interpret $ \case
   CreateConversationId -> Id <$> embed nextRandom
   CreateConversation loc nc -> embedClient $ createConversation loc nc
+  CreateMLSSelfConversation lusr nc -> embedClient $ createMLSSelfConversation lusr nc
   GetConversation cid -> embedClient $ getConversation cid
   GetConversationIdByGroupId gId -> embedClient $ lookupGroupId gId
   GetConversations cids -> localConversations cids

services/galley/src/Galley/Cassandra/Instances.hs

@@ -182,13 +182,14 @@ instance Cql Public.EnforceAppLock where
 instance Cql ProtocolTag where
   ctype = Tagged IntColumn
 
-  toCql ProtocolProteusTag = CqlInt 0
-  toCql ProtocolMLSTag = CqlInt 1
-
-  fromCql (CqlInt i) = case i of
-    0 -> pure ProtocolProteusTag
-    1 -> pure ProtocolMLSTag
-    n -> Left $ "unexpected protocol: " ++ show n
+  toCql = CqlInt . fromIntegral . fromEnum
+
+  fromCql (CqlInt i) = do
+    let i' = fromIntegral i
+    if i' < fromEnum @ProtocolTag minBound
+      || i' > fromEnum @ProtocolTag maxBound
+      then Left $ "unexpected protocol: " ++ show i
+      else Right $ toEnum i'
   fromCql _ = Left "protocol: int expected"
 
 instance Cql GroupId where