integration: Fix testAddingUserNonFullyConnectedFederation and testNotificationsForOfflineBackends

integration/test/API/BrigInternal.hs

@@ -110,6 +110,14 @@ deleteFedConn' owndom dom = do
   req <- rawBaseRequest owndom Brig Unversioned ("/i/federation/remotes/" <> dom)
   submit "DELETE" req
 
+deleteAllFedConns :: (HasCallStack, MakesValue dom) => dom -> App ()
+deleteAllFedConns dom = do
+  readFedConns dom >>= \resp ->
+    resp.json %. "remotes"
+      & asList
+      >>= traverse (\v -> v %. "domain" & asString)
+      >>= mapM_ (deleteFedConn dom)
+
 registerOAuthClient :: (HasCallStack, MakesValue user, MakesValue name, MakesValue url) => user -> name -> url -> App Response
 registerOAuthClient user name url = do
   req <- baseRequest user Brig Unversioned "i/oauth/clients"

integration/test/API/Galley.hs

@@ -171,22 +171,30 @@ postProteusMessage user conv msgs = do
   submit "POST" (addProtobuf bytes req)
 
 mkProteusRecipient :: (HasCallStack, MakesValue user, MakesValue client) => user -> client -> String -> App Proto.QualifiedUserEntry
-mkProteusRecipient user client msg = do
-  userDomain <- objDomain user
-  userId <- LBS.toStrict . UUID.toByteString . fromJust . UUID.fromString <$> objId user
-  clientId <- (^?! hex) <$> objId client
+mkProteusRecipient user client = mkProteusRecipients user [(user, [client])]
+
+mkProteusRecipients :: (HasCallStack, MakesValue domain, MakesValue user, MakesValue client) => domain -> [(user, [client])] -> String -> App Proto.QualifiedUserEntry
+mkProteusRecipients dom userClients msg = do
+  userDomain <- asString =<< objDomain dom
+  userEntries <- mapM mkUserEntry userClients
   pure $
     Proto.defMessage
       & #domain .~ fromString userDomain
-      & #entries
-        .~ [ Proto.defMessage
-               & #user . #uuid .~ userId
-               & #clients
-                 .~ [ Proto.defMessage
-                        & #client . #client .~ clientId
-                        & #text .~ fromString msg
-                    ]
-           ]
+      & #entries .~ userEntries
+  where
+    mkUserEntry (user, clients) = do
+      userId <- LBS.toStrict . UUID.toByteString . fromJust . UUID.fromString <$> objId user
+      clientEntries <- mapM mkClientEntry clients
+      pure $
+        Proto.defMessage
+          & #user . #uuid .~ userId
+          & #clients .~ clientEntries
+    mkClientEntry client = do
+      clientId <- (^?! hex) <$> objId client
+      pure $
+        Proto.defMessage
+          & #client . #client .~ clientId
+          & #text .~ fromString msg
 
 getGroupInfo ::
   (HasCallStack, MakesValue user, MakesValue conv) =>

integration/test/Test/Conversation.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -Wno-ambiguous-fields #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 module Test.Conversation where
 
@@ -410,19 +411,35 @@ testAddUnreachable = do
 testAddingUserNonFullyConnectedFederation :: HasCallStack => App ()
 testAddingUserNonFullyConnectedFederation = do
   let overrides =
-        def {dbBrig = setField "optSettings.setFederationStrategy" "allowAll"}
-          <> fullSearchWithAll
-  startDynamicBackends [overrides] $ \domains -> do
-    own <- make OwnDomain & asString
-    other <- make OtherDomain & asString
-    [alice, alex, bob, charlie] <-
-      createAndConnectUsers $ [own, own, other] <> domains
-
-    let newConv = defProteus {qualifiedUsers = [alex]}
+        def
+          { dbBrig =
+              setField "optSettings.setFederationStrategy" "allowDynamic"
+                >=> removeField "optSettings.setFederationDomainConfigs"
+          }
+  startDynamicBackends [overrides] $ \[dynBackend] -> do
+    own <- asString OwnDomain
+    other <- asString OtherDomain
+
+    -- Ensure that dynamic backend only federates with own domain, but not other
+    -- domain.
+    --
+    -- FUTUREWORK: deleteAllFedConns at the time of acquiring a backend, so
+    -- tests don't affect each other.
+    deleteAllFedConns dynBackend
+    void $ createFedConn dynBackend (FedConn own "full_search")
+
+    alice <- randomUser own def
+    bob <- randomUser other def
+    charlie <- randomUser dynBackend def
+    -- We use retryT here so the dynamic federated connection changes can take
+    -- some time to be propagated. Remove after fixing https://wearezeta.atlassian.net/browse/WPB-3797
+    mapM_ (retryT . connectUsers alice) [bob, charlie]
+
+    let newConv = defProteus {qualifiedUsers = []}
     conv <- postConversation alice newConv >>= getJSON 201
 
     bobId <- bob %. "qualified_id"
     charlieId <- charlie %. "qualified_id"
-    bindResponse (addMembers alex conv [bobId, charlieId]) $ \resp -> do
+    bindResponse (addMembers alice conv [bobId, charlieId]) $ \resp -> do
       resp.status `shouldMatchInt` 409
-      resp.json %. "non_federating_backends" `shouldMatchSet` (other : domains)
+      resp.json %. "non_federating_backends" `shouldMatchSet` [other, dynBackend]

integration/test/Test/Federation.hs

@@ -22,9 +22,10 @@ testNotificationsForOfflineBackends :: HasCallStack => App ()
 testNotificationsForOfflineBackends = do
   resourcePool <- asks (.resourcePool)
   -- `delUser` will eventually get deleted.
-  [delUser, otherUser] <- createAndConnectUsers [OwnDomain, OtherDomain]
+  [delUser, otherUser, otherUser2] <- createAndConnectUsers [OwnDomain, OtherDomain, OtherDomain]
   delClient <- objId $ bindResponse (API.addClient delUser def) $ getJSON 201
   otherClient <- objId $ bindResponse (API.addClient otherUser def) $ getJSON 201
+  otherClient2 <- objId $ bindResponse (API.addClient otherUser2 def) $ getJSON 201
 
   -- We call it 'downBackend' because it is down for the most of this test
   -- except for setup and assertions. Perhaps there is a better name.
@@ -36,18 +37,18 @@ testNotificationsForOfflineBackends = do
       connectUsers delUser downUser1
       connectUsers delUser downUser2
       connectUsers otherUser downUser1
-      upBackendConv <- bindResponse (postConversation delUser (defProteus {qualifiedUsers = [otherUser, downUser1]})) $ getJSON 201
+      upBackendConv <- bindResponse (postConversation delUser (defProteus {qualifiedUsers = [otherUser, otherUser2, downUser1]})) $ getJSON 201
       downBackendConv <- bindResponse (postConversation downUser1 (defProteus {qualifiedUsers = [otherUser, delUser]})) $ getJSON 201
       pure (downUser1, downClient1, downUser2, upBackendConv, downBackendConv)
 
     -- Even when a participating backend is down, messages to conversations
     -- owned by other backends should go.
-    successfulMsgForOtherUser <- mkProteusRecipient otherUser otherClient "success message for other user"
+    successfulMsgForOtherUsers <- mkProteusRecipients otherUser [(otherUser, [otherClient]), (otherUser2, [otherClient2])] "success message for other user"
     successfulMsgForDownUser <- mkProteusRecipient downUser1 downClient1 "success message for down user"
     let successfulMsg =
           Proto.defMessage @Proto.QualifiedNewOtrMessage
             & #sender . Proto.client .~ (delClient ^?! hex)
-            & #recipients .~ [successfulMsgForOtherUser, successfulMsgForDownUser]
+            & #recipients .~ [successfulMsgForOtherUsers, successfulMsgForDownUser]
             & #reportAll .~ Proto.defMessage
     bindResponse (postProteusMessage delUser upBackendConv successfulMsg) assertSuccess
 
@@ -68,12 +69,13 @@ testNotificationsForOfflineBackends = do
     bindResponse (postConversation delUser (defProteus {qualifiedUsers = [otherUser, downUser1]})) $ \resp ->
       resp.status `shouldMatchInt` 533
 
-    -- Adding users to an up backend conversation should work even when one of
-    -- the participating backends is down
-    otherUser2 <- randomUser OtherDomain def
-    connectUsers delUser otherUser2
-    bindResponse (addMembers delUser upBackendConv [otherUser2]) $ \resp ->
-      resp.status `shouldMatchInt` 200
+    -- Adding users to an up backend conversation should not work when one of
+    -- the participating backends is down. This is due to not being able to
+    -- check non-fully connected graph between all participating backends
+    otherUser3 <- randomUser OtherDomain def
+    connectUsers delUser otherUser3
+    bindResponse (addMembers delUser upBackendConv [otherUser3]) $ \resp ->
+      resp.status `shouldMatchInt` 533
 
     -- Adding users from down backend to a conversation should also fail
     bindResponse (addMembers delUser upBackendConv [downUser2]) $ \resp ->
@@ -86,14 +88,17 @@ testNotificationsForOfflineBackends = do
 
     -- User deletions should eventually make it to the other backend.
     deleteUser delUser
+
+    let isOtherUser2LeaveUpConvNotif = allPreds [isConvLeaveNotif, isNotifConv upBackendConv, isNotifForUser otherUser2]
+        isDelUserLeaveUpConvNotif = allPreds [isConvLeaveNotif, isNotifConv upBackendConv, isNotifForUser delUser]
+
     do
       newMsgNotif <- awaitNotification otherUser otherClient noValue 1 isNewMessageNotif
       newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
       newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` "success message for other user"
 
-      memberJoinNotif <- awaitNotification otherUser otherClient (Just newMsgNotif) 1 isMemberJoinNotif
-      memberJoinNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
-      asListOf objQidObject (memberJoinNotif %. "payload.0.data.users") `shouldMatch` mapM objQidObject [otherUser2]
+      void $ awaitNotification otherUser otherClient (Just newMsgNotif) 1 isOtherUser2LeaveUpConvNotif
+      void $ awaitNotification otherUser otherClient (Just newMsgNotif) 1 isDelUserLeaveUpConvNotif
 
       delUserDeletedNotif <- nPayload $ awaitNotification otherUser otherClient (Just newMsgNotif) 1 isDeleteUserNotif
       objQid delUserDeletedNotif `shouldMatch` objQid delUser
@@ -103,23 +108,17 @@ testNotificationsForOfflineBackends = do
       newMsgNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
       newMsgNotif %. "payload.0.data.text" `shouldMatchBase64` "success message for down user"
 
-      -- FUTUREWORK: Uncomment after fixing this bug: https://wearezeta.atlassian.net/browse/WPB-3664
-      -- memberJoinNotif <- awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isMemberJoinNotif
-      -- memberJoinNotif %. "payload.0.qualified_conversation" `shouldMatch` objQidObject upBackendConv
-      -- asListOf objQidObject (memberJoinNotif %. "payload.0.data.users") `shouldMatch` mapM objQidObject [downUser2]
-
       let isDelUserLeaveDownConvNotif =
             allPreds
               [ isConvLeaveNotif,
                 isNotifConv downBackendConv,
                 isNotifForUser delUser
               ]
       void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isDelUserLeaveDownConvNotif
-      void $ awaitNotification otherUser otherClient noValue 1 isDelUserLeaveDownConvNotif
 
       -- FUTUREWORK: Uncomment after fixing this bug: https://wearezeta.atlassian.net/browse/WPB-3664
-      -- void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 (allPreds [isConvLeaveNotif, isNotifConv upBackendConv, isNotifForUser otherUser])
-      -- void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 (allPreds [isConvLeaveNotif, isNotifConv upBackendConv, isNotifForUser delUser])
+      -- void $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isOtherUser2LeaveUpConvNotif
+      -- void $ awaitNotification otherUser otherClient (Just newMsgNotif) 1 isDelUserLeaveDownConvNotif
 
       delUserDeletedNotif <- nPayload $ awaitNotification downUser1 downClient1 (Just newMsgNotif) 1 isDeleteUserNotif
       objQid delUserDeletedNotif `shouldMatch` objQid delUser

integration/test/Testlib/HTTP.hs

@@ -100,7 +100,7 @@ getJSON status resp = withResponse resp $ \r -> do
   r.status `shouldMatch` status
   r.json
 
-assertSuccess :: Response -> App ()
+assertSuccess :: HasCallStack => Response -> App ()
 assertSuccess resp = withResponse resp $ \r -> r.status `shouldMatchRange` (200, 299)
 
 onFailureAddResponse :: HasCallStack => Response -> App a -> App a