WIP

services/galley/galley.cabal

@@ -590,6 +590,7 @@ executable galley-schema
     V78_TeamFeatureOutlookCalIntegration
     V79_TeamFeatureMlsE2EId
     V80_MLSSubconversation
+    V81_MLSDraft17
 
   hs-source-dirs:     schema/src
   default-extensions: TemplateHaskell

services/galley/schema/src/Run.hs

@@ -153,7 +153,7 @@ main = do
       V78_TeamFeatureOutlookCalIntegration.migration,
       V79_TeamFeatureMlsE2EId.migration,
       V80_MLSSubconversation.migration,
-      V81_MLSDraft17.migration,
+      V81_MLSDraft17.migration
       -- When adding migrations here, don't forget to update
       -- 'schemaVersion' in Galley.Cassandra
       -- (see also docs/developer/cassandra-interaction.md)

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

@@ -41,7 +41,6 @@ import Data.Time
 import qualified Data.UUID.Tagged as U
 import Galley.API.Error
 import Galley.API.MLS
-import Galley.API.MLS.KeyPackage (nullKeyPackageRef)
 import Galley.API.MLS.Keys (getMLSRemovalKey)
 import Galley.API.Mapping
 import Galley.API.One2One
@@ -86,7 +85,6 @@ import Wire.API.Team.Permission hiding (self)
 createGroupConversation ::
   ( Member BrigAccess r,
     Member ConversationStore r,
-    Member MemberStore r,
     Member (ErrorS 'ConvAccessDenied) r,
     Member (Error InternalError) r,
     Member (Error InvalidInput) r,
@@ -95,7 +93,6 @@ createGroupConversation ::
     Member (ErrorS 'NotConnected) r,
     Member (ErrorS 'MLSNotEnabled) r,
     Member (ErrorS 'MLSNonEmptyMemberList) r,
-    Member (ErrorS 'MLSMissingSenderClient) r,
     Member (ErrorS 'MissingLegalholdConsent) r,
     Member FederatorAccess r,
     Member GundeckAccess r,
@@ -107,11 +104,10 @@ createGroupConversation ::
     Member P.TinyLog r
   ) =>
   Local UserId ->
-  Maybe ClientId ->
   Maybe ConnId ->
   NewConv ->
   Sem r ConversationResponse
-createGroupConversation lusr mCreatorClient mConn newConv = do
+createGroupConversation lusr mConn newConv = do
   (nc, fromConvSize -> allUsers) <- newRegularConversation lusr newConv
   let tinfo = newConvTeam newConv
   checkCreateConvPermissions lusr newConv tinfo allUsers
@@ -132,13 +128,6 @@ createGroupConversation lusr mCreatorClient mConn newConv = do
   -- conversation is already in the database.
   conv <- E.createConversation lcnv nc
 
-  -- set creator client for MLS conversations
-  case (convProtocol conv, mCreatorClient) of
-    (ProtocolProteus, _) -> pure ()
-    (ProtocolMLS mlsMeta, Just c) ->
-      E.addMLSClients (cnvmlsGroupId mlsMeta) (tUntagged lusr) (Set.singleton (c, nullKeyPackageRef))
-    (ProtocolMLS _mlsMeta, Nothing) -> throwS @'MLSMissingSenderClient
-
   now <- input
   -- NOTE: We only send (conversation) events to members of the conversation
   notifyCreatedConversation (Just now) lusr mConn conv

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

@@ -42,7 +42,8 @@ mkMLSConversation conv =
           mcLocalMembers = Data.convLocalMembers conv,
           mcRemoteMembers = Data.convRemoteMembers conv,
           mcMLSData = mlsData,
-          mcMembers = cm
+          mcMembers = cm,
+          mcIndexMap = mempty -- TODO
         }
 
 mcConv :: MLSConversation -> Data.Conversation

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

@@ -47,7 +47,6 @@ import Galley.API.Action
 import Galley.API.Error
 import Galley.API.MLS.Conversation
 import Galley.API.MLS.Enabled
-import Galley.API.MLS.KeyPackage
 import Galley.API.MLS.Propagate
 import Galley.API.MLS.Removal
 import Galley.API.MLS.Types
@@ -105,6 +104,9 @@ import Wire.API.User.Client
 -- [ ] remove MissingSenderClient error
 -- [ ] PreSharedKey proposal
 -- [ ] remove all key package ref mapping
+-- [ ] initialise index maps
+-- [ ] newtype for leaf node indices
+-- [ ] compute new indices for add proposals
 
 data IncomingMessage = IncomingMessage
   { epoch :: Epoch,
@@ -463,7 +465,6 @@ postMLSMessageToLocalConv ::
   ( HasProposalEffects r,
     Member (ErrorS 'ConvNotFound) r,
     Member (ErrorS 'MissingLegalholdConsent) r,
-    Member (ErrorS 'MLSClientSenderUserMismatch) r,
     Member (ErrorS 'MLSCommitMissingReferences) r,
     Member (ErrorS 'MLSProposalNotFound) r,
     Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
@@ -581,11 +582,11 @@ instance Semigroup ProposalAction where
 instance Monoid ProposalAction where
   mempty = ProposalAction mempty mempty mempty
 
-paAddClient :: Qualified (UserId, (ClientId, Word32)) -> ProposalAction
-paAddClient quc = mempty {paAdd = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))}
+paAddClient :: ClientIdentity -> Word32 -> ProposalAction
+paAddClient cid idx = mempty {paAdd = cmSingleton cid idx}
 
-paRemoveClient :: Qualified (UserId, (ClientId, Word32)) -> ProposalAction
-paRemoveClient quc = mempty {paRemove = Map.singleton (fmap fst quc) (uncurry Map.singleton (snd (qUnqualified quc)))}
+paRemoveClient :: ClientIdentity -> Word32 -> ProposalAction
+paRemoveClient cid idx = mempty {paRemove = cmSingleton cid idx}
 
 paExternalInitPresent :: ProposalAction
 paExternalInitPresent = mempty {paExternalInit = Any True}
@@ -615,7 +616,6 @@ processCommit ::
   ( HasProposalEffects r,
     Member (ErrorS 'ConvNotFound) r,
     Member (ErrorS 'MissingLegalholdConsent) r,
-    Member (ErrorS 'MLSClientSenderUserMismatch) r,
     Member (ErrorS 'MLSCommitMissingReferences) r,
     Member (ErrorS 'MLSProposalNotFound) r,
     Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
@@ -641,8 +641,6 @@ processExternalCommit ::
     Member ConversationStore r,
     Member (Error MLSProtocolError) r,
     Member (ErrorS 'ConvNotFound) r,
-    Member (ErrorS 'MLSClientSenderUserMismatch) r,
-    Member (ErrorS 'MLSKeyPackageRefNotFound) r,
     Member (ErrorS 'MLSStaleMessage) r,
     Member (ErrorS 'MLSSubConvClientNotInParent) r,
     Member ExternalAccess r,
@@ -662,82 +660,73 @@ processExternalCommit ::
   ProposalAction ->
   Maybe UpdatePath ->
   Sem r ()
-processExternalCommit senderIdentity lConvOrSub epoch action updatePath =
-  withCommitLock (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub) epoch $ do
-    let convOrSub = tUnqualified lConvOrSub
-    leafNode <-
-      upLeaf
-        <$> note
-          (mlsProtocolError "External commits need an update path")
-          updatePath
-    when (paExternalInit action == mempty) $
-      throw . mlsProtocolError $
-        "The external commit is missing an external init proposal"
-    unless (paAdd action == mempty) $
-      throw . mlsProtocolError $
-        "The external commit must not have add proposals"
-
-    -- validate and update mapping in brig
-    validateLeafNode senderIdentity leafNode >>= \case
-      Left errMsg ->
-        throw $
-          mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg)
-      Right _ -> pure ()
-
-    -- only members can join a subconversation
-    forOf_ _SubConv convOrSub $ \(mlsConv, _) ->
-      unless (isClientMember senderIdentity (mcMembers mlsConv)) $
-        throwS @'MLSSubConvClientNotInParent
-
-    -- check if there is a key package ref in the remove proposal
-    remIndex <-
-      if Map.null (paRemove action)
-        then pure Nothing
-        else do
-          (remCid, r) <- derefUser (paRemove action) (cidQualifiedUser senderIdentity)
-          unless (cidQualifiedUser senderIdentity == cidQualifiedUser remCid)
-            . throw
-            . mlsProtocolError
-            $ "The external commit attempts to remove a client from a user other than themselves"
-          pure (Just r)
+processExternalCommit senderIdentity lConvOrSub epoch action updatePath = do
+  let convOrSub = tUnqualified lConvOrSub
+  leafNode <-
+    upLeaf
+      <$> note
+        (mlsProtocolError "External commits need an update path")
+        updatePath
+  when (paExternalInit action == mempty) $
+    throw . mlsProtocolError $
+      "The external commit is missing an external init proposal"
+  unless (paAdd action == mempty) $
+    throw . mlsProtocolError $
+      "The external commit must not have add proposals"
+
+  -- validate and update mapping in brig
+  validateLeafNode senderIdentity leafNode >>= \case
+    Left errMsg ->
+      throw $
+        mlsProtocolError ("Tried to add invalid LeafNode: " <> errMsg)
+    Right _ -> pure ()
+
+  -- only members can join a subconversation
+  forOf_ _SubConv convOrSub $ \(mlsConv, _) ->
+    unless (isClientMember senderIdentity (mcMembers mlsConv)) $
+      throwS @'MLSSubConvClientNotInParent
+
+  let groupId = cnvmlsGroupId (mlsMetaConvOrSub convOrSub)
+
+  withCommitLock groupId epoch $ do
+    -- validate remove proposal: an external commit can contain
+    --
+    -- > At most one Remove proposal, with which the joiner removes an old
+    -- > version of themselves
+    remIndex <- case cmAssocs (paRemove action) of
+      [] -> pure Nothing
+      [(_, idx :: Word32)] -> do
+        cid <-
+          note (mlsProtocolError "Invalid index in remove proposal") $
+            indexToClient (indicesConvOrSub convOrSub) idx
+        unless (cid == senderIdentity) $
+          throw $
+            mlsProtocolError "Only the self client can be removed by an external commit"
+        pure (Just idx)
+      _ -> throw (mlsProtocolError "Multiple remove proposals in external commits not allowed")
 
     -- increment epoch number
     lConvOrSub' <- for lConvOrSub incrementEpoch
 
     -- fetch backend remove proposals of the previous epoch
-    kpRefs <-
+    indicesInRemoveProposals <-
       -- skip remove proposals of already removed by the external commit
-      filter (maybe (const True) (/=) remRef)
-        <$> getPendingBackendRemoveProposals (cnvmlsGroupId . mlsMetaConvOrSub . tUnqualified $ lConvOrSub') epoch
+      filter (maybe (const True) (/=) remIndex)
+        <$> getPendingBackendRemoveProposals groupId epoch
+
     -- requeue backend remove proposals for the current epoch
     let cm = membersConvOrSub (tUnqualified lConvOrSub')
-    createAndSendRemoveProposals lConvOrSub' kpRefs (cidQualifiedUser senderIdentity) cm
-  where
-    derefUser :: ClientMap -> Qualified UserId -> Sem r (ClientIdentity, KeyPackageRef)
-    derefUser cm user = case Map.assocs cm of
-      [(u, clients)] -> do
-        unless (user == u) $
-          throwS @'MLSClientSenderUserMismatch
-        ref <- ensureSingleton clients
-        ci <- derefKeyPackage ref
-        unless (cidQualifiedUser ci == user) $
-          throwS @'MLSClientSenderUserMismatch
-        pure (ci, ref)
-      _ -> throwRemProposal
-    ensureSingleton :: Map k a -> Sem r a
-    ensureSingleton m = case Map.elems m of
-      [e] -> pure e
-      _ -> throwRemProposal
-    throwRemProposal =
-      throw . mlsProtocolError $
-        "The external commit must have at most one remove proposal"
+    createAndSendRemoveProposals
+      lConvOrSub'
+      indicesInRemoveProposals
+      (cidQualifiedUser senderIdentity)
+      cm
 
 processCommitWithAction ::
   forall r.
   ( HasProposalEffects r,
     Member (ErrorS 'ConvNotFound) r,
     Member (ErrorS 'MissingLegalholdConsent) r,
-    Member (ErrorS 'MLSClientSenderUserMismatch) r,
     Member (ErrorS 'MLSCommitMissingReferences) r,
     Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
     Member (ErrorS 'MLSStaleMessage) r,
@@ -830,26 +819,16 @@ applyProposal ::
   GroupId ->
   Proposal ->
   Sem r ProposalAction
-applyProposal _convOrSubConvId groupId (AddProposal kp) = do
-  ref <- kpRef' kp & note (mlsProtocolError "Could not compute ref of a key package in an Add proposal")
-  mbClientIdentity <- getClientByKeyPackageRef ref
-  clientIdentity <- case mbClientIdentity of
-    Nothing -> do
-      -- TODO: validate key package
-      cid <-
-        either
-          (\_ -> throw (mlsProtocolError "Invalid key package in an Add proposal"))
-          pure
-          $ keyPackageIdentity kp.rmValue
-      addMLSClients groupId (cidQualifiedUser cid) (Set.singleton (ciClient cid, ref))
-      pure cid
-    Just cid ->
-      -- ad-hoc add proposal in commit, the key package has been claimed before
-      pure cid
-  pure (paAddClient . (<$$>) (,ref) . cidQualifiedClient $ clientIdentity)
-applyProposal _convOrSubConvId _groupId (RemoveProposal ref) = do
-  qclient <- cidQualifiedClient <$> derefKeyPackage ref
-  pure (paRemoveClient ((,ref) <$$> qclient))
+applyProposal _convOrSubConvId _groupId (AddProposal kp) = do
+  let idx = error "TODO: compute new index"
+  -- TODO: validate key package
+  cid <- getKeyPackageIdentity kp.rmValue
+  -- TODO: we probably should not update the conversation state here
+  -- addMLSClients groupId (cidQualifiedUser cid) (Set.singleton (ciClient cid, idx))
+  pure (paAddClient cid idx)
+applyProposal _convOrSubConvId _groupId (RemoveProposal idx) = do
+  let cid = error "TODO: lookup in index map"
+  pure (paRemoveClient cid idx)
 applyProposal _convOrSubConvId _groupId (ExternalInitProposal _) =
   -- only record the fact there was an external init proposal, but do not
   -- process it in any way.
@@ -949,11 +928,7 @@ checkExternalProposalUser qusr prop = do
     loc
     ( \lusr -> case prop of
         AddProposal kp -> do
-          ClientIdentity {ciUser, ciClient} <-
-            either
-              (const $ throwS @'MLSUnsupportedProposal)
-              pure
-              (keyPackageIdentity kp.rmValue)
+          ClientIdentity {ciUser, ciClient} <- getKeyPackageIdentity kp.rmValue
           -- requesting user must match key package owner
           when (tUnqualified lusr /= ciUser) $ throwS @'MLSUnsupportedProposal
           -- client referenced in key package must be one of the user's clients
@@ -1188,6 +1163,14 @@ removeMembers qusr con lconvOrSub users = case tUnqualified lconvOrSub of
       $ users
   SubConv _ _ -> pure []
 
+getKeyPackageIdentity ::
+  Member (ErrorS 'MLSUnsupportedProposal) r =>
+  KeyPackage ->
+  Sem r ClientIdentity
+getKeyPackageIdentity =
+  either (\_ -> throwS @'MLSUnsupportedProposal) pure
+    . keyPackageIdentity
+
 handleNoChanges :: Monoid a => Sem (Error NoChanges ': r) a -> Sem r a
 handleNoChanges = fmap fold . runError
 

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

@@ -70,15 +70,15 @@ createAndSendRemoveProposals ::
   -- conversation/subconversation client maps.
   ClientMap ->
   Sem r ()
-createAndSendRemoveProposals lConvOrSubConv cs qusr cm = do
+createAndSendRemoveProposals lConvOrSubConv indices qusr cm = do
   let meta = mlsMetaConvOrSub (tUnqualified lConvOrSubConv)
   mKeyPair <- getMLSRemovalKey
   case mKeyPair of
     Nothing -> do
       warn $ Log.msg ("No backend removal key is configured (See 'mlsPrivateKeyPaths' in galley's config). Not able to remove client from MLS conversation." :: Text)
     Just (secKey, pubKey) -> do
-      for_ cs $ \_kpref -> do
-        let proposal = mkRawMLS (RemoveProposal (error "TODO: proposal index"))
+      for_ indices $ \idx -> do
+        let proposal = mkRawMLS (RemoveProposal idx)
             msg =
               mkSignedMessage
                 secKey