Desperately trying to make the tests work

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,26 +579,26 @@ 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 ()
 
     -- if the conversation is actually MLS (and not mixed), pick one client for
     -- 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

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')
 

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

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"

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
 

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,15 +39,15 @@ 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
   createOne2OneSubConv def one2OneConvId bob1 "conference" (one2OneConv %. "public_keys")
 
   -- 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
 

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 =