wip: client identity refactoring

Author: battermann

libs/wire-api/src/Wire/API/Error/Galley.hs

@@ -631,7 +631,7 @@ data GroupInfoDiagnostics = GroupInfoDiagnostics
   { commit :: ByteString,
     groupInfo :: ByteString,
     groupId :: GroupId,
-    clients :: [(Int, ClientIdentity)],
+    clients :: [(Int, GroupMember)],
     convId :: ConvOrSubConvId,
     domain :: Domain
   }
@@ -649,7 +649,7 @@ instance APIError GroupInfoDiagnostics where
         headers = []
       }
 
-indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, ClientIdentity)
+indexedClientSchema :: ValueSchema NamedSwaggerDoc (Int, GroupMember)
 indexedClientSchema =
   object $
     (,)

libs/wire-api/src/Wire/API/MLS/Credential.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 -- This file is part of the Wire Server implementation.
 --
 -- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
@@ -17,7 +19,7 @@
 
 module Wire.API.MLS.Credential where
 
-import Control.Lens ((?~))
+import Control.Lens (makePrisms, (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Binary
 import Data.Binary.Get
@@ -167,3 +169,11 @@ instance SerialiseMLS ClientIdentity where
 
 mkClientIdentity :: Qualified UserId -> ClientId -> ClientIdentity
 mkClientIdentity (Qualified uid domain) = ClientIdentity domain uid
+
+makePrisms ''GroupMember
+
+instance ToSchema GroupMember where
+  schema =
+    named "GroupMember" $
+      tag _RegularClient (unnamed schema)
+        <> tag _HistoryClient (unnamed schema)

libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/Core.hs

@@ -122,7 +122,7 @@ getCommitData senderIdentity lConvOrSub epoch ciphersuite bundle = do
   runState convOrSub.indexMap $ do
     creatorAction <-
       if epoch == Epoch 0
-        then addProposedClient (Left senderIdentity.client)
+        then addProposedClient (Left . RegularClient $ senderIdentity.client)
         else mempty
     proposals <-
       traverse
@@ -260,7 +260,7 @@ checkUpdatePath ::
 checkUpdatePath lConvOrSub senderIdentity ciphersuite path = for_ senderIdentity.index $ \index -> do
   let groupId = cnvmlsGroupId (tUnqualified lConvOrSub).mlsMeta
   let extra = LeafNodeTBSExtraCommit groupId index
-  case validateLeafNode ciphersuite (Just senderIdentity.client) extra path.leaf.value of
+  case validateLeafNode ciphersuite (Just . RegularClient $ senderIdentity.client) extra path.leaf.value of
     Left InvalidLeafNodeSignature -> throwS @'MLSInvalidLeafNodeSignature
     Left errMsg ->
       throw $

libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Commit/ExternalCommit.hs

@@ -114,7 +114,7 @@ getExternalCommitData senderIdentity lConvOrSub epoch commit = do
 
     -- add sender client
     im <- get
-    let (addedIndex, im') = imAddClient im senderIdentity
+    let (addedIndex, im') = imAddClient im (RegularClient senderIdentity)
     put im'
 
     pure

libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Proposal.hs

@@ -80,26 +80,26 @@ import Wire.Util
 data ProposalAction = ProposalAction
   { paAdd :: ClientMap (LeafIndex, Maybe KeyPackage),
     paRemove :: ClientMap LeafIndex,
-    historyClientAction :: Maybe HistoryClientAction
+    paHistoryClientAdd :: Maybe (HistoryClientId, LeafIndex, Maybe KeyPackage),
+    paHistoryClientRemove :: Maybe (HistoryClientId, LeafIndex)
   }
   deriving (Show)
 
-data HistoryClientAction
-  = AddHistoryClient HistoryClientId
-  | RemoveHistoryClient HistoryClientId
-
+-- TODO: (leif) check this
 instance Semigroup ProposalAction where
-  ProposalAction add1 rem1 <> ProposalAction add2 rem2 =
-    ProposalAction (add1 <> add2) (rem1 <> rem2)
+  ProposalAction add1 rem1 hadd1 hrem1 <> ProposalAction add2 rem2 hadd2 hrem2 =
+    ProposalAction (add1 <> add2) (rem1 <> rem2) (hadd1 <|> hadd2) (hrem1 <|> hrem2)
 
 instance Monoid ProposalAction where
-  mempty = ProposalAction mempty mempty
+  mempty = ProposalAction mempty mempty Nothing Nothing
 
 paAddClient :: GroupMember -> LeafIndex -> Maybe KeyPackage -> ProposalAction
-paAddClient (RegularMember cid) idx kp = mempty {paAdd = cmSingleton cid (idx, kp)}
+paAddClient (RegularClient cid) idx kp = mempty {paAdd = cmSingleton cid (idx, kp)}
+paAddClient (HistoryClient hid) idx kp = mempty {paHistoryClientAdd = Just (hid, idx, kp)}
 
 paRemoveClient :: GroupMember -> LeafIndex -> ProposalAction
-paRemoveClient cid idx = mempty {paRemove = cmSingleton cid idx}
+paRemoveClient (RegularClient cid) idx = mempty {paRemove = cmSingleton cid idx}
+paRemoveClient (HistoryClient hid) idx = mempty {paHistoryClientRemove = Just (hid, idx)}
 
 -- | This is used to sort proposals into the correct processing order, as defined by the spec
 data ProposalProcessingStage
@@ -309,15 +309,18 @@ checkExternalProposalUser qusr prop = do
     loc
     ( \lusr -> case prop of
         AddProposal kp -> do
-          ClientIdentity {ciUser, ciClient} <- getKeyPackageIdentity kp.value
-          -- 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
-          UserClients {userClients} <- lookupClients [ciUser]
-          maybe
-            (throwS @'MLSUnsupportedProposal)
-            (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient))
-            $ userClients Map.!? ciUser
+          groupMember <- getKeyPackageIdentity kp.value
+          case groupMember of
+            RegularClient (ClientIdentity {ciUser, ciClient}) -> do 
+              -- 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
+              UserClients {userClients} <- lookupClients [ciUser]
+              maybe
+                (throwS @'MLSUnsupportedProposal)
+                (flip when (throwS @'MLSUnsupportedProposal) . Set.null . Set.filter (== ciClient))
+                $ userClients Map.!? ciUser
+            HistoryClient _ -> pure ()
         _ -> throwS @'MLSUnsupportedProposal
     )
     (const $ pure ()) -- FUTUREWORK: check external proposals from remote backends