wip: extend client identity

Author: battermann

libs/types-common/src/Data/Id.hs

@@ -58,6 +58,7 @@ module Data.Id
     OAuthRefreshTokenId,
     ChallengeId,
     MeetingId,
+    HistoryClientId,
 
     -- * Utils
     uuidSchema,
@@ -116,6 +117,7 @@ data IdTag
   | Challenge
   | Job
   | Meeting
+  | HistoryClient
 
 idTagName :: IdTag -> Text
 idTagName Asset = "Asset"
@@ -132,6 +134,7 @@ idTagName OAuthRefreshToken = "OAuthRefreshToken"
 idTagName Challenge = "Challenge"
 idTagName Job = "Job"
 idTagName Meeting = "Meeting"
+idTagName HistoryClient = "HistoryClient"
 
 class KnownIdTag (t :: IdTag) where
   idTagValue :: IdTag
@@ -162,6 +165,8 @@ instance KnownIdTag 'Job where idTagValue = Job
 
 instance KnownIdTag 'Meeting where idTagValue = Meeting
 
+instance KnownIdTag 'HistoryClient where idTagValue = HistoryClient
+
 type AssetId = Id 'Asset
 
 type InvitationId = Id 'Invitation
@@ -192,6 +197,8 @@ type JobId = Id 'Job
 
 type MeetingId = Id 'Meeting
 
+type HistoryClientId = Id 'HistoryClient
+
 -- Id -------------------------------------------------------------------------
 
 data NoId = NoId deriving (Eq, Show, Generic)

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
@@ -120,17 +122,30 @@ instance ToHttpApiData ClientIdentity where
   toHeader = encodeMLS'
   toUrlPiece = T.decodeUtf8 . encodeMLS'
 
+parseId :: Get (Id a)
+parseId = maybe (fail "Invalid UUID") (pure . Id) . fromASCIIBytes =<< getByteString 36
+
 instance ParseMLS ClientIdentity where
   parseMLS = do
-    uid <-
-      maybe (fail "Invalid UUID") (pure . Id) . fromASCIIBytes =<< getByteString 36
+    uid <- parseId
     char ':'
     cid <- ClientId <$> hexadecimal
     char '@'
     dom <-
       either fail pure . (mkDomain . T.pack) =<< many' anyChar
     pure $ ClientIdentity dom uid cid
 
+data GroupMember = RegularClient ClientIdentity | HistoryClient HistoryClientId
+  deriving (Eq, Show)
+
+parseHistoryClient :: Get HistoryClientId
+parseHistoryClient = string "history-client:" *> parseId
+
+instance ParseMLS GroupMember where
+  parseMLS =
+    (HistoryClient <$> parseHistoryClient)
+      <|> (RegularClient <$> parseMLS)
+
 -- format of the x509 client identity: {userid}%21{deviceid}@{host}
 parseX509ClientIdentity :: Get ClientIdentity
 parseX509ClientIdentity = do
@@ -154,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-api/src/Wire/API/MLS/KeyPackage.hs

@@ -233,7 +233,7 @@ instance HasField "extensions" KeyPackage [Extension] where
 instance HasField "leafNode" KeyPackage LeafNode where
   getField = (.tbs.value.leafNode)
 
-credentialIdentityAndKey :: Credential -> Either Text (ClientIdentity, Maybe X509.PubKey)
+credentialIdentityAndKey :: Credential -> Either Text (GroupMember, Maybe X509.PubKey)
 credentialIdentityAndKey (BasicCredential i) = (,) <$> decodeMLS' i <*> pure Nothing
 credentialIdentityAndKey (X509Credential certs) = do
   bs <- case certs of
@@ -244,9 +244,9 @@ credentialIdentityAndKey (X509Credential certs) = do
       X509.decodeSignedCertificate bs
   -- FUTUREWORK: verify signature
   let cert = X509.getCertificate signed
-  certificateIdentityAndKey cert
+  first RegularClient <$> certificateIdentityAndKey cert
 
-keyPackageIdentity :: KeyPackage -> Either Text ClientIdentity
+keyPackageIdentity :: KeyPackage -> Either Text GroupMember
 keyPackageIdentity kp = fst <$> credentialIdentityAndKey kp.leafNode.credential
 
 certificateIdentityAndKey :: X509.Certificate -> Either Text (ClientIdentity, Maybe X509.PubKey)

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

@@ -39,7 +39,7 @@ import Wire.API.MLS.Serialisation
 import Wire.API.MLS.Validation.Error
 
 validateKeyPackage ::
-  Maybe ClientIdentity ->
+  Maybe GroupMember ->
   KeyPackage ->
   Either ValidationError (CipherSuiteTag, Lifetime)
 validateKeyPackage mIdentity kp = do
@@ -79,7 +79,7 @@ validateKeyPackage mIdentity kp = do
 
 validateLeafNode ::
   CipherSuiteTag ->
-  Maybe ClientIdentity ->
+  Maybe GroupMember ->
   LeafNodeTBSExtra ->
   LeafNode ->
   Either ValidationError ()
@@ -99,7 +99,12 @@ validateLeafNode cs mIdentity extra leafNode = do
   validateSource extra.tag leafNode.source
   validateCapabilities (credentialTag leafNode.credential) leafNode.capabilities
 
-validateCredential :: CipherSuiteTag -> ByteString -> Maybe ClientIdentity -> Credential -> Either ValidationError ()
+validateCredential ::
+  CipherSuiteTag ->
+  ByteString ->
+  Maybe GroupMember ->
+  Credential ->
+  Either ValidationError ()
 validateCredential cs pkey mIdentity cred = do
   -- FUTUREWORK: check signature in the case of an x509 credential
   (identity, mkey) <-

libs/wire-api/test/unit/Test/Wire/API/MLS.hs

@@ -89,7 +89,7 @@ testParseKeyPackage = do
 
   case keyPackageIdentity kp of
     Left err -> assertFailure $ "Failed to parse identity: " <> T.unpack err
-    Right identity -> identity @?= alice
+    Right identity -> identity @?= RegularClient alice
 
 testParseKeyPackageWithCapabilities :: IO ()
 testParseKeyPackageWithCapabilities = do

libs/wire-subsystems/src/Wire/ConversationStore/Cassandra.hs

@@ -768,7 +768,9 @@ addBotMember s bot cnv = do
 lookupMLSClientLeafIndices :: GroupId -> Client (ClientMap LeafIndex, IndexMap)
 lookupMLSClientLeafIndices groupId = do
   entries <- retry x5 (query Cql.lookupMLSClients (params LocalQuorum (Identity groupId)))
-  pure $ (mkClientMap &&& mkIndexMap) entries
+  -- TODO: (leif) lookup history client
+  historyClientEntries <- todo
+  pure $ (mkClientMap entries, mkIndexMapFromParts entries historyClientEntries )
 
 lookupMLSClients :: GroupId -> Client (ClientMap LeafIndex)
 lookupMLSClients = fmap fst . lookupMLSClientLeafIndices

libs/wire-subsystems/src/Wire/ConversationStore/MLS/Types.hs

@@ -54,6 +54,17 @@ import Wire.API.MLS.LeafNode
 import Wire.API.MLS.SubConversation
 import Wire.StoredConversation
 
+mkGroupMember ::
+  Maybe Domain ->
+  Maybe UserId ->
+  Maybe ClientId ->
+  Maybe HistoryClientId ->
+  Maybe GroupMember
+mkGroupMember (Just dom) (Just uid) (Just cid) Nothing =
+  Just (RegularClient (ClientIdentity dom uid cid))
+mkGroupMember Nothing Nothing Nothing (Just hid) = Just (HistoryClient hid)
+mkGroupMember _ _ _ _ = Nothing
+
 -- | A map of leaf index to members.
 --
 -- This is used to reconstruct client
@@ -63,31 +74,40 @@ import Wire.StoredConversation
 -- Note that clients that are in the process of being removed from a group
 -- (i.e. there is a pending remove proposals for them) are included in this
 -- mapping.
-newtype IndexMap = IndexMap {unIndexMap :: IntMap ClientIdentity}
+newtype IndexMap = IndexMap {unIndexMap :: IntMap GroupMember}
   deriving (Eq, Show)
   deriving newtype (Semigroup, Monoid)
 
-mkIndexMap :: [(Domain, UserId, ClientId, Int32, Bool)] -> IndexMap
-mkIndexMap = IndexMap . foldr addEntry mempty
+mkIndexMapFromParts ::
+  [(Domain, UserId, ClientId, Int32, Bool)] ->
+  [(HistoryClientId, Int32, Bool)] ->
+  IndexMap
+mkIndexMapFromParts rows1 rows2 =
+  IndexMap
+    . flip (foldr addHistoryClient) rows2
+    . flip (foldr addRegularClient) rows1
+    $ mempty
   where
-    addEntry (dom, usr, c, leafidx, _pending_removal) =
-      IntMap.insert (fromIntegral leafidx) (ClientIdentity dom usr c)
+    addHistoryClient (h, leafidx, _) =
+      IntMap.insert (fromIntegral leafidx) (HistoryClient h)
+    addRegularClient (dom, usr, c, leafidx, _) =
+      IntMap.insert (fromIntegral leafidx) (RegularClient (ClientIdentity dom usr c))
 
-imLookup :: IndexMap -> LeafIndex -> Maybe ClientIdentity
+imLookup :: IndexMap -> LeafIndex -> Maybe GroupMember
 imLookup m i = IntMap.lookup (fromIntegral i) (unIndexMap m)
 
-imFromList :: [(LeafIndex, ClientIdentity)] -> IndexMap
+imFromList :: [(LeafIndex, GroupMember)] -> IndexMap
 imFromList = IndexMap . IntMap.fromList . map (first fromIntegral)
 
 imNextIndex :: IndexMap -> LeafIndex
 imNextIndex im =
   fromIntegral . fromJust $
     find (\n -> not $ IntMap.member n (unIndexMap im)) [0 ..]
 
-imAddClient :: IndexMap -> ClientIdentity -> (LeafIndex, IndexMap)
+imAddClient :: IndexMap -> GroupMember -> (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 :: IndexMap -> LeafIndex -> Maybe (GroupMember, IndexMap)
 imRemoveClient im idx = do
   cid <- imLookup im idx
   pure (cid, IndexMap . IntMap.delete (fromIntegral idx) $ unIndexMap im)
@@ -98,7 +118,7 @@ imRemoveIndices keys =
     . flip IntMap.withoutKeys (IntSet.fromList (map fromIntegral keys))
     . unIndexMap
 
-imAssocs :: IndexMap -> [(Int, ClientIdentity)]
+imAssocs :: IndexMap -> [(Int, GroupMember)]
 imAssocs = IntMap.assocs . unIndexMap
 
 -- | A two-level map of users to clients to leaf indices.
@@ -111,6 +131,7 @@ imAssocs = IntMap.assocs . unIndexMap
 -- this mapping.
 newtype ClientMap a = ClientMap
   { unClientMap :: Map (Qualified UserId) (Map ClientId a)
+  -- TODO: add historyClients
   }
   deriving (Show, Eq, Functor)
 

libs/wire-subsystems/src/Wire/ConversationStore/Migration.hs

@@ -237,6 +237,7 @@ deleteConvFromCassandra allConvData = withCassandra $ do
     Nothing -> deleteConversation allConvData.conv.id_
     Just tid -> deleteTeamConversation tid allConvData.conv.id_
 
+-- TODO: (leif) migrate history client data
 saveConvToPostgres :: (PGConstraints r) => AllConvData -> Sem r ()
 saveConvToPostgres allConvData = do
   let meta = storedConv.metadata
@@ -384,11 +385,12 @@ saveConvToPostgres allConvData = do
 
     mlsClientRows :: GroupId -> ClientMap LeafIndex -> IndexMap -> [(GroupId, Domain, UserId, ClientId, Int32, Bool)]
     mlsClientRows gid clientMap indexMap =
-      let clients :: [(LeafIndex, ClientIdentity, Bool)] =
-            IntMap.elems $
-              IntMap.mapWithKey
-                (\idx ci -> (fromIntegral idx, ci, isNothing (cmLookupIndex ci clientMap)))
-                indexMap.unIndexMap
+      let clients :: [(LeafIndex, ClientIdentity, Bool)] = do
+            (idx, element) <- IntMap.assocs indexMap.unIndexMap
+            case element of
+              RegularClient ci ->
+                pure (fromIntegral idx, ci, isNothing (cmLookupIndex ci clientMap))
+              HistoryClient _ -> []
        in flip map clients $ \(idx, ci, removalPending) ->
             (gid, ci.ciDomain, ci.ciUser, ci.ciClient, fromIntegral idx, removalPending)
 

libs/wire-subsystems/src/Wire/ConversationStore/Postgres.hs

@@ -1065,10 +1065,19 @@ selectMLSClients =
                      WHERE group_id = ($1 :: bytea)
                     |]
 
+selectHistoryClients :: Hasql.Statement GroupId [(HistoryClientId, Int32, Bool)]
+selectHistoryClients =
+  dimapPG
+    [vectorStatement|SELECT (id :: uuid), (leaf_node_index :: integer), (removal_pending :: bool)
+                     FROM mls_history_client
+                     WHERE group_id = ($1 :: bytea)
+                    |]
+
 lookupMLSClientLeafIndicesImpl :: (PGConstraints r) => GroupId -> Sem r (ClientMap LeafIndex, IndexMap)
 lookupMLSClientLeafIndicesImpl gid = do
-  rows <- runStatement gid selectMLSClients
-  pure (mkClientMap rows, mkIndexMap rows)
+  rows1 <- runStatement gid selectMLSClients
+  rows2 <- runStatement gid selectHistoryClients
+  pure (mkClientMap rows1, mkIndexMapFromParts rows1 rows2)
 
 -- SUB CONVERSATION OPERATIONS
 createSubConversationImpl :: (PGConstraints r) => ConvId -> SubConvId -> GroupId -> Sem r SubConversation