wip

cassandra-schema.cql

@@ -1632,6 +1632,32 @@ CREATE TABLE galley_test.mls_group_member_client (
     AND read_repair = 'BLOCKING'
     AND speculative_retry = '99p';
 
+CREATE TABLE galley_test.mls_history_client (
+    group_id blob,
+    id uuid,
+    key_package_ref blob,
+    leaf_node_index int,
+    removal_pending boolean,
+    PRIMARY KEY (group_id, id)
+) WITH CLUSTERING ORDER BY (id ASC)
+    AND additional_write_policy = '99p'
+    AND bloom_filter_fp_chance = 0.01
+    AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'}
+    AND cdc = false
+    AND comment = ''
+    AND compaction = {'class': 'org.apache.cassandra.db.compaction.SizeTieredCompactionStrategy', 'max_threshold': '32', 'min_threshold': '4'}
+    AND compression = {'chunk_length_in_kb': '16', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'}
+    AND memtable = 'default'
+    AND crc_check_chance = 1.0
+    AND default_time_to_live = 0
+    AND extensions = {}
+    AND gc_grace_seconds = 864000
+    AND max_index_interval = 2048
+    AND memtable_flush_period_in_ms = 0
+    AND min_index_interval = 128
+    AND read_repair = 'BLOCKING'
+    AND speculative_retry = '99p';
+
 CREATE TABLE galley_test.mls_proposal_refs (
     group_id blob,
     epoch bigint,

integration/test/MLS/Util.hs

@@ -46,6 +46,7 @@ import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUIDV4
 import GHC.Stack
 import Notifications
+import SetupHelpers (randomUUIDString)
 import System.Directory
 import System.Exit
 import System.FilePath
@@ -69,6 +70,9 @@ mkClientIdentity u c = do
 cid2Str :: ClientIdentity -> String
 cid2Str cid = cid.user <> ":" <> cid.client <> "@" <> cid.domain
 
+hid2Str :: String -> String
+hid2Str hid = "history-client:" <> hid
+
 data MessagePackage = MessagePackage
   { sender :: ClientIdentity,
     convId :: ConvId,
@@ -91,12 +95,22 @@ randomFileName = do
   (bd </>) . UUID.toString <$> liftIO UUIDV4.nextRandom
 
 mlscli :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
-mlscli mConvId cs cid args mbstdin = do
+mlscli mConvId cs cid = mlscli' mConvId cs (Right cid)
+
+-- TODO: (leif)
+mlscli' :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> Either String ClientIdentity -> [String] -> Maybe ByteString -> App ByteString
+mlscli' mConvId cs cid args mbstdin = do
   groupOut <- randomFileName
   let substOut = argSubst "<group-out>" groupOut
   let scheme = csSignatureScheme cs
 
-  gs <- getClientGroupState cid
+  gs <- case cid of
+    Right cid' -> getClientGroupState cid'
+    Left _ -> do
+      convId <- assertOne mConvId
+      state <- getMLSState
+      let keyStore = Map.findWithDefault mempty convId state.historyClientState
+      pure $ ClientGroupState mempty keyStore BasicCredentialType
 
   substIn <- case flip Map.lookup gs.groups =<< mConvId of
     Nothing -> pure id
@@ -106,7 +120,7 @@ mlscli mConvId cs cid args mbstdin = do
   store <- case Map.lookup scheme gs.keystore of
     Nothing -> do
       bd <- getBaseDir
-      liftIO (createDirectory (bd </> cid2Str cid))
+      liftIO (createDirectory (bd </> either hid2Str cid2Str cid))
         `catch` \e ->
           if (isAlreadyExistsError e)
             then pure () -- creates a file per signature scheme
@@ -115,7 +129,7 @@ mlscli mConvId cs cid args mbstdin = do
       -- initialise new keystore
       path <- randomFileName
       ctype <- make gs.credType & asString
-      void $ runCli path ["init", "--ciphersuite", cs.code, "-t", ctype, cid2Str cid] Nothing
+      void $ runCli path ["init", "--ciphersuite", cs.code, "-t", ctype, either hid2Str cid2Str cid] Nothing
       pure path
     Just s -> toRandomFile s
 
@@ -136,11 +150,15 @@ mlscli mConvId cs cid args mbstdin = do
         print =<< liftIO (prettierCallStack callStack)
         pure id
       _ -> pure id
-  setStore <- do
-    storeData <- liftIO (BS.readFile store)
-    pure $ \x -> x {keystore = Map.insert scheme storeData x.keystore}
+  storeData <- liftIO (BS.readFile store)
+  let setStore x = x {keystore = Map.insert scheme storeData x.keystore}
 
-  setClientGroupState cid (setGroup (setStore gs))
+  case cid of
+    Right cid' -> setClientGroupState cid' (setGroup (setStore gs))
+    Left _ -> do
+      convId <- assertOne mConvId
+      modifyMLSState $ \s ->
+        s {historyClientState = Map.alter (Just . Map.insert scheme storeData . fromMaybe mempty) convId s.historyClientState}
 
   pure out
 
@@ -218,10 +236,19 @@ generateKeyPackage :: (HasCallStack) => ClientIdentity -> Ciphersuite -> App (By
 generateKeyPackage cid suite = do
   kp <- mlscli Nothing suite cid ["key-package", "create", "--ciphersuite", suite.code] Nothing
   ref <- B8.unpack . Base64.encode <$> mlscli Nothing suite cid ["key-package", "ref", "-"] (Just kp)
-  fp <- keyPackageFile cid ref
+  fp <- keyPackageFile (cid2Str cid) ref
   liftIO $ BS.writeFile fp kp
   pure (kp, ref)
 
+generateHistoryClient :: (HasCallStack) => ConvId -> Ciphersuite -> App (ByteString, String, String)
+generateHistoryClient convId suite = do
+  hid <- randomUUIDString
+  kp <- mlscli' (Just convId) suite (Left hid) ["key-package", "create", "--ciphersuite", suite.code] Nothing
+  ref <- B8.unpack . Base64.encode <$> mlscli' (Just convId) suite (Left hid) ["key-package", "ref", "-"] (Just kp)
+  fp <- keyPackageFile (hid2Str hid) ref
+  liftIO $ BS.writeFile fp kp
+  pure (kp, ref, hid)
+
 -- | Create conversation and corresponding group.
 createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App ConvId
 createNewGroup cs cid = createNewGroupWith cs cid defMLS
@@ -348,11 +375,11 @@ resetClientGroup cs cid gid convId keys = do
       ]
       (Just removalKey)
 
-keyPackageFile :: (HasCallStack) => ClientIdentity -> String -> App FilePath
-keyPackageFile cid ref = do
+keyPackageFile :: (HasCallStack) => String -> String -> App FilePath
+keyPackageFile name ref = do
   let ref' = map urlSafe ref
   bd <- getBaseDir
-  pure $ bd </> cid2Str cid </> ref'
+  pure $ bd </> name </> ref'
   where
     urlSafe '+' = '-'
     urlSafe '/' = '_'
@@ -383,7 +410,7 @@ createAddCommit cid convId users = do
   kps <- fmap concat . for users $ \user -> do
     bundle <- claimKeyPackages conv.ciphersuite cid user >>= getJSON 200
     unbundleKeyPackages bundle
-  createAddCommitWithKeyPackages cid convId kps
+  createAddCommitWithKeyPackages cid convId kps Nothing
 
 withTempKeyPackageFile :: ByteString -> ContT a App FilePath
 withTempKeyPackageFile bs = do
@@ -396,19 +423,29 @@ withTempKeyPackageFile bs = do
         liftIO $ BS.hPut h bs `finally` hClose h
         k fp
 
+createAddCommitWithHistoryClient :: (HasCallStack) => ClientIdentity -> ConvId -> [Value] -> App MessagePackage
+createAddCommitWithHistoryClient cid convId users = do
+  conv <- getMLSConv convId
+  kps <- fmap concat . for users $ \user -> do
+    bundle <- claimKeyPackages conv.ciphersuite cid user >>= getJSON 200
+    unbundleKeyPackages bundle
+  (hckp, _, _) <- generateHistoryClient convId conv.ciphersuite
+  createAddCommitWithKeyPackages cid convId kps (Just hckp)
+
 createAddCommitWithKeyPackages ::
   (HasCallStack) =>
   ClientIdentity ->
   ConvId ->
   [(ClientIdentity, ByteString)] ->
+  Maybe ByteString ->
   App MessagePackage
-createAddCommitWithKeyPackages cid convId clientsAndKeyPackages = do
+createAddCommitWithKeyPackages cid convId clientsAndKeyPackages hckp = do
   bd <- getBaseDir
   welcomeFile <- liftIO $ emptyTempFile bd "welcome"
   giFile <- liftIO $ emptyTempFile bd "gi"
   Just conv <- Map.lookup convId . (.convs) <$> getMLSState
 
-  commit <- runContT (traverse (withTempKeyPackageFile . snd) clientsAndKeyPackages) $ \kpFiles ->
+  commit <- runContT (traverse withTempKeyPackageFile (maybeToList hckp <> fmap snd clientsAndKeyPackages)) $ \kpFiles ->
     mlscli
       (Just convId)
       conv.ciphersuite

integration/test/Test/MLS/History.hs

@@ -137,6 +137,34 @@ testSetHistory = do
   conv <- getConversation alice convId >>= getJSON 200
   conv %. "history" `shouldMatch` history
 
+testHistoryConflict :: App ()
+testHistoryConflict = do
+  (alice, tid, [bob]) <- createTeam OwnDomain 2
+
+  I.setTeamFeatureLockStatus alice tid "channels" "unlocked"
+  setTeamFeatureConfig alice tid "channels" channelsConfig >>= assertSuccess
+
+  let history = object ["depth" .= "infinite"]
+
+  [alice1, bob1] <- traverse (createMLSClient def) [alice, bob]
+  void $ uploadNewKeyPackage def bob1
+  convId <-
+    createNewGroupWith
+      def
+      alice1
+      defMLS
+        { team = Just tid,
+          groupConvType = Just "channel"
+        }
+
+  bindResponse (updateHistory alice convId history) $ \resp -> do
+    resp.status `shouldMatchInt` 200
+
+  mp <- createAddCommit alice1 convId [bob]
+  postMLSCommitBundle mp.sender (mkBundle mp) `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 400
+    resp.json %. "label" `shouldMatch` "mls-history-client-conflict"
+
 channelsConfig :: Value
 channelsConfig =
   object

integration/test/Testlib/Env.hs

@@ -217,7 +217,8 @@ mkMLSState = Codensity $ \k ->
       MLSState
         { baseDir = tmp,
           convs = mempty,
-          clientGroupState = mempty
+          clientGroupState = mempty,
+          historyClientState = mempty
         }
 
 getMLSConv :: (HasCallStack) => ConvId -> App MLSConv

integration/test/Testlib/Types.hs

@@ -358,7 +358,8 @@ instance ToJSON ConvId where
 data MLSState = MLSState
   { baseDir :: FilePath,
     convs :: Map ConvId MLSConv,
-    clientGroupState :: Map ClientIdentity ClientGroupState
+    clientGroupState :: Map ClientIdentity ClientGroupState,
+    historyClientState :: Map ConvId (Map String ByteString)
   }
   deriving (Show)
 

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

@@ -179,6 +179,7 @@ data GalleyError
   | MLSReadReceiptsNotAllowed
   | MLSInvalidLeafNodeSignature
   | MeetingNotFound
+  | MLSHistoryClientConflict
   deriving (Show, Eq, Generic)
   deriving (FromJSON, ToJSON) via (CustomEncoded GalleyError)
 
@@ -379,6 +380,8 @@ type instance MapError 'MLSReadReceiptsNotAllowed = 'StaticError 403 "mls-receip
 
 type instance MapError 'MLSInvalidLeafNodeSignature = 'StaticError 400 "mls-invalid-leaf-node-signature" "Invalid leaf node signature"
 
+type instance MapError 'MLSHistoryClientConflict = 'StaticError 400 "mls-history-client-conflict" "History sharing settings of the conversation are conflicting with this request"
+
 --------------------------------------------------------------------------------
 -- Meeting errors
 
@@ -631,7 +634,7 @@ data GroupInfoDiagnostics = GroupInfoDiagnostics
   { commit :: ByteString,
     groupInfo :: ByteString,
     groupId :: GroupId,
-    clients :: [(Int, ClientIdentity)],
+    clients :: [(Int, GroupMember)],
     convId :: ConvOrSubConvId,
     domain :: Domain
   }
@@ -649,7 +652,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,34 @@ 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)
+
+isHistoryClient :: GroupMember -> Bool
+isHistoryClient (HistoryClient _) = True
+isHistoryClient (RegularClient _) = False
+
+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 +173,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)