diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 1896cafb28d..7266da60feb 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -189,7 +189,7 @@ createNewGroup :: (HasCallStack) => Ciphersuite -> ClientIdentity -> App (String createNewGroup cs cid = do conv <- postConversation cid defMLS >>= getJSON 201 groupId <- conv %. "group_id" & asString - convId <- objSubConvObject conv + convId <- objConvId conv createGroup cs cid conv pure (groupId, convId) @@ -208,8 +208,15 @@ createGroup cs cid conv = resetGroup cs cid conv createSubConv :: (HasCallStack) => Ciphersuite -> ConvId -> ClientIdentity -> String -> App () createSubConv cs convId cid subId = do sub <- getSubConversation cid convId subId >>= getJSON 200 + subConvId <- objConvId sub resetGroup cs cid sub - void $ createPendingProposalCommit convId cid >>= sendAndConsumeCommitBundle + void $ createPendingProposalCommit subConvId cid >>= tap "Pending Proposal Commit" >>= sendAndConsumeCommitBundle + +tap :: String -> MessagePackage -> App MessagePackage +tap tag x = do + j <- prettyJSON x.convId + putStrLn $ "Tap: " <> tag <> "\n" <> j + pure x createOne2OneSubConv :: (HasCallStack, MakesValue keys) => Ciphersuite -> ConvId -> ClientIdentity -> String -> keys -> App () createOne2OneSubConv cs convId cid subId keys = do @@ -219,14 +226,15 @@ createOne2OneSubConv cs convId cid subId keys = do resetGroup :: (HasCallStack, MakesValue conv) => Ciphersuite -> ClientIdentity -> conv -> App () resetGroup cs cid conv = do - convId <- objSubConvObject conv - groupId <- conv %. "group_id" & asString + convId <- objConvId conv + putStrLn =<< prettyJSON convId + let Just groupId = convId.groupId modifyMLSState $ \s -> let mlsConv = MLSConv { members = Set.singleton cid, newMembers = mempty, - groupId = groupId, + groupId, convId = convId, epoch = 0, ciphersuite = cs @@ -242,7 +250,7 @@ resetOne2OneGroup cs cid one2OneConv = -- | Useful when keys are to be taken from main conv and the conv here is the subconv resetOne2OneGroupGeneric :: (HasCallStack, MakesValue conv, MakesValue keys) => Ciphersuite -> ClientIdentity -> conv -> keys -> App () resetOne2OneGroupGeneric cs cid conv keys = do - convId <- objSubConvObject conv + convId <- objConvId conv groupId <- conv %. "group_id" & asString modifyMLSState $ \s -> let newMLSConv = @@ -558,18 +566,6 @@ createExternalCommit convId cid mgi = do data MLSNotificationTag = MLSNotificationMessageTag | MLSNotificationWelcomeTag deriving (Show, Eq, Ord) --- | Extract a conversation ID (including an optional subconversation) from an --- event object. -eventSubConv :: (HasCallStack) => (MakesValue event) => event -> App ConvId -eventSubConv event = do - sub <- lookupField event "subconv" - conv <- event %. "qualified_conversation" - objSubConvObject $ - object - [ "parent_qualified_id" .= conv, - "subconv_id" .= sub - ] - consumingMessages :: (HasCallStack) => MessagePackage -> Codensity App () consumingMessages mp = Codensity $ \k -> do conv <- getMLSConv mp.convId @@ -583,11 +579,11 @@ consumingMessages mp = Codensity $ \k -> do map (,MLSNotificationMessageTag) (toList oldClients) <> map (,MLSNotificationWelcomeTag) (toList newClients) - let newUsers = - Set.delete mp.sender.user $ - Set.difference - (Set.map (.user) newClients) - (Set.map (.user) oldClients) + -- let newUsers = + -- Set.delete mp.sender.user $ + -- Set.difference + -- (Set.map (.user) newClients) + -- (Set.map (.user) oldClients) withWebSockets (map fst clients) $ \wss -> do r <- k () @@ -595,14 +591,14 @@ consumingMessages mp = Codensity $ \k -> do -- each new user and wait for its join event -- when (mls.protocol == MLSProtocolMLS) $ - traverse_ - (awaitMatch isMemberJoinNotif) - ( flip Map.restrictKeys newUsers - . Map.mapKeys ((.user) . fst) - . Map.fromList - . toList - $ zip clients wss - ) + -- traverse_ + -- (awaitMatch (\n -> (||) <$> isMemberJoinNotif n <*> isWelcomeNotif n)) + -- ( flip Map.restrictKeys newUsers + -- . Map.mapKeys ((.user) . fst) + -- . Map.fromList + -- . toList + -- $ zip clients wss + -- ) -- at this point we know that every new user has been added to the -- conversation @@ -617,9 +613,10 @@ consumeMessageWithPredicate p cs cid mmp ws = do event <- notif %. "payload.0" for_ mmp $ \mp -> do - shouldMatch (eventSubConv event) mp.convId - shouldMatch (event %. "from") mp.sender.user - shouldMatch (event %. "data") (B8.unpack (Base64.encode mp.message)) + event %. "qualified_conversation" `shouldMatch` objQidObject mp.convId + lookupField event "subconv" `shouldMatch` mp.convId.subconvId + event %. "from" `shouldMatch` mp.sender.user + event %. "data" `shouldMatch` (B8.unpack (Base64.encode mp.message)) msgData <- event %. "data" & asByteString _ <- mlsCliConsume cs cid msgData @@ -711,9 +708,11 @@ consumeWelcome cid mp ws = do notif <- awaitMatch isWelcomeNotif ws event <- notif %. "payload.0" - shouldMatch (eventSubConv event) mp.convId - shouldMatch (event %. "from") mp.sender.user - shouldMatch (event %. "data") (fmap (B8.unpack . Base64.encode) mp.welcome) + -- eventSubConv event `shouldMatch` mp.convId + event %. "qualified_conversation" `shouldMatch` objQidObject mp.convId + lookupField event "subconv" `shouldMatch` mp.convId.subconvId + event %. "from" `shouldMatch` mp.sender.user + event %. "data" `shouldMatch` (fmap (B8.unpack . Base64.encode) mp.welcome) welcome <- event %. "data" & asByteString gs <- getClientGroupState cid @@ -857,4 +856,4 @@ getSubConvId :: (MakesValue user, HasCallStack) => user -> ConvId -> String -> A getSubConvId user convId subConvName = getSubConversation user convId subConvName >>= getJSON 200 - >>= objSubConvObject + >>= objConvId diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 2469d3644b7..ad19f9d972b 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -145,7 +145,7 @@ simpleMixedConversationSetup secondDomain = do bindResponse (putConversationProtocol bob conv "mixed") $ \resp -> do resp.status `shouldMatchInt` 200 - conv' <- getConversation alice conv >>= getJSON 200 >>= objSubConvObject + conv' <- getConversation alice conv >>= getJSON 200 >>= objConvId pure (alice, bob, conv') diff --git a/integration/test/Test/AccessUpdate.hs b/integration/test/Test/AccessUpdate.hs index 9df53f02377..36dff78fdf9 100644 --- a/integration/test/Test/AccessUpdate.hs +++ b/integration/test/Test/AccessUpdate.hs @@ -83,7 +83,7 @@ testAccessUpdateGuestRemoved proto = do traverse_ (uploadNewKeyPackage def) clients conv <- postConversation alice1 defMLS {team = Just tid} >>= getJSON 201 - convId <- objSubConvObject conv + convId <- objConvId conv createGroup def alice1 conv void $ createAddCommit alice1 convId [bob, charlie, dee] >>= sendAndConsumeCommitBundle diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index ea2e73116b4..d940a41d66a 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -178,7 +178,7 @@ testMixedProtocolAddUsers secondDomain suite = do resp.status `shouldMatchInt` 200 resp.json %. "epoch" `shouldMatchInt` 0 createGroup suite alice1 resp.json - objSubConvObject resp.json + objConvId resp.json void $ uploadNewKeyPackage suite bob1 @@ -215,7 +215,7 @@ testMixedProtocolUserLeaves secondDomain = do convId <- bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 createGroup def alice1 resp.json - objSubConvObject resp.json + objConvId resp.json void $ uploadNewKeyPackage def bob1 @@ -253,7 +253,7 @@ testMixedProtocolAddPartialClients secondDomain = do convId <- bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 createGroup def alice1 resp.json - objSubConvObject resp.json + objConvId resp.json traverse_ (uploadNewKeyPackage def) [bob1, bob1, bob2, bob2] @@ -293,7 +293,7 @@ testMixedProtocolRemovePartialClients secondDomain = do convId <- bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 createGroup def alice1 resp.json - objSubConvObject resp.json + objConvId resp.json traverse_ (uploadNewKeyPackage def) [bob1, bob2] void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle @@ -322,7 +322,7 @@ testMixedProtocolAppMessagesAreDenied secondDomain = do convId <- bindResponse (getConversation alice qcnv) $ \resp -> do resp.status `shouldMatchInt` 200 createGroup def alice1 resp.json - objSubConvObject resp.json + objConvId resp.json void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle @@ -405,7 +405,7 @@ testAddUserSimple suite ctype = do -- check that bob can now see the conversation convs <- getAllConvs bob - convIds <- traverse objSubConvObject convs + convIds <- traverse objConvId convs void $ assertBool "Users added to an MLS group should find it when listing conversations" @@ -512,7 +512,7 @@ testSelfConversation v = withVersion5 v $ do creator : others <- traverse (createMLSClient def def) (replicate 3 alice) traverse_ (uploadNewKeyPackage def) others (_, conv) <- createSelfGroup def creator - convId <- objSubConvObject conv + convId <- objConvId conv conv %. "epoch" `shouldMatchInt` 0 case v of Version5 -> conv %. "cipher_suite" `shouldMatchInt` 1 @@ -613,7 +613,7 @@ testAdminRemovesUserFromConv suite = do do convs <- getAllConvs bob - convIds <- traverse objSubConvObject convs + convIds <- traverse objConvId convs clients <- bindResponse (getGroupClients alice gid) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "client_ids" & asList @@ -745,7 +745,7 @@ testAddUserBareProposalCommit = do -- check that bob can now see the conversation convs <- getAllConvs bob - convIds <- traverse objSubConvObject convs + convIds <- traverse objConvId convs void $ assertBool "Users added to an MLS group should find it when listing conversations" diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index 1fd6ddb748a..e2d18c5891e 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -117,7 +117,7 @@ testMLSOne2OneOtherMember scenario = do convDomain = one2OneScenarioConvDomain scenario bob <- createMLSOne2OnePartner otherDomain alice convDomain one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv do convId <- one2OneConv %. "conversation.qualified_id" bobOne2OneConv <- getMLSOne2OneConversation bob alice >>= getJSON 200 @@ -156,7 +156,7 @@ testMLSOne2OneRemoveClientLocalV5 = withVersion5 Version5 $ do [alice1, bob1] <- traverse (createMLSClient def def) [alice, bob] void $ uploadNewKeyPackage def bob1 resetGroup def alice1 conv - convId <- objSubConvObject conv + convId <- objConvId conv void $ createAddCommit alice1 convId [bob] >>= sendAndConsumeCommitBundle @@ -201,7 +201,7 @@ testMLSOne2OneBlockedAfterConnected scenario = do convDomain = one2OneScenarioConvDomain scenario bob <- createMLSOne2OnePartner otherDomain alice convDomain one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv convId <- one2OneConv %. "conversation.qualified_id" do bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200 @@ -241,7 +241,7 @@ testMLSOne2OneUnblocked scenario = do convDomain = one2OneScenarioConvDomain scenario bob <- createMLSOne2OnePartner otherDomain alice convDomain one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv do convId <- one2OneConv %. "conversation.qualified_id" bobConv <- getMLSOne2OneConversation bob alice >>= getJSON 200 @@ -330,7 +330,7 @@ testMLSOne2One suite scenario = do void $ uploadNewKeyPackage suite bob1 one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv resetOne2OneGroup suite alice1 one2OneConv commit <- createAddCommit alice1 one2OneConvId [bob] @@ -369,7 +369,7 @@ testMLSGhostOne2OneConv = do [alice1, bob1, bob2] <- traverse (createMLSClient def def) [alice, bob, bob] traverse_ (uploadNewKeyPackage def) [bob1, bob2] one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv resetOne2OneGroup def alice1 one2OneConv doneVar <- liftIO $ newEmptyMVar @@ -424,7 +424,7 @@ testMLSFederationV1ConvOnOldBackend = do fedError %. "label" `shouldMatch` "federation-version-error" conv <- getMLSOne2OneConversation bob alice >>= getJSON 200 - convId <- objSubConvObject conv + convId <- objConvId conv keys <- getMLSPublicKeys bob >>= getJSON 200 resetOne2OneGroupGeneric def bob1 conv keys @@ -477,7 +477,7 @@ testMLSFederationV1ConvOnNewBackend = do fedError %. "label" `shouldMatch` "federation-remote-error" one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv conv <- one2OneConv %. "conversation" resetOne2OneGroup def alice1 one2OneConv diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index 400439e7336..51965c9c3d2 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -23,7 +23,7 @@ testJoinSubConv = do -- bob adds his first client to the subconversation sub' <- getSubConversation bob convId "conference" >>= getJSON 200 - subConvId <- objSubConvObject sub' + subConvId <- objConvId sub' do tm <- sub' %. "epoch_timestamp" assertBool "Epoch timestamp should not be null" (tm /= Null) @@ -39,7 +39,7 @@ testJoinOne2OneSubConv = do [alice1, bob1, bob2] <- traverse (createMLSClient def def) [alice, bob, bob] traverse_ (uploadNewKeyPackage def) [bob1, bob2] one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv resetOne2OneGroup def alice1 one2OneConv void $ createAddCommit alice1 one2OneConvId [bob] >>= sendAndConsumeCommitBundle @@ -47,7 +47,7 @@ testJoinOne2OneSubConv = do -- bob adds his first client to the subconversation sub' <- getSubConversation bob (one2OneConv %. "conversation") "conference" >>= getJSON 200 - subConvId <- objSubConvObject sub' + subConvId <- objConvId sub' do tm <- sub' %. "epoch_timestamp" assertBool "Epoch timestamp should not be null" (tm /= Null) @@ -67,7 +67,7 @@ testLeaveOne2OneSubConv scenario leaver = do [alice1, bob1] <- traverse (createMLSClient def def) [alice, bob] void $ uploadNewKeyPackage def bob1 one2OneConv <- getMLSOne2OneConversation alice bob >>= getJSON 200 - one2OneConvId <- objSubConvObject one2OneConv + one2OneConvId <- objConvId one2OneConv resetOne2OneGroup def alice1 one2OneConv void $ createAddCommit alice1 one2OneConvId [bob] >>= sendAndConsumeCommitBundle diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index ec61e68e8ce..8b5a6f95b59 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -436,18 +436,29 @@ objSubConv x = do lift $ asString sub' pure (obj, sub) --- | Turn an object parseable by 'objSubConv' into a canonical flat representation. --- TODO: Rename this function -objSubConvObject :: (HasCallStack, MakesValue a) => a -> App ConvId -objSubConvObject x = do - (convId, mSubConvId) <- objSubConv x - (domain, id_) <- objQid convId - pure $ - ConvId - { domain = domain, - id_ = id_, - subconvId = mSubConvId - } +-- -- | Turn an object parseable by 'objSubConv' into a canonical flat representation. +-- -- TODO :Rename this +-- objConvId :: (HasCallStack, MakesValue a) => a -> App ConvId +-- objConvId x = do +-- (convId, mSubConvId) <- objSubConv x +-- (domain, id_) <- objQid convId +-- pure $ +-- ConvId +-- { domain = domain, +-- id_ = id_, +-- subconvId = mSubConvId +-- } + +objConvId :: (HasCallStack, MakesValue conv) => conv -> App ConvId +objConvId conv = do + v <- make conv + -- Domain and ConvId either come from parent_qualified_id or qualified_id + mParent <- lookupField v "parent_qualified_id" + (domain, id_) <- objQid $ fromMaybe v mParent + + groupId <- traverse asString =<< asOptional (lookupField v "group_id") + subconvId <- traverse asString =<< asOptional (lookupField v "subconv_id") + pure ConvId {..} instance MakesValue ClientIdentity where make cid = diff --git a/integration/test/Testlib/Run.hs b/integration/test/Testlib/Run.hs index 7fb7a4ca456..fa5255972fc 100644 --- a/integration/test/Testlib/Run.hs +++ b/integration/test/Testlib/Run.hs @@ -114,7 +114,7 @@ runTests tests mXMLOutput cfg = do runCodensity (mkGlobalEnv cfg) $ \genv -> withAsync displayOutput $ \displayThread -> do -- Currently 4 seems to be stable, more seems to create more timeouts. - report <- fmap mconcat $ pooledForConcurrentlyN 4 tests $ \(qname, _, _, action) -> do + report <- fmap mconcat $ pooledForConcurrentlyN 16 tests $ \(qname, _, _, action) -> do (mErr, tm) <- withTime (runTest genv action) case mErr of Left err -> do diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index b31da519804..bebb8674c95 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -280,6 +280,7 @@ data MLSProtocol = MLSProtocolMLS | MLSProtocolMixed data ConvId = ConvId { domain :: String, id_ :: String, + groupId :: Maybe String, subconvId :: Maybe String } deriving (Show, Eq, Ord) @@ -292,7 +293,14 @@ instance ToJSON ConvId where [ fromString "id" .= c.id_, fromString "domain" .= c.domain ], - fromString "subconv_id" .= c.subconvId + fromString "subconv_id" .= c.subconvId, + fromString "qualified_id" + .= object + [ fromString "id" .= c.id_, + fromString "domain" .= c.domain + ], + fromString "id" .= c.id_, + fromString "group_id" .= c.groupId ] data MLSState = MLSState