WPB-20806 Require history client when history sharing is enabled

cassandra-schema.cql

@@ -1632,6 +1632,31 @@ 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,
+    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,

changelog.d/2-features/WPB-20806

@@ -0,0 +1 @@
+Enforced history client invariants for conversation history sharing: enabled requires exactly one history client, disabled requires none.

integration/test/MLS/Util.hs

@@ -22,6 +22,7 @@ module MLS.Util where
 import API.Brig
 import API.BrigCommon
 import API.Galley
+import Control.Applicative
 import Control.Concurrent.Async hiding (link)
 import Control.Monad
 import Control.Monad.Catch
@@ -46,6 +47,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 +71,14 @@ mkClientIdentity u c = do
 cid2Str :: ClientIdentity -> String
 cid2Str cid = cid.user <> ":" <> cid.client <> "@" <> cid.domain
 
+hid2Str :: String -> String
+hid2Str hid = "history-client:" <> hid
+
+mem2Str :: GroupMember -> String
+mem2Str = \case
+  RegularClient cid -> cid2Str cid
+  HistoryClient hid -> hid2Str hid
+
 data MessagePackage = MessagePackage
   { sender :: ClientIdentity,
     convId :: ConvId,
@@ -91,12 +101,21 @@ 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 = mlscliGroupMem mConvId cs (RegularClient cid)
+
+mlscliGroupMem :: (HasCallStack) => Maybe ConvId -> Ciphersuite -> GroupMember -> [String] -> Maybe ByteString -> App ByteString
+mlscliGroupMem mConvId cs groupMem args mbstdin = do
   groupOut <- randomFileName
   let substOut = argSubst "<group-out>" groupOut
   let scheme = csSignatureScheme cs
 
-  gs <- getClientGroupState cid
+  gs <- case groupMem of
+    RegularClient cid -> getClientGroupState cid
+    HistoryClient hid -> do
+      convId <- assertOne mConvId
+      state <- getMLSState
+      let keyStore = Map.findWithDefault mempty (convId, hid) state.historyClientState
+      pure $ ClientGroupState mempty keyStore BasicCredentialType
 
   substIn <- case flip Map.lookup gs.groups =<< mConvId of
     Nothing -> pure id
@@ -106,7 +125,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 </> mem2Str groupMem))
         `catch` \e ->
           if (isAlreadyExistsError e)
             then pure () -- creates a file per signature scheme
@@ -115,7 +134,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, mem2Str groupMem] Nothing
       pure path
     Just s -> toRandomFile s
 
@@ -136,11 +155,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 groupMem of
+    RegularClient cid -> setClientGroupState cid (setGroup (setStore gs))
+    HistoryClient hid -> do
+      convId <- assertOne mConvId
+      modifyMLSState $ \s ->
+        s {historyClientState = Map.alter (Just . Map.insert scheme storeData . fromMaybe mempty) (convId, hid) s.historyClientState}
 
   pure out
 
@@ -218,10 +241,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 <- mlscliGroupMem (Just convId) suite (HistoryClient hid) ["key-package", "create", "--ciphersuite", suite.code] Nothing
+  ref <- B8.unpack . Base64.encode <$> mlscliGroupMem (Just convId) suite (HistoryClient 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 +380,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 +415,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 +428,30 @@ withTempKeyPackageFile bs = do
         liftIO $ BS.hPut h bs `finally` hClose h
         k fp
 
+createAddCommitWithHistoryClient :: (HasCallStack) => ClientIdentity -> ConvId -> [Value] -> App (MessagePackage, String)
+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, _, hid) <- generateHistoryClient convId conv.ciphersuite
+  mp <- createAddCommitWithKeyPackages cid convId kps (Just hckp)
+  pure (mp, hid)
+
 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
@@ -452,7 +495,10 @@ createAddCommitWithKeyPackages cid convId clientsAndKeyPackages = do
       }
 
 createRemoveCommit :: (HasCallStack) => ClientIdentity -> ConvId -> [ClientIdentity] -> App MessagePackage
-createRemoveCommit cid convId targets = do
+createRemoveCommit cid convId targets = createRemoveCommitGroupMember cid convId (fmap RegularClient targets)
+
+createRemoveCommitGroupMember :: (HasCallStack) => ClientIdentity -> ConvId -> [GroupMember] -> App MessagePackage
+createRemoveCommitGroupMember cid convId targets = do
   bd <- getBaseDir
   welcomeFile <- liftIO $ emptyTempFile bd "welcome"
   giFile <- liftIO $ emptyTempFile bd "gi"
@@ -485,12 +531,16 @@ createRemoveCommit cid convId targets = do
       )
       Nothing
 
+  let toRegular :: (Alternative f) => GroupMember -> f ClientIdentity
+      toRegular (RegularClient x) = pure x
+      toRegular (HistoryClient _) = empty
+
   modifyMLSState $ \mls ->
     mls
       { convs =
           Map.adjust
             ( \oldConvState ->
-                oldConvState {membersToBeRemoved = Set.fromList targets}
+                oldConvState {membersToBeRemoved = Set.fromList (foldMap toRegular targets)}
             )
             convId
             mls.convs
@@ -884,7 +934,7 @@ showMessage cs cid msg = do
   bs <- mlscli Nothing cs cid ["show", "message", "-"] (Just msg)
   assertOne (Aeson.decode (BS.fromStrict bs))
 
-readGroupState :: (HasCallStack) => ByteString -> App [(ClientIdentity, Word32)]
+readGroupState :: (HasCallStack) => ByteString -> App [(GroupMember, Word32)]
 readGroupState gs = do
   v :: Value <- assertJust "Could not decode group state" (Aeson.decode (BS.fromStrict gs))
   lnodes <- v %. "group" %. "public_group" %. "treesync" %. "tree" %. "leaf_nodes" & asList
@@ -897,10 +947,16 @@ readGroupState gs = do
             vecb <- lnode %. "payload" %. "credential" %. "credential" %. "Basic" %. "identity" %. "vec"
             vec <- asList vecb
             ws <- BS.pack <$> for vec (\x -> asIntegral @Word8 x)
-            [uc, domain] <- pure (C8.split '@' ws)
-            [uid, client] <- pure (C8.split ':' uc)
-            let cid = ClientIdentity (C8.unpack domain) (C8.unpack uid) (C8.unpack client)
-            pure (Just (cid, leafNodeIndex))
+            let prefix = fromString "history-client:"
+            if (prefix `BS.isPrefixOf` ws)
+              then do
+                let hid = BS.drop (BS.length prefix) ws
+                pure $ Just (HistoryClient $ C8.unpack hid, leafNodeIndex)
+              else do
+                [uc, domain] <- pure (C8.split '@' ws)
+                [uid, client] <- pure (C8.split ':' uc)
+                let cid = RegularClient $ ClientIdentity (C8.unpack domain) (C8.unpack uid) (C8.unpack client)
+                pure (Just (cid, leafNodeIndex))
       Nothing ->
         pure Nothing
 
@@ -1062,3 +1118,8 @@ resetMLSConversation cid conv = do
   keys <- getMLSPublicKeys cid >>= getJSON 200
   resetClientGroup mlsConv'.ciphersuite cid mlsConv'.groupId convId' keys
   pure conv'
+
+withMLSStateReset :: App a -> App a
+withMLSStateReset f = do
+  mlsState <- getMLSState
+  f <* modifyMLSState (const mlsState)

integration/test/Test/MLS.hs

@@ -311,7 +311,7 @@ testMixedProtocolAddPartialClients secondDomain = do
     bundle <- claimKeyPackages def alice1 bob >>= getJSON 200
     kps <- unbundleKeyPackages bundle
     kp1 <- assertOne (filter ((== bob1) . fst) kps)
-    mp <- createAddCommitWithKeyPackages alice1 convId [kp1]
+    mp <- createAddCommitWithKeyPackages alice1 convId [kp1] Nothing
     void $ sendAndConsumeCommitBundleWithProtocol MLSProtocolMixed mp
 
   -- this tests that bob's backend has a mapping of group id to the remote conv
@@ -320,7 +320,7 @@ testMixedProtocolAddPartialClients secondDomain = do
     bundle <- claimKeyPackages def bob1 bob >>= getJSON 200
     kps <- unbundleKeyPackages bundle
     kp2 <- assertOne (filter ((== bob2) . fst) kps)
-    mp <- createAddCommitWithKeyPackages bob1 convId [kp2]
+    mp <- createAddCommitWithKeyPackages bob1 convId [kp2] Nothing
     void $ postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201
 
 testMixedProtocolRemovePartialClients :: (HasCallStack) => Domain -> App ()
@@ -590,7 +590,7 @@ testFirstCommitAllowsPartialAdds = do
   kps <- unbundleKeyPackages bundle
 
   -- first commit only adds kp for alice2 (not alice2 and alice3)
-  mp <- createAddCommitWithKeyPackages alice1 convId (filter ((== alice2) . fst) kps)
+  mp <- createAddCommitWithKeyPackages alice1 convId (filter ((== alice2) . fst) kps) Nothing
   bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do
     resp.status `shouldMatchInt` 409
     resp.json %. "label" `shouldMatch` "mls-client-mismatch"
@@ -618,7 +618,7 @@ testAddUserPartial = do
   kps <- fmap concat . for [bob, charlie] $ \user -> do
     bundle <- claimKeyPackages def alice1 user >>= getJSON 200
     unbundleKeyPackages bundle
-  mp <- createAddCommitWithKeyPackages alice1 convId kps
+  mp <- createAddCommitWithKeyPackages alice1 convId kps Nothing
 
   -- before alice can commit, bob3 uploads a key package
   void $ uploadNewKeyPackage def bob3
@@ -970,7 +970,7 @@ testInternalCommitDuplicateClient = do
   -- We cannot upload the new key package at this point, because the
   -- signature key won't match. However, alice1 can still use it to craft an
   -- add proposal.
-  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)]
+  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)] Nothing
   bindResponse (postMLSCommitBundle alice1 (mkBundle mp)) $ \resp -> do
     resp.status `shouldMatchInt` 400
     resp.json %. "label" `shouldMatch` "mls-protocol-error"
@@ -1005,7 +1005,7 @@ testInternalCommitWrongSignatureKey = do
   setClientGroupState alice2 def
   (kp, _) <- generateKeyPackage alice2 def
 
-  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)]
+  mp <- createAddCommitWithKeyPackages alice1 convId [(alice2, kp)] Nothing
   bindResponse (postMLSCommitBundle alice1 (mkBundle mp)) $ \resp -> do
     resp.status `shouldMatchInt` 403
     resp.json %. "label" `shouldMatch` "mls-identity-mismatch"