fix integration test: send other user's commit

* keep track of index map while processing proposals
* add creator client to ProposalAction in epoch 0

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

@@ -695,7 +695,6 @@ sendMLSMessage ::
     Member (Input UTCTime) r,
     Member LegalHoldStore r,
     Member MemberStore r,
-    Member Resource r,
     Member TeamStore r,
     Member P.TinyLog r,
     Member ProposalStore r,

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

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

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

@@ -71,6 +71,7 @@ import Polysemy.Error
 import Polysemy.Input
 import Polysemy.Internal
 import Polysemy.Resource (Resource)
+import Polysemy.State
 import Polysemy.TinyLog
 import Wire.API.Conversation hiding (Member)
 import Wire.API.Conversation.Protocol
@@ -103,7 +104,7 @@ import Wire.API.User.Client
 -- [ ] remove MissingSenderClient error
 -- [ ] PreSharedKey proposal
 -- [ ] remove all key package ref mapping
--- [ ] initialise index maps
+-- [x] initialise index maps
 -- [ ] newtype for leaf node indices
 -- [x] compute new indices for add proposals
 -- [ ] remove prefixes from rmValue and rmRaw
@@ -238,7 +239,6 @@ postMLSMessageFromLocalUserV1 ::
     Member (ErrorS 'MLSStaleMessage) r,
     Member (ErrorS 'MLSUnsupportedMessage) r,
     Member (ErrorS 'MLSSubConvClientNotInParent) r,
-    Member Resource r,
     Member SubConversationStore r
   ) =>
   Local UserId ->
@@ -270,7 +270,6 @@ postMLSMessageFromLocalUser ::
     Member (ErrorS 'MLSStaleMessage) r,
     Member (ErrorS 'MLSUnsupportedMessage) r,
     Member (ErrorS 'MLSSubConvClientNotInParent) r,
-    Member Resource r,
     Member SubConversationStore r
   ) =>
   Local UserId ->
@@ -343,9 +342,9 @@ postMLSCommitBundleToLocalConv ::
   Sem r [LocalConversationUpdate]
 postMLSCommitBundleToLocalConv qusr c conn bundle lConvOrSubId = do
   lConvOrSub <- fetchConvOrSub qusr lConvOrSubId
-  senderIdentity <- getSenderIdentity qusr c (Just bundle.sender)
+  senderIdentity <- getSenderIdentity qusr c bundle.sender lConvOrSub
 
-  action <- getCommitData lConvOrSub bundle.epoch bundle.commit.rmValue
+  action <- getCommitData senderIdentity lConvOrSub bundle.epoch bundle.commit.rmValue
   -- TODO: check that the welcome message matches the action
   -- for_ bundle.welcome $ \welcome ->
   --   when
@@ -397,15 +396,13 @@ postMLSCommitBundleToRemoteConv loc qusr c con bundle rConvOrSubId = do
 
   flip unless (throwS @'ConvMemberNotFound) =<< checkLocalMemberRemoteConv (tUnqualified lusr) (convOfConvOrSub <$> rConvOrSubId)
 
-  senderIdentity <- getSenderIdentity qusr c (Just bundle.sender)
-
   resp <-
     runFederated rConvOrSubId $
       fedClient @'Galley @"send-mls-commit-bundle" $
         MLSMessageSendRequest
           { mmsrConvOrSubId = tUnqualified rConvOrSubId,
             mmsrSender = tUnqualified lusr,
-            mmsrSenderClient = ciClient senderIdentity,
+            mmsrSenderClient = c,
             mmsrRawMessage = Base64ByteString bundle.serialized
           }
   updates <- case resp of
@@ -435,7 +432,6 @@ postMLSMessage ::
     Member (ErrorS 'MLSStaleMessage) r,
     Member (ErrorS 'MLSUnsupportedMessage) r,
     Member (ErrorS 'MLSSubConvClientNotInParent) r,
-    Member Resource r,
     Member SubConversationStore r
   ) =>
   Local x ->
@@ -446,36 +442,38 @@ postMLSMessage ::
   IncomingMessage ->
   Sem r [LocalConversationUpdate]
 postMLSMessage loc qusr c qconvOrSub con msg = do
-  -- verify sender identity
-  void $ getSenderIdentity qusr c msg.sender
-
   foldQualified
     loc
     (postMLSMessageToLocalConv qusr c con msg)
     (postMLSMessageToRemoteConv loc qusr c con msg)
     qconvOrSub
 
 getSenderIdentity ::
+  ( Member (ErrorS 'MLSClientSenderUserMismatch) r,
+    Member (Error MLSProtocolError) r
+  ) =>
   Qualified UserId ->
   ClientId ->
-  Maybe Sender ->
+  Sender ->
+  Local ConvOrSubConv ->
   Sem r ClientIdentity
-getSenderIdentity qusr c _mSender = do
+getSenderIdentity qusr c mSender lConvOrSubConv = do
   let cid = mkClientIdentity qusr c
-  -- TODO: check that mSender matches cid
+  let idxMap = indexMapConvOrSub $ tUnqualified lConvOrSubConv
+  let epoch = epochNumber . cnvmlsEpoch . mlsMetaConvOrSub . tUnqualified $ lConvOrSubConv
+  case mSender of
+    SenderMember idx | epoch > 0 -> do
+      cid' <- note (mlsProtocolError "unknown sender leaf index") $ imLookup idxMap idx
+      unless (cid' == cid) $ throwS @'MLSClientSenderUserMismatch
+    _ -> pure ()
   pure cid
 
 postMLSMessageToLocalConv ::
   ( HasProposalEffects r,
     Member (ErrorS 'ConvNotFound) r,
-    Member (ErrorS 'MissingLegalholdConsent) r,
-    Member (ErrorS 'MLSCommitMissingReferences) r,
-    Member (ErrorS 'MLSProposalNotFound) r,
-    Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
+    Member (ErrorS 'MLSClientSenderUserMismatch) r,
     Member (ErrorS 'MLSStaleMessage) r,
     Member (ErrorS 'MLSUnsupportedMessage) r,
-    Member (ErrorS 'MLSSubConvClientNotInParent) r,
-    Member Resource r,
     Member SubConversationStore r
   ) =>
   Qualified UserId ->
@@ -487,13 +485,13 @@ postMLSMessageToLocalConv ::
 postMLSMessageToLocalConv qusr c con msg convOrSubId = do
   lConvOrSub <- fetchConvOrSub qusr convOrSubId
 
-  senderIdentity <- getSenderIdentity qusr c msg.sender
+  for_ msg.sender $ \sender ->
+    void $ getSenderIdentity qusr c sender lConvOrSub
 
   -- validate message
   events <- case msg.content of
     IncomingMessageContentPublic pub -> case pub.content of
-      FramedContentCommit commit ->
-        processCommit senderIdentity con lConvOrSub msg.epoch pub.sender commit.rmValue
+      FramedContentCommit _commit -> throwS @'MLSUnsupportedMessage
       FramedContentApplicationData _ -> throwS @'MLSUnsupportedMessage
       FramedContentProposal prop ->
         processProposal qusr lConvOrSub msg pub prop $> mempty
@@ -602,11 +600,12 @@ getCommitData ::
     Member (ErrorS 'MLSProposalNotFound) r,
     Member (ErrorS 'MLSStaleMessage) r
   ) =>
+  ClientIdentity ->
   Local ConvOrSubConv ->
   Epoch ->
   Commit ->
   Sem r ProposalAction
-getCommitData lConvOrSub epoch commit = do
+getCommitData senderIdentity lConvOrSub epoch commit = do
   let convOrSub = tUnqualified lConvOrSub
       mlsMeta = mlsMetaConvOrSub convOrSub
       curEpoch = cnvmlsEpoch mlsMeta
@@ -615,39 +614,22 @@ getCommitData lConvOrSub epoch commit = do
 
   -- check epoch number
   when (epoch /= curEpoch) $ throwS @'MLSStaleMessage
-  foldMap
-    ( applyProposalRef
-        (idForConvOrSub convOrSub)
-        (indexMapConvOrSub convOrSub)
-        mlsMeta
-        groupId
-        epoch
-        suite
-    )
-    (cProposals commit)
-
-processCommit ::
-  ( HasProposalEffects r,
-    Member (ErrorS 'ConvNotFound) r,
-    Member (ErrorS 'MissingLegalholdConsent) r,
-    Member (ErrorS 'MLSCommitMissingReferences) r,
-    Member (ErrorS 'MLSProposalNotFound) r,
-    Member (ErrorS 'MLSSelfRemovalNotAllowed) r,
-    Member (ErrorS 'MLSStaleMessage) r,
-    Member (ErrorS 'MLSSubConvClientNotInParent) r,
-    Member Resource r,
-    Member SubConversationStore r
-  ) =>
-  ClientIdentity ->
-  Maybe ConnId ->
-  Local ConvOrSubConv ->
-  Epoch ->
-  Sender ->
-  Commit ->
-  Sem r [LocalConversationUpdate]
-processCommit senderIdentity con lConvOrSub epoch sender commit = do
-  action <- getCommitData lConvOrSub epoch commit
-  processCommitWithAction senderIdentity con lConvOrSub epoch action sender commit
+  evalState (indexMapConvOrSub convOrSub) $ do
+    creatorAction <-
+      if epoch == Epoch 0
+        then addProposedClient senderIdentity
+        else mempty
+    action <-
+      foldMap
+        ( applyProposalRef
+            (idForConvOrSub convOrSub)
+            mlsMeta
+            groupId
+            epoch
+            suite
+        )
+        (cProposals commit)
+    pure (creatorAction <> action)
 
 processExternalCommit ::
   forall r.
@@ -804,52 +786,57 @@ processInternalCommit senderIdentity con lConvOrSub epoch action commit = do
 
 applyProposalRef ::
   ( HasProposalEffects r,
-    ( Member (ErrorS 'ConvNotFound) r,
-      Member (ErrorS 'MLSProposalNotFound) r,
-      Member (ErrorS 'MLSStaleMessage) r,
-      Member ProposalStore r
-    )
+    Member (State IndexMap) r,
+    Member (ErrorS 'ConvNotFound) r,
+    Member (ErrorS 'MLSProposalNotFound) r,
+    Member (ErrorS 'MLSStaleMessage) r
   ) =>
   ConvOrSubConvId ->
-  IndexMap ->
   ConversationMLSData ->
   GroupId ->
   Epoch ->
   CipherSuiteTag ->
   ProposalOrRef ->
   Sem r ProposalAction
-applyProposalRef convOrSubConvId im mlsMeta groupId epoch _suite (Ref ref) = do
+applyProposalRef convOrSubConvId mlsMeta groupId epoch _suite (Ref ref) = do
   p <- getProposal groupId epoch ref >>= noteS @'MLSProposalNotFound
   checkEpoch epoch mlsMeta
   checkGroup groupId mlsMeta
-  applyProposal convOrSubConvId im groupId (rmValue p)
-applyProposalRef convOrSubConvId im _mlsMeta groupId _epoch suite (Inline p) = do
+  applyProposal convOrSubConvId groupId (rmValue p)
+applyProposalRef convOrSubConvId _mlsMeta groupId _epoch suite (Inline p) = do
   checkProposalCipherSuite suite p
-  applyProposal convOrSubConvId im groupId p
+  applyProposal convOrSubConvId groupId p
+
+addProposedClient :: Member (State IndexMap) r => ClientIdentity -> Sem r ProposalAction
+addProposedClient cid = do
+  im <- get
+  let (idx, im') = imAddClient im cid
+  put im'
+  pure (paAddClient cid idx)
 
 applyProposal ::
   forall r.
-  HasProposalEffects r =>
+  ( HasProposalEffects r,
+    Member (State IndexMap) r
+  ) =>
   ConvOrSubConvId ->
-  IndexMap ->
   GroupId ->
   Proposal ->
   Sem r ProposalAction
-applyProposal _convOrSubConvId im _groupId (AddProposal kp) = do
-  let idx = imNextIndex im
+applyProposal _convOrSubConvId _groupId (AddProposal kp) = do
   -- 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 im _groupId (RemoveProposal idx) = do
-  cid <- noteS @'MLSInvalidLeafNodeIndex $ imLookup im idx
+  addProposedClient cid
+applyProposal _convOrSubConvId _groupId (RemoveProposal idx) = do
+  im <- get
+  (cid, im') <- noteS @'MLSInvalidLeafNodeIndex $ imRemoveClient im idx
+  put im'
   pure (paRemoveClient cid idx)
-applyProposal _convOrSubConvId _im _groupId (ExternalInitProposal _) =
+applyProposal _convOrSubConvId _groupId (ExternalInitProposal _) =
   -- only record the fact there was an external init proposal, but do not
   -- process it in any way.
   pure paExternalInitPresent
-applyProposal _convOrSubConvId _im _groupId _ = pure mempty
+applyProposal _convOrSubConvId _groupId _ = pure mempty
 
 checkProposalCipherSuite ::
   Member (Error MLSProtocolError) r =>

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

@@ -143,7 +143,7 @@ getLocalSubConversation qusr lconv sconv = do
                       cnvmlsCipherSuite = suite
                     },
                 scMembers = mkClientMap [],
-                scIndexMap = mempty -- TODO
+                scIndexMap = mempty
               }
       pure sub
     Just sub -> pure sub

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

@@ -29,21 +29,33 @@ import Imports
 import Wire.API.Conversation
 import Wire.API.Conversation.Protocol
 import Wire.API.MLS.Credential
+import Wire.API.MLS.LeafNode
 import Wire.API.MLS.SubConversation
 
 newtype IndexMap = IndexMap {unIndexMap :: IntMap ClientIdentity}
   deriving (Eq, Show)
   deriving newtype (Semigroup, Monoid)
 
-imLookup :: IndexMap -> Word32 -> Maybe ClientIdentity
+mkIndexMap :: ClientMap -> IndexMap
+mkIndexMap = IndexMap . IntMap.fromList . map (swap . fmap fromIntegral) . cmAssocs
+
+imLookup :: IndexMap -> LeafIndex -> Maybe ClientIdentity
 imLookup m i = IntMap.lookup (fromIntegral i) (unIndexMap m)
 
-imNextIndex :: IndexMap -> Word32
+imNextIndex :: IndexMap -> LeafIndex
 imNextIndex im =
   fromIntegral . fromJust $
     find (\n -> not $ IntMap.member n (unIndexMap im)) [0 ..]
 
-type ClientMap = Map (Qualified UserId) (Map ClientId Word32)
+imAddClient :: IndexMap -> ClientIdentity -> (LeafIndex, IndexMap)
+imAddClient im cid = let idx = imNextIndex im in (idx, IndexMap $ IntMap.insert (fromIntegral idx) cid $ unIndexMap im)
+
+imRemoveClient :: IndexMap -> LeafIndex -> Maybe (ClientIdentity, IndexMap)
+imRemoveClient im idx = do
+  cid <- imLookup im idx
+  pure (cid, IndexMap . IntMap.delete (fromIntegral idx) $ unIndexMap im)
+
+type ClientMap = Map (Qualified UserId) (Map ClientId LeafIndex)
 
 mkClientMap :: [(Domain, UserId, ClientId, Int32)] -> ClientMap
 mkClientMap = foldr addEntry mempty
@@ -52,7 +64,7 @@ mkClientMap = foldr addEntry mempty
     addEntry (dom, usr, c, kpi) =
       Map.insertWith (<>) (Qualified usr dom) (Map.singleton c (fromIntegral kpi))
 
-cmLookupIndex :: ClientIdentity -> ClientMap -> Maybe Word32
+cmLookupIndex :: ClientIdentity -> ClientMap -> Maybe LeafIndex
 cmLookupIndex cid cm = do
   clients <- Map.lookup (cidQualifiedUser cid) cm
   Map.lookup (ciClient cid) clients
@@ -69,13 +81,13 @@ cmRemoveClient cid cm = case Map.lookup (cidQualifiedUser cid) cm of
 isClientMember :: ClientIdentity -> ClientMap -> Bool
 isClientMember ci = isJust . cmLookupIndex ci
 
-cmAssocs :: ClientMap -> [(ClientIdentity, Word32)]
+cmAssocs :: ClientMap -> [(ClientIdentity, LeafIndex)]
 cmAssocs cm = do
   (quid, clients) <- Map.assocs cm
   (clientId, idx) <- Map.assocs clients
   pure (mkClientIdentity quid clientId, idx)
 
-cmSingleton :: ClientIdentity -> Word32 -> ClientMap
+cmSingleton :: ClientIdentity -> LeafIndex -> ClientMap
 cmSingleton cid idx =
   Map.singleton
     (cidQualifiedUser cid)

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

@@ -26,7 +26,7 @@ import Data.Id
 import qualified Data.Map as Map
 import Data.Qualified
 import Data.Time.Clock
-import Galley.API.MLS.Types (SubConversation (..))
+import Galley.API.MLS.Types
 import Galley.Cassandra.Conversation.MLS (lookupMLSClients)
 import qualified Galley.Cassandra.Queries as Cql
 import Galley.Cassandra.Store (embedClient)
@@ -57,7 +57,7 @@ selectSubConversation convId subConvId = do
                 cnvmlsCipherSuite = suite
               },
           scMembers = cm,
-          scIndexMap = mempty -- TODO
+          scIndexMap = mkIndexMap cm
         }
 
 insertSubConversation ::