From dce1e8fd1e9beb030a5b39b2dce014759a8ff37f Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Wed, 10 Apr 2024 11:36:34 +0200 Subject: [PATCH] [WPB-5687] more legalhold tests (#3966) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - [feat] port more legalhold tests to /integration - [feat] introduce combinators for lazy Notifications in App --------- Co-authored-by: Marko Dimjašević Co-authored-by: Igor Ranieri Co-authored-by: Akshay Mankar --- changelog.d/5-internal/WPB-7021 | 1 + charts/integration/templates/configmap.yaml | 1 + charts/integration/templates/service.yaml | 11 + integration/test/Notifications.hs | 19 +- integration/test/SetupHelpers.hs | 4 +- integration/test/Test/LegalHold.hs | 1298 +++++++++-------- integration/test/Testlib/App.hs | 28 + integration/test/Testlib/Env.hs | 2 + .../test/Testlib/MockIntegrationService.hs | 18 +- integration/test/Testlib/Types.hs | 16 +- .../src/Network/Wai/Utilities/MockServer.hs | 6 +- .../test/integration/API/Teams/LegalHold.hs | 255 +--- .../API/Teams/LegalHold/DisabledByDefault.hs | 1 - .../integration/API/Teams/LegalHold/Util.hs | 57 - services/integration.yaml | 5 +- 15 files changed, 811 insertions(+), 911 deletions(-) create mode 100644 changelog.d/5-internal/WPB-7021 diff --git a/changelog.d/5-internal/WPB-7021 b/changelog.d/5-internal/WPB-7021 new file mode 100644 index 00000000000..bcdb36d2cc6 --- /dev/null +++ b/changelog.d/5-internal/WPB-7021 @@ -0,0 +1 @@ +port more of the legalhold test-suite from galley-integration to /integration and get rid of the need for startDynamicBackends diff --git a/charts/integration/templates/configmap.yaml b/charts/integration/templates/configmap.yaml index f211ab25105..2c2178dc14f 100644 --- a/charts/integration/templates/configmap.yaml +++ b/charts/integration/templates/configmap.yaml @@ -164,3 +164,4 @@ data: stern: host: stern.wire-federation-v0.svc.cluster.local port: 8080 + integrationTestHostName: integration-headless.{{ .Release.Namespace }}.svc.cluster.local diff --git a/charts/integration/templates/service.yaml b/charts/integration/templates/service.yaml index d445160ad4e..350b33f11f7 100644 --- a/charts/integration/templates/service.yaml +++ b/charts/integration/templates/service.yaml @@ -1,4 +1,15 @@ {{- $newLabels := eq (include "integrationTestHelperNewLabels" .) "true" -}} +--- +apiVersion: v1 +kind: Service +metadata: + name: integration-headless +spec: + selector: + app: integration-integration + type: ClusterIP + clusterIP: None + --- apiVersion: v1 kind: Service diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 4cd03abc95c..9186f325f07 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -115,6 +115,11 @@ isMemberJoinNotif n = fieldEquals n "payload.0.type" "conversation.member-join" isConvLeaveNotif :: MakesValue a => a -> App Bool isConvLeaveNotif n = fieldEquals n "payload.0.type" "conversation.member-leave" +isConvLeaveNotifWithLeaver :: (MakesValue user, MakesValue a) => user -> a -> App Bool +isConvLeaveNotifWithLeaver user n = + fieldEquals n "payload.0.type" "conversation.member-leave" + &&~ (n %. "payload.0.data.user_ids.0") `isEqual` (user %. "id") + isNotifConv :: (MakesValue conv, MakesValue a, HasCallStack) => conv -> a -> App Bool isNotifConv conv n = fieldEquals n "payload.0.qualified_conversation" (objQidObject conv) @@ -145,6 +150,12 @@ isConvAccessUpdateNotif n = isConvCreateNotif :: MakesValue a => a -> App Bool isConvCreateNotif n = fieldEquals n "payload.0.type" "conversation.create" +-- | like 'isConvCreateNotif' but excludes self conversations +isConvCreateNotifNotSelf :: MakesValue a => a -> App Bool +isConvCreateNotifNotSelf n = + fieldEquals n "payload.0.type" "conversation.create" + &&~ do not <$> fieldEquals n "payload.0.data.access" ["private"] + isConvDeleteNotif :: MakesValue a => a -> App Bool isConvDeleteNotif n = fieldEquals n "payload.0.type" "conversation.delete" @@ -177,9 +188,11 @@ isUserConnectionNotif = notifTypeIsEqual "user.connection" isConnectionNotif :: MakesValue a => String -> a -> App Bool isConnectionNotif status n = - (&&) - <$> nPayload n %. "type" `isEqual` "user.connection" - <*> nPayload n %. "connection.status" `isEqual` status + -- NB: + -- (&&) <$> (print "hello" *> pure False) <*> fail "bla" === _|_ + -- runMaybeT $ (lift (print "hello") *> MaybeT (pure Nothing)) *> lift (fail "bla") === pure Nothing + nPayload n %. "type" `isEqual` "user.connection" + &&~ nPayload n %. "connection.status" `isEqual` status assertLeaveNotification :: ( HasCallStack, diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 0181d9325c8..1d6803e0beb 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -289,8 +289,8 @@ setUpLHDevice :: tid -> owner -> uid -> - -- | the port the LH service is running on - Int -> + -- | the host and port the LH service is running on + (String, Int) -> App () setUpLHDevice tid alice bob lhPort = do legalholdWhitelistTeam tid alice diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index af2968206f8..175721bf399 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Test.LegalHold where import API.Brig @@ -48,40 +47,39 @@ import UnliftIO (Chan, readChan, timeout) testLHPreventAddingNonConsentingUsers :: App () testLHPreventAddingNonConsentingUsers = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - (owner, tid, [alice, alex]) <- createTeam dom 3 - - legalholdWhitelistTeam tid owner >>= assertSuccess - legalholdIsTeamInWhitelist tid owner >>= assertSuccess - postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= assertStatus 201 - - george <- randomUser dom def - georgeQId <- george %. "qualified_id" - connectUsers =<< forM [alice, george] make - connectUsers =<< forM [alex, george] make - conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201 - - -- the guest should be added to the conversation - bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "type" `shouldMatch` "conversation.member-join" + withMockServer lhMockApp $ \lhDomAndPort _chan -> do + (owner, tid, [alice, alex]) <- createTeam OwnDomain 3 + + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 - -- assert that the guest is in the conversation - checkConvHasOtherMembers conv alice [alex, george] + george <- randomUser OwnDomain def + georgeQId <- george %. "qualified_id" + connectUsers =<< forM [alice, george] make + connectUsers =<< forM [alex, george] make + conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201 + + -- the guest should be added to the conversation + bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "type" `shouldMatch` "conversation.member-join" - -- now request legalhold for alex (but not alice) - requestLegalHoldDevice tid owner alex >>= assertSuccess + -- assert that the guest is in the conversation + checkConvHasOtherMembers conv alice [alex, george] - -- the guest should be removed from the conversation - checkConvHasOtherMembers conv alice [alex] + -- now request legalhold for alex (but not alice) + requestLegalHoldDevice tid owner alex >>= assertSuccess - -- it should not be possible neither for alex nor for alice to add the guest back - addMembers alex conv def {users = [georgeQId]} - >>= assertLabel 403 "not-connected" + -- the guest should be removed from the conversation + checkConvHasOtherMembers conv alice [alex] - addMembers alice conv def {users = [georgeQId]} - >>= assertLabel 403 "missing-legalhold-consent" + -- it should not be possible neither for alex nor for alice to add the guest back + addMembers alex conv def {users = [georgeQId]} + >>= assertLabel 403 "not-connected" + + addMembers alice conv def {users = [georgeQId]} + >>= assertLabel 403 "missing-legalhold-consent" where checkConvHasOtherMembers :: HasCallStack => Value -> Value -> [Value] -> App () checkConvHasOtherMembers conv u us = @@ -100,100 +98,99 @@ testLHMessageExchange :: TaggedBool "consentFrom2" -> App () testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedBool consentFrom1) (TaggedBool consentFrom2) = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - (owner, tid, [mem1, mem2]) <- createTeam dom 3 - - let clientSettings :: Bool -> AddClient - clientSettings allnew = - if allnew - then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) - else def {acapabilities = Nothing} - client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 - _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 - - legalholdWhitelistTeam tid owner >>= assertSuccess - legalholdIsTeamInWhitelist tid owner >>= assertSuccess - postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= assertStatus 201 - - conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 - - requestLegalHoldDevice tid owner mem1 >>= assertSuccess - requestLegalHoldDevice tid owner mem2 >>= assertSuccess - when consentFrom1 $ do - approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess - when consentFrom2 $ do - approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess - - let getCls :: Value -> App [String] - getCls mem = do - res <- getClientsQualified mem dom mem - val <- getJSON 200 res - cls <- asList val - objId `mapM` cls - cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. - cs2 :: [String] <- getCls mem2 - - length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 - length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 - - do - successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" - let successfulMsg = - Proto.defMessage @Proto.QualifiedNewOtrMessage - & #sender . Proto.client .~ (client1 ^?! hex) - & #recipients .~ [successfulMsgForOtherUsers] - & #reportAll .~ Proto.defMessage - bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do - let check :: HasCallStack => Int -> Maybe String -> App () - check status Nothing = do - resp.status `shouldMatchInt` status - check status (Just label) = do - resp.status `shouldMatchInt` status - resp.json %. "label" `shouldMatch` label - - let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): - _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - (_, _, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, _, _) -> - if consentFrom1 /= consentFrom2 - then -- no old clients, but users disagree on LH - check 403 (Just "missing-legalhold-consent") - else -- everybody likes LH - check 201 Nothing - _ -> - -- everything else - check 403 (Just "missing-legalhold-consent-old-clients") - - theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - -- NB: "consent" always implies "has an active LH device" - (False, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (False, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, False, True) -> - -- all clients new, no consent from sender, recipient has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, False) -> - -- all clients new, no consent from recipient, sender has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, True) -> - -- everybody happy with LH - check 201 Nothing - _ -> pure () - - -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! - theOtherWay + withMockServer lhMockApp $ \lhDomAndPort _chan -> do + (owner, tid, [mem1, mem2]) <- createTeam OwnDomain 3 + + let clientSettings :: Bool -> AddClient + clientSettings allnew = + if allnew + then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) + else def {acapabilities = Nothing} + client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 + _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 + + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + postLegalHoldSettings tid owner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + + conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 + + requestLegalHoldDevice tid owner mem1 >>= assertSuccess + requestLegalHoldDevice tid owner mem2 >>= assertSuccess + when consentFrom1 $ do + approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess + when consentFrom2 $ do + approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess + + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem OwnDomain mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. + cs2 :: [String] <- getCls mem2 + + length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 + length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 + + do + successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" + let successfulMsg = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (client1 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do + let check :: HasCallStack => Int -> Maybe String -> App () + check status Nothing = do + resp.status `shouldMatchInt` status + check status (Just label) = do + resp.status `shouldMatchInt` status + resp.json %. "label" `shouldMatch` label + + let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): + _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + (_, _, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, _, _) -> + if consentFrom1 /= consentFrom2 + then -- no old clients, but users disagree on LH + check 403 (Just "missing-legalhold-consent") + else -- everybody likes LH + check 201 Nothing + _ -> + -- everything else + check 403 (Just "missing-legalhold-consent-old-clients") + + theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + -- NB: "consent" always implies "has an active LH device" + (False, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (False, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, False, True) -> + -- all clients new, no consent from sender, recipient has LH device + check 403 (Just "missing-legalhold-consent") + (True, True, True, False) -> + -- all clients new, no consent from recipient, sender has LH device + check 403 (Just "missing-legalhold-consent") + (True, True, True, True) -> + -- everybody happy with LH + check 201 Nothing + _ -> pure () + + -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! + theOtherWay data TestClaimKeys = TCKConsentMissing -- (team not whitelisted, that is) @@ -203,59 +200,58 @@ data TestClaimKeys -- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients. testLHClaimKeys :: TestClaimKeys -> App () testLHClaimKeys testmode = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - (lowner, ltid, [lmem]) <- createTeam dom 2 - (powner, ptid, [pmem]) <- createTeam dom 2 - - legalholdWhitelistTeam ltid lowner >>= assertSuccess - legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess - postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhPort) >>= assertStatus 201 - - requestLegalHoldDevice ltid lowner lmem >>= assertSuccess - approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess - - let addc caps = addClient pmem (settings caps) >>= assertSuccess - settings caps = - def - { prekeys = Just $ take 10 somePrekeysRendered, - lastPrekey = Just $ head someLastPrekeysRendered, - acapabilities = caps - } - in case testmode of - TCKConsentMissing -> - addc $ Just ["legalhold-implicit-consent"] - TCKConsentAndNewClients -> do - addc $ Just ["legalhold-implicit-consent"] - legalholdWhitelistTeam ptid powner >>= assertSuccess - legalholdIsTeamInWhitelist ptid powner >>= assertSuccess - - llhdev :: String <- do - let getCls :: Value -> App [String] - getCls mem = do - res <- getClientsQualified mem dom mem - val <- getJSON 200 res - cls <- asList val - objId `mapM` cls - getCls lmem <&> \case - [d] -> d - bad -> error $ show bad - - let assertResp :: HasCallStack => Response -> App () - assertResp resp = case testmode of - TCKConsentMissing -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "missing-legalhold-consent" - TCKConsentAndNewClients -> do - resp.status `shouldMatchInt` 200 - - bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp - bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp - - slmemdom <- asString $ lmem %. "qualified_id.domain" - slmemid <- asString $ lmem %. "qualified_id.id" - let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] - bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp + withMockServer lhMockApp $ \lhDomAndPort _chan -> do + (lowner, ltid, [lmem]) <- createTeam OwnDomain 2 + (powner, ptid, [pmem]) <- createTeam OwnDomain 2 + + legalholdWhitelistTeam ltid lowner >>= assertSuccess + legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess + postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + + requestLegalHoldDevice ltid lowner lmem >>= assertSuccess + approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess + + let addc caps = addClient pmem (settings caps) >>= assertSuccess + settings caps = + def + { prekeys = Just $ take 10 somePrekeysRendered, + lastPrekey = Just $ head someLastPrekeysRendered, + acapabilities = caps + } + in case testmode of + TCKConsentMissing -> + addc $ Just ["legalhold-implicit-consent"] + TCKConsentAndNewClients -> do + addc $ Just ["legalhold-implicit-consent"] + legalholdWhitelistTeam ptid powner >>= assertSuccess + legalholdIsTeamInWhitelist ptid powner >>= assertSuccess + + llhdev :: String <- do + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem OwnDomain mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + getCls lmem <&> \case + [d] -> d + bad -> error $ show bad + + let assertResp :: HasCallStack => Response -> App () + assertResp resp = case testmode of + TCKConsentMissing -> do + resp.status `shouldMatchInt` 403 + resp.json %. "label" `shouldMatch` "missing-legalhold-consent" + TCKConsentAndNewClients -> do + resp.status `shouldMatchInt` 200 + + bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp + bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp + + slmemdom <- asString $ lmem %. "qualified_id.domain" + slmemid <- asString $ lmem %. "qualified_id.id" + let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] + bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp testLHAddClientManually :: App () testLHAddClientManually = do @@ -282,50 +278,49 @@ testLHDeleteClientManually = do resp.json %. "message" `shouldMatch` "LegalHold clients cannot be deleted. LegalHold must be disabled on this user by an admin" testLHRequestDevice :: App () -testLHRequestDevice = - startDynamicBackends [mempty] $ \[dom] -> do - (alice, tid, [bob]) <- createTeam dom 2 - let reqNotEnabled requester requestee = - requestLegalHoldDevice tid requester requestee - >>= assertLabel 403 "legalhold-not-enabled" - - reqNotEnabled alice bob - - lpk <- getLastPrekey - pks <- replicateM 3 getPrekey - - withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhPort _chan -> do - let statusShouldBe :: String -> App () - statusShouldBe status = - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` status - - -- the user has not agreed to be under legalhold - for_ [alice, bob] \requester -> do - reqNotEnabled requester bob - statusShouldBe "no_consent" - - legalholdWhitelistTeam tid alice >>= assertSuccess - postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) >>= assertSuccess - - statusShouldBe "disabled" - - requestLegalHoldDevice tid alice bob >>= assertStatus 201 - statusShouldBe "pending" - - -- requesting twice should be idempotent wrt the approval - -- mind that requesting twice means two "user.legalhold-request" notifications - -- for the clients of the user under legalhold (bob) - requestLegalHoldDevice tid alice bob >>= assertStatus 204 - statusShouldBe "pending" - - [bobc1, bobc2] <- replicateM 2 do - objId $ addClient bob def `bindResponse` getJSON 201 - for_ [bobc1, bobc2] \client -> - awaitNotification bob client noValue isUserLegalholdRequestNotif >>= \notif -> do - notif %. "payload.0.last_prekey" `shouldMatch` lpk - notif %. "payload.0.id" `shouldMatch` objId bob +testLHRequestDevice = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 + let reqNotEnabled requester requestee = + requestLegalHoldDevice tid requester requestee + >>= assertLabel 403 "legalhold-not-enabled" + + reqNotEnabled alice bob + + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do + let statusShouldBe :: String -> App () + statusShouldBe status = + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` status + + -- the user has not agreed to be under legalhold + for_ [alice, bob] \requester -> do + reqNotEnabled requester bob + statusShouldBe "no_consent" + + legalholdWhitelistTeam tid alice >>= assertSuccess + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertSuccess + + statusShouldBe "disabled" + + requestLegalHoldDevice tid alice bob >>= assertStatus 201 + statusShouldBe "pending" + + -- requesting twice should be idempotent wrt the approval + -- mind that requesting twice means two "user.legalhold-request" notifications + -- for the clients of the user under legalhold (bob) + requestLegalHoldDevice tid alice bob >>= assertStatus 204 + statusShouldBe "pending" + + [bobc1, bobc2] <- replicateM 2 do + objId $ addClient bob def `bindResponse` getJSON 201 + for_ [bobc1, bobc2] \client -> + awaitNotification bob client noValue isUserLegalholdRequestNotif >>= \notif -> do + notif %. "payload.0.last_prekey" `shouldMatch` lpk + notif %. "payload.0.id" `shouldMatch` objId bob -- | pops a channel until it finds an event that returns a 'Just' -- upon running the matcher function @@ -344,136 +339,134 @@ checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do testLHApproveDevice :: App () testLHApproveDevice = do - startDynamicBackends [mempty] \[dom] -> do - -- team users - -- alice (boss) and bob and charlie (member) - (alice, tid, [bob, charlie]) <- createTeam dom 3 + -- team users + -- alice (boss) and bob and charlie (member) + (alice, tid, [bob, charlie]) <- createTeam OwnDomain 3 + + -- ollie the outsider + ollie <- do + o <- randomUser OwnDomain def + connectTwoUsers o alice + pure o + + -- sandy the stranger + sandy <- randomUser OwnDomain def + + legalholdWhitelistTeam tid alice >>= assertStatus 200 + approveLegalHoldDevice tid (bob %. "qualified_id") defPassword + >>= assertLabel 412 "legalhold-not-pending" + + withMockServer lhMockApp \lhDomAndPort chan -> do + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) + >>= assertStatus 201 + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 + + let uidsAndTidMatch val = do + actualTid <- + lookupFieldM val "team_id" + >>= lift . asString + actualUid <- + lookupFieldM val "user_id" + >>= lift . asString + bobUid <- lift $ objId bob - -- ollie the outsider - ollie <- do - o <- randomUser dom def - connectTwoUsers o alice - pure o + -- we pass the check on equality + unless ((actualTid, actualUid) == (tid, bobUid)) do + mzero - -- sandy the stranger - sandy <- randomUser dom def + checkChanVal chan uidsAndTidMatch - legalholdWhitelistTeam tid alice >>= assertStatus 200 - approveLegalHoldDevice tid (bob %. "qualified_id") defPassword - >>= assertLabel 412 "legalhold-not-pending" + -- the team owner cannot approve for bob + approveLegalHoldDevice' tid alice bob defPassword + >>= assertLabel 403 "access-denied" + -- bob needs to provide a password + approveLegalHoldDevice tid bob "wrong-password" + >>= assertLabel 403 "access-denied" + -- now bob finally found his password + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 + + let matchAuthToken val = + lookupFieldM val "refresh_token" + >>= lift . asString + + checkChanVal chan matchAuthToken + >>= renewToken bob + >>= assertStatus 200 + + lhdId <- lhDeviceIdOf bob - withMockServer lhMockApp \lhPort chan -> do + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "client.id" `shouldMatch` lhdId + resp.json %. "status" `shouldMatch` "enabled" + + replicateM 2 do + objId $ addClient bob def `bindResponse` getJSON 201 + >>= traverse_ \client -> + awaitNotification bob client noValue isUserClientAddNotif >>= \notif -> do + notif %. "payload.0.client.type" `shouldMatch` "legalhold" + notif %. "payload.0.client.class" `shouldMatch` "legalhold" + + -- the other team members receive a notification about the + -- legalhold device being approved in their team + for_ [alice, charlie] \user -> do + client <- objId $ addClient user def `bindResponse` getJSON 201 + awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do + notif %. "payload.0.id" `shouldMatch` objId bob + for_ [ollie, sandy] \outsider -> do + outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201 + assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif + +testLHGetDeviceStatus :: App () +testLHGetDeviceStatus = do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam OwnDomain 2 + for_ [alice, bob] \user -> do + legalholdUserStatus tid alice user `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "no_consent" + + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer + do lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks} + \lhDomAndPort _chan -> do legalholdWhitelistTeam tid alice >>= assertStatus 200 - postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "disabled" + lookupField resp.json "last_prekey" + >>= assertNothing + runMaybeT (lookupFieldM resp.json "client" >>= flip lookupFieldM "id") + >>= assertNothing + + -- the status messages for these have already been tested + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + requestLegalHoldDevice tid alice bob >>= assertStatus 201 - let uidsAndTidMatch val = do - actualTid <- - lookupFieldM val "team_id" - >>= lift . asString - actualUid <- - lookupFieldM val "user_id" - >>= lift . asString - bobUid <- lift $ objId bob - - -- we pass the check on equality - unless ((actualTid, actualUid) == (tid, bobUid)) do - mzero - - checkChanVal chan uidsAndTidMatch - - -- the team owner cannot approve for bob - approveLegalHoldDevice' tid alice bob defPassword - >>= assertLabel 403 "access-denied" - -- bob needs to provide a password - approveLegalHoldDevice tid bob "wrong-password" - >>= assertLabel 403 "access-denied" - -- now bob finally found his password approveLegalHoldDevice tid bob defPassword >>= assertStatus 200 - let matchAuthToken val = - lookupFieldM val "refresh_token" - >>= lift . asString - - checkChanVal chan matchAuthToken - >>= renewToken bob - >>= assertStatus 200 - lhdId <- lhDeviceIdOf bob - legalholdUserStatus tid alice bob `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 - resp.json %. "client.id" `shouldMatch` lhdId resp.json %. "status" `shouldMatch` "enabled" + resp.json %. "last_prekey" `shouldMatch` lpk + resp.json %. "client.id" `shouldMatch` lhdId - replicateM 2 do - objId $ addClient bob def `bindResponse` getJSON 201 - >>= traverse_ \client -> - awaitNotification bob client noValue isUserClientAddNotif >>= \notif -> do - notif %. "payload.0.client.type" `shouldMatch` "legalhold" - notif %. "payload.0.client.class" `shouldMatch` "legalhold" - - -- the other team members receive a notification about the - -- legalhold device being approved in their team - for_ [alice, charlie] \user -> do - client <- objId $ addClient user def `bindResponse` getJSON 201 - awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do - notif %. "payload.0.id" `shouldMatch` objId bob - for_ [ollie, sandy] \outsider -> do - outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201 - assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif - -testLHGetDeviceStatus :: App () -testLHGetDeviceStatus = - startDynamicBackends [mempty] \[dom] -> do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, [bob]) <- createTeam dom 2 - for_ [alice, bob] \user -> do - legalholdUserStatus tid alice user `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "no_consent" - - lpk <- getLastPrekey - pks <- replicateM 3 getPrekey - - withMockServer - do lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks} - \lhPort _chan -> do - legalholdWhitelistTeam tid alice - >>= assertStatus 200 - - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "disabled" - lookupField resp.json "last_prekey" - >>= assertNothing - runMaybeT (lookupFieldM resp.json "client" >>= flip lookupFieldM "id") - >>= assertNothing - - -- the status messages for these have already been tested - postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) - >>= assertStatus 201 - - requestLegalHoldDevice tid alice bob - >>= assertStatus 201 - - approveLegalHoldDevice tid bob defPassword - >>= assertStatus 200 - - lhdId <- lhDeviceIdOf bob - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "enabled" - resp.json %. "last_prekey" `shouldMatch` lpk - resp.json %. "client.id" `shouldMatch` lhdId - - requestLegalHoldDevice tid alice bob - >>= assertLabel 409 "legalhold-already-enabled" + requestLegalHoldDevice tid alice bob + >>= assertLabel 409 "legalhold-already-enabled" -- | this sets the timeout to a higher number; we need -- this because the SQS queue on the brig is super slow @@ -485,118 +478,113 @@ setTimeoutTo :: Int -> Env -> Env setTimeoutTo tSecs env = env {timeOutSeconds = tSecs} testLHDisableForUser :: App () -testLHDisableForUser = - startDynamicBackends [mempty] \[dom] -> do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, [bob]) <- createTeam dom 2 +testLHDisableForUser = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 - withMockServer lhMockApp \lhPort chan -> do - setUpLHDevice tid alice bob lhPort + withMockServer lhMockApp \lhDomAndPort chan -> do + setUpLHDevice tid alice bob lhDomAndPort - bobc <- objId $ addClient bob def `bindResponse` getJSON 201 + bobc <- objId $ addClient bob def `bindResponse` getJSON 201 - awaitNotification bob bobc noValue isUserClientAddNotif >>= \notif -> do - notif %. "payload.0.client.type" `shouldMatch` "legalhold" - notif %. "payload.0.client.class" `shouldMatch` "legalhold" + awaitNotification bob bobc noValue isUserClientAddNotif >>= \notif -> do + notif %. "payload.0.client.type" `shouldMatch` "legalhold" + notif %. "payload.0.client.class" `shouldMatch` "legalhold" - -- only an admin can disable legalhold - disableLegalHold tid bob bob defPassword - >>= assertLabel 403 "operation-denied" + -- only an admin can disable legalhold + disableLegalHold tid bob bob defPassword + >>= assertLabel 403 "operation-denied" - disableLegalHold tid alice bob "fix ((\"the password always is \" <>) . show)" - >>= assertLabel 403 "access-denied" + disableLegalHold tid alice bob "fix ((\"the password always is \" <>) . show)" + >>= assertLabel 403 "access-denied" - disableLegalHold tid alice bob defPassword - >>= assertStatus 200 + disableLegalHold tid alice bob defPassword + >>= assertStatus 200 - checkChan chan \(req, _) -> runMaybeT do - unless - do - BS8.unpack req.requestMethod == "POST" - && req.pathInfo == (T.pack <$> ["legalhold", "remove"]) - mzero + checkChan chan \(req, _) -> runMaybeT do + unless + do + BS8.unpack req.requestMethod == "POST" + && req.pathInfo == (T.pack <$> ["legalhold", "remove"]) + mzero - void $ local (setTimeoutTo 90) do - awaitNotification bob bobc noValue isUserClientRemoveNotif - *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif + void $ local (setTimeoutTo 90) do + awaitNotification bob bobc noValue isUserClientRemoveNotif + *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif - bobId <- objId bob - lhClients <- - BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do - resp.json %. bobId - & asList - >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + bobId <- objId bob + lhClients <- + BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do + resp.json %. bobId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) - shouldBeEmpty lhClients + shouldBeEmpty lhClients testLHEnablePerTeam :: App () testLHEnablePerTeam = do - startDynamicBackends [mempty] \[dom] -> do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, [bob]) <- createTeam dom 2 - legalholdIsEnabled tid alice `bindResponse` \resp -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam OwnDomain 2 + legalholdIsEnabled tid alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "lockStatus" `shouldMatch` "unlocked" + resp.json %. "status" `shouldMatch` "disabled" + + withMockServer lhMockApp \lhDomAndPort _chan -> do + setUpLHDevice tid alice bob lhDomAndPort + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 - resp.json %. "lockStatus" `shouldMatch` "unlocked" - resp.json %. "status" `shouldMatch` "disabled" - - withMockServer lhMockApp \lhPort _chan -> do - setUpLHDevice tid alice bob lhPort - - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "enabled" + resp.json %. "status" `shouldMatch` "enabled" - putLegalholdStatus tid alice "disabled" - `bindResponse` assertLabel 403 "legalhold-whitelisted-only" + putLegalholdStatus tid alice "disabled" + `bindResponse` assertLabel 403 "legalhold-whitelisted-only" - -- the put doesn't have any influence on the status being "enabled" - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "enabled" + -- the put doesn't have any influence on the status being "enabled" + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" testLHGetMembersIncludesStatus :: App () testLHGetMembersIncludesStatus = do - startDynamicBackends [mempty] \[dom] -> do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, [bob]) <- createTeam dom 2 + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam OwnDomain 2 - let statusShouldBe :: String -> App () - statusShouldBe status = do - getTeamMembers alice tid `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - [bobMember] <- - resp.json %. "members" & asList >>= filterM \u -> do - (==) <$> asString (u %. "user") <*> objId bob - bobMember %. "legalhold_status" `shouldMatch` status + let statusShouldBe :: String -> App () + statusShouldBe status = do + getTeamMembers alice tid `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + [bobMember] <- + resp.json %. "members" & asList >>= filterM \u -> do + (==) <$> asString (u %. "user") <*> objId bob + bobMember %. "legalhold_status" `shouldMatch` status + statusShouldBe "no_consent" + withMockServer lhMockApp \lhDomAndPort _chan -> do statusShouldBe "no_consent" - withMockServer lhMockApp \lhPort _chan -> do - statusShouldBe "no_consent" - legalholdWhitelistTeam tid alice - >>= assertStatus 200 + legalholdWhitelistTeam tid alice + >>= assertStatus 200 - -- the status messages for these have already been tested - postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) - >>= assertStatus 201 + -- the status messages for these have already been tested + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) + >>= assertStatus 201 - -- legalhold has been requested but is disabled - statusShouldBe "disabled" + -- legalhold has been requested but is disabled + statusShouldBe "disabled" - requestLegalHoldDevice tid alice bob - >>= assertStatus 201 + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 - -- legalhold has been set to pending after requesting device - statusShouldBe "pending" + -- legalhold has been set to pending after requesting device + statusShouldBe "pending" - approveLegalHoldDevice tid bob defPassword - >>= assertStatus 200 + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 - -- bob has accepted the legalhold device - statusShouldBe "enabled" + -- bob has accepted the legalhold device + statusShouldBe "enabled" type TB s = TaggedBool s @@ -605,172 +593,322 @@ testLHNoConsentBlockOne2OneConv (MkTagged connectFirst) (MkTagged teampeer) (MkTagged approveLH) - (MkTagged testPendingConnection) = - startDynamicBackends [mempty] \[dom1] -> do - -- team users - -- alice (team owner) and bob (member) - (alice, tid, []) <- createTeam dom1 1 - bob <- - if teampeer - then do - (walice, _tid, []) <- createTeam dom1 1 - -- FUTUREWORK(mangoiv): creating a team on a second backend - -- causes this bug: https://wearezeta.atlassian.net/browse/WPB-6640 - pure walice - else randomUser dom1 def - - legalholdWhitelistTeam tid alice - >>= assertStatus 200 - - let doEnableLH :: HasCallStack => App (Maybe String) - doEnableLH = do - -- alice requests a legalhold device for herself - requestLegalHoldDevice tid alice alice - >>= assertStatus 201 - - when approveLH do - approveLegalHoldDevice tid alice defPassword - >>= assertStatus 200 - legalholdUserStatus tid alice alice `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" - if approveLH - then Just <$> lhDeviceIdOf alice - else pure Nothing - - doDisableLH :: HasCallStack => App () - doDisableLH = - disableLegalHold tid alice alice defPassword + (MkTagged testPendingConnection) = do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, []) <- createTeam OwnDomain 1 + bob <- + if teampeer + then do + (walice, _tid, []) <- createTeam OwnDomain 1 + -- FUTUREWORK(mangoiv): creating a team on a second backend + -- causes this bug: https://wearezeta.atlassian.net/browse/WPB-6640 + pure walice + else randomUser OwnDomain def + + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + let doEnableLH :: HasCallStack => App (Maybe String) + doEnableLH = do + -- alice requests a legalhold device for herself + requestLegalHoldDevice tid alice alice + >>= assertStatus 201 + + when approveLH do + approveLegalHoldDevice tid alice defPassword >>= assertStatus 200 + legalholdUserStatus tid alice alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" + if approveLH + then Just <$> lhDeviceIdOf alice + else pure Nothing + + doDisableLH :: HasCallStack => App () + doDisableLH = + disableLegalHold tid alice alice defPassword + >>= assertStatus 200 + + withMockServer lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) + >>= assertStatus 201 - withMockServer lhMockApp \lhPort _chan -> do - postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) - >>= assertStatus 201 - - if not connectFirst - then do - void doEnableLH - postConnection alice bob - >>= assertLabel 403 "missing-legalhold-consent" - - postConnection bob alice - >>= assertLabel 403 "missing-legalhold-consent" - else do - alicec <- objId $ addClient alice def >>= getJSON 201 - bobc <- objId $ addClient bob def >>= getJSON 201 - - postConnection alice bob - >>= assertStatus 201 - mbConvId <- - if testPendingConnection - then pure Nothing - else - Just - <$> do - putConnection bob alice "accepted" - >>= getJSON 200 - %. "qualified_conversation" - - -- we need to take away the pending/ sent status for the connections - [lastNotifAlice, lastNotifBob] <- for [(alice, alicec), (bob, bobc)] \(user, client) -> do - -- we get two events if bob accepts alice's request - let numEvents = if testPendingConnection then 1 else 2 - last <$> awaitNotifications user client Nothing numEvents isUserConnectionNotif - - mbLHDevice <- doEnableLH - - let assertConnectionsMissingLHConsent = - for_ [(bob, alice), (alice, bob)] \(a, b) -> - getConnections a `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - conn <- assertOne =<< do resp.json %. "connections" & asList - conn %. "status" `shouldMatch` "missing-legalhold-consent" - conn %. "from" `shouldMatch` objId a - conn %. "to" `shouldMatch` objId b - - assertConnectionsMissingLHConsent - - [lastNotifAlice', lastNotifBob'] <- for [(alice, alicec, lastNotifAlice), (bob, bobc, lastNotifBob)] \(user, client, lastNotif) -> do - awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> - notif %. "payload.0.connection.status" `shouldMatch` "missing-legalhold-consent" - $> notif - - for_ [(bob, alice), (alice, bob)] \(a, b) -> - putConnection a b "accepted" - >>= assertLabel 403 "bad-conn-update" - - -- putting the connection to "accepted" with 403 doesn't change the - -- connection status - assertConnectionsMissingLHConsent - - bobc2 <- objId $ addClient bob def >>= getJSON 201 - - let -- \| we send a message from bob to alice, but only if - -- we have a conversation id and a legalhold device - -- we first create a message that goes to recipients - -- chosen by the first callback passed - -- then send the message using proteus - -- and in the end running the assertino callback to - -- verify the result - sendMessageFromBobToAlice :: - HasCallStack => - (String -> [String]) -> - -- \^ if we have the legalhold device registered, this - -- callback will be passed the lh device - (Response -> App ()) -> - -- \^ the callback to verify our response (an assertion) - App () - sendMessageFromBobToAlice recipients assertion = - for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do - successfulMsgForOtherUsers <- - mkProteusRecipients - bob -- bob is the sender - [(alice, recipients device), (bob, [bobc])] - -- we send to clients of alice, maybe the legalhold device - -- we need to send to our other clients (bobc) - "hey alice (and eve)" -- the message - let bobaliceMessage = - Proto.defMessage @Proto.QualifiedNewOtrMessage - & #sender . Proto.client .~ (bobc2 ^?! hex) - & #recipients .~ [successfulMsgForOtherUsers] - & #reportAll .~ Proto.defMessage - -- make sure that `convId` is not just the `convId` but also - -- contains the domain because `postProteusMessage` will take the - -- comain from the `convId` json object - postProteusMessage bob convId bobaliceMessage - `bindResponse` assertion - - sendMessageFromBobToAlice (\device -> [alicec, device]) \resp -> do - resp.status `shouldMatchInt` 404 - - -- now we disable legalhold - doDisableLH - - for_ mbLHDevice \lhd -> - local (setTimeoutTo 90) $ - awaitNotification alice alicec noValue isUserClientRemoveNotif >>= \notif -> - notif %. "payload.0.client.id" `shouldMatch` lhd - - let assertStatusFor user status = - getConnections user `bindResponse` \resp -> do + if not connectFirst + then do + void doEnableLH + postConnection alice bob + >>= assertLabel 403 "missing-legalhold-consent" + + postConnection bob alice + >>= assertLabel 403 "missing-legalhold-consent" + else do + alicec <- objId $ addClient alice def >>= getJSON 201 + bobc <- objId $ addClient bob def >>= getJSON 201 + + postConnection alice bob + >>= assertStatus 201 + mbConvId <- + if testPendingConnection + then pure Nothing + else + Just + <$> do + putConnection bob alice "accepted" + >>= getJSON 200 + %. "qualified_conversation" + + -- we need to take away the pending/ sent status for the connections + [lastNotifAlice, lastNotifBob] <- for [(alice, alicec), (bob, bobc)] \(user, client) -> do + -- we get two events if bob accepts alice's request + let numEvents = if testPendingConnection then 1 else 2 + last <$> awaitNotifications user client Nothing numEvents isUserConnectionNotif + + mbLHDevice <- doEnableLH + + let assertConnectionsMissingLHConsent = + for_ [(bob, alice), (alice, bob)] \(a, b) -> + getConnections a `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 conn <- assertOne =<< do resp.json %. "connections" & asList - conn %. "status" `shouldMatch` status + conn %. "status" `shouldMatch` "missing-legalhold-consent" + conn %. "from" `shouldMatch` objId a + conn %. "to" `shouldMatch` objId b + + assertConnectionsMissingLHConsent + + [lastNotifAlice', lastNotifBob'] <- for [(alice, alicec, lastNotifAlice), (bob, bobc, lastNotifBob)] \(user, client, lastNotif) -> do + awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> + notif %. "payload.0.connection.status" `shouldMatch` "missing-legalhold-consent" + $> notif + + for_ [(bob, alice), (alice, bob)] \(a, b) -> + putConnection a b "accepted" + >>= assertLabel 403 "bad-conn-update" + + -- putting the connection to "accepted" with 403 doesn't change the + -- connection status + assertConnectionsMissingLHConsent + + bobc2 <- objId $ addClient bob def >>= getJSON 201 + + let -- \| we send a message from bob to alice, but only if + -- we have a conversation id and a legalhold device + -- we first create a message that goes to recipients + -- chosen by the first callback passed + -- then send the message using proteus + -- and in the end running the assertino callback to + -- verify the result + sendMessageFromBobToAlice :: + HasCallStack => + (String -> [String]) -> + -- \^ if we have the legalhold device registered, this + -- callback will be passed the lh device + (Response -> App ()) -> + -- \^ the callback to verify our response (an assertion) + App () + sendMessageFromBobToAlice recipients assertion = + for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do + successfulMsgForOtherUsers <- + mkProteusRecipients + bob -- bob is the sender + [(alice, recipients device), (bob, [bobc])] + -- we send to clients of alice, maybe the legalhold device + -- we need to send to our other clients (bobc) + "hey alice (and eve)" -- the message + let bobaliceMessage = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (bobc2 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + -- make sure that `convId` is not just the `convId` but also + -- contains the domain because `postProteusMessage` will take the + -- comain from the `convId` json object + postProteusMessage bob convId bobaliceMessage + `bindResponse` assertion + + sendMessageFromBobToAlice (\device -> [alicec, device]) \resp -> do + resp.status `shouldMatchInt` 404 + + -- now we disable legalhold + doDisableLH + + for_ mbLHDevice \lhd -> + local (setTimeoutTo 90) $ + awaitNotification alice alicec noValue isUserClientRemoveNotif >>= \notif -> + notif %. "payload.0.client.id" `shouldMatch` lhd + + let assertStatusFor user status = + getConnections user `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + conn <- assertOne =<< do resp.json %. "connections" & asList + conn %. "status" `shouldMatch` status + + if testPendingConnection + then do + assertStatusFor alice "sent" + assertStatusFor bob "pending" + else do + assertStatusFor alice "accepted" + assertStatusFor bob "accepted" + + for_ [(alice, alicec, lastNotifAlice'), (bob, bobc, lastNotifBob')] \(user, client, lastNotif) -> do + awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> + notif %. "payload.0.connection.status" `shouldMatchOneOf` ["sent", "pending", "accepted"] + + sendMessageFromBobToAlice (const [alicec]) \resp -> do + resp.status `shouldMatchInt` 201 + + sendMessageFromBobToAlice (\device -> [device]) \resp -> do + resp.status `shouldMatchInt` 412 + +data GroupConvAdmin + = LegalholderIsAdmin + | PeerIsAdmin + | BothAreAdmins + deriving (Show, Generic) - if testPendingConnection - then do - assertStatusFor alice "sent" - assertStatusFor bob "pending" - else do - assertStatusFor alice "accepted" - assertStatusFor bob "accepted" - - for_ [(alice, alicec, lastNotifAlice'), (bob, bobc, lastNotifBob')] \(user, client, lastNotif) -> do - awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> - notif %. "payload.0.connection.status" `shouldMatchOneOf` ["sent", "pending", "accepted"] - - sendMessageFromBobToAlice (const [alicec]) \resp -> do - resp.status `shouldMatchInt` 201 - - sendMessageFromBobToAlice (\device -> [device]) \resp -> do - resp.status `shouldMatchInt` 412 +-- | If a member of an existing conversation is assigned a LH device, users are removed from +-- the conversation until policy conflicts are resolved. +-- +-- As to who gets to stay: +-- - admins will stay over members +-- - local members will stay over remote members. +testLHNoConsentRemoveFromGroup :: GroupConvAdmin -> App () +testLHNoConsentRemoveFromGroup admin = do + (alice, tidAlice, []) <- createTeam OwnDomain 1 + (bob, tidBob, []) <- createTeam OwnDomain 1 + legalholdWhitelistTeam tidAlice alice >>= assertStatus 200 + withMockServer lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + withWebSockets [alice, bob] \[aws, bws] -> do + connectTwoUsers alice bob + (convId, qConvId) <- do + let (inviter, tidInviter, invitee, inviteeRole) = case admin of + LegalholderIsAdmin -> (alice, tidAlice, bob, "wire_member") + BothAreAdmins -> (alice, tidAlice, bob, "wire_admin") + PeerIsAdmin -> (bob, tidBob, alice, "wire_member") + + let createConv = defProteus {qualifiedUsers = [invitee], newUsersRole = inviteeRole, team = Just tidInviter} + postConversation inviter createConv `bindResponse` \resp -> do + resp.json %. "members.self.conversation_role" `shouldMatch` "wire_admin" + resp.json %. "members.others.0.conversation_role" `shouldMatch` case admin of + BothAreAdmins -> "wire_admin" + PeerIsAdmin -> "wire_member" + LegalholderIsAdmin -> "wire_member" + (,) <$> resp.json %. "id" <*> resp.json %. "qualified_id" + for_ [aws, bws] \ws -> do + awaitMatch isConvCreateNotifNotSelf ws >>= \pl -> pl %. "payload.0.conversation" `shouldMatch` convId + + for_ [alice, bob] \user -> + getConversation user qConvId >>= assertStatus 200 + + requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201 + approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200 + legalholdUserStatus tidAlice alice alice `bindResponse` \resp -> do + resp.json %. "status" `shouldMatch` "enabled" + resp.status `shouldMatchInt` 200 + + case admin of + LegalholderIsAdmin -> do + for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + getConversation alice qConvId >>= assertStatus 200 + getConversation bob qConvId >>= assertLabel 403 "access-denied" + PeerIsAdmin -> do + for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver alice) + getConversation bob qConvId >>= assertStatus 200 + getConversation alice qConvId >>= assertLabel 403 "access-denied" + BothAreAdmins -> do + for_ [aws, bws] do awaitMatch (isConvLeaveNotifWithLeaver bob) + getConversation alice qConvId >>= assertStatus 200 + getConversation bob qConvId >>= assertLabel 403 "access-denied" + +testLHHappyFlow :: App () +testLHHappyFlow = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 + let statusShouldBe :: String -> App () + statusShouldBe status = + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` status + + legalholdWhitelistTeam tid alice >>= assertStatus 200 + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + + -- implicit consent + statusShouldBe "disabled" + -- whitelisting is idempotent + legalholdWhitelistTeam tid alice >>= assertStatus 200 + statusShouldBe "disabled" + + -- memmbers cannot request LH devices + requestLegalHoldDevice tid bob alice >>= assertLabel 403 "operation-denied" + + -- owners can; bob should now have a pending request + requestLegalHoldDevice tid alice bob >>= assertStatus 201 + statusShouldBe "pending" + + -- owner cannot approve on behalf on user under legalhold + approveLegalHoldDevice' tid alice bob defPassword >>= assertLabel 403 "access-denied" + + -- user can approve the request, however + approveLegalHoldDevice tid bob defPassword `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + _ <- + resp.json `lookupField` "client.id" + >>= assertJust "client id is present" + resp.json %. "last_prekey" `shouldMatch` lpk + +testLHGetStatus :: App () +testLHGetStatus = do + (alice, tid, [bob]) <- createTeam OwnDomain 2 + (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2 + emil <- randomUser OwnDomain def + + let check :: HasCallStack => (MakesValue getter, MakesValue target) => getter -> target -> String -> App () + check getter target status = do + profile <- getUser getter target >>= getJSON 200 + pStatus <- profile %. "legalhold_status" & asString + status `shouldMatch` pStatus + + for_ [alice, bob, charlie, debora, emil] \u -> do + check u bob "no_consent" + check u emil "no_consent" + legalholdWhitelistTeam tid alice >>= assertStatus 200 + withMockServer lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tid alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + for_ [alice, bob, charlie, debora, emil] \u -> do + check u bob "disabled" + requestLegalHoldDevice tid alice bob >>= assertStatus 201 + check debora bob "pending" + approveLegalHoldDevice tid bob defPassword >>= assertStatus 200 + check debora bob "enabled" + +testLHCannotCreateGroupWithUsersInConflict :: App () +testLHCannotCreateGroupWithUsersInConflict = do + (alice, tidAlice, [bob]) <- createTeam OwnDomain 2 + (charlie, _tidCharlie, [debora]) <- createTeam OwnDomain 2 + legalholdWhitelistTeam tidAlice alice >>= assertStatus 200 + connectTwoUsers bob charlie + connectTwoUsers bob debora + withMockServer lhMockApp \lhDomAndPort _chan -> do + postLegalHoldSettings tidAlice alice (mkLegalHoldSettings lhDomAndPort) >>= assertStatus 201 + postConversation bob defProteus {qualifiedUsers = [charlie, alice], newUsersRole = "wire_member", team = Just tidAlice} + >>= assertStatus 201 + + requestLegalHoldDevice tidAlice alice alice >>= assertStatus 201 + approveLegalHoldDevice tidAlice alice defPassword >>= assertStatus 200 + legalholdUserStatus tidAlice alice alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + + postConversation bob defProteus {qualifiedUsers = [debora, alice], newUsersRole = "wire_member", team = Just tidAlice} + >>= assertLabel 403 "missing-legalhold-consent" diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index ee6f5e4da77..904386a791e 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -1,9 +1,13 @@ module Testlib.App where +import Control.Applicative ((<|>)) import Control.Monad.Reader +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import qualified Control.Retry as Retry import Data.Aeson hiding ((.=)) +import Data.Bool (bool) import Data.IORef +import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Yaml as Yaml import GHC.Exception @@ -72,3 +76,27 @@ instance MakesValue FedDomain where -- backwards-compatible way so everybody can benefit. retryT :: App a -> App a retryT action = Retry.recoverAll (Retry.exponentialBackoff 8000 <> Retry.limitRetries 10) (const action) + +-- | make Bool lazy +liftBool :: Functor f => f Bool -> BoolT f +liftBool = MaybeT . fmap (bool Nothing (Just ())) + +-- | make Bool strict +unliftBool :: Functor f => BoolT f -> f Bool +unliftBool = fmap isJust . runMaybeT + +-- | lazy (&&) +(&&~) :: App Bool -> App Bool -> App Bool +b1 &&~ b2 = unliftBool $ liftBool b1 *> liftBool b2 + +infixr 3 &&~ + +-- | lazy (||) +(||~) :: App Bool -> App Bool -> App Bool +b1 ||~ b2 = unliftBool $ liftBool b1 <|> liftBool b2 + +infixr 2 ||~ + +-- | lazy (&&): (*>) +-- lazy (||): (<|>) +type BoolT f = MaybeT f () diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 4becf8eb9a3..7ff7d2559bb 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -100,6 +100,7 @@ mkGlobalEnv cfgFile = do { gServiceMap = sm, gDomain1 = intConfig.backendOne.originDomain, gDomain2 = intConfig.backendTwo.originDomain, + gIntegrationTestHostName = intConfig.integrationTestHostName, gFederationV0Domain = intConfig.federationV0.originDomain, gDynamicDomains = (.domain) <$> Map.elems intConfig.dynamicBackends, gDefaultAPIVersion = 6, @@ -138,6 +139,7 @@ mkEnv ge = do { serviceMap = gServiceMap ge, domain1 = gDomain1 ge, domain2 = gDomain2 ge, + integrationTestHostName = gIntegrationTestHostName ge, federationV0Domain = gFederationV0Domain ge, dynamicDomains = gDynamicDomains ge, defaultAPIVersion = gDefaultAPIVersion ge, diff --git a/integration/test/Testlib/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs index c7c279211e4..7e91be4b7b5 100644 --- a/integration/test/Testlib/MockIntegrationService.hs +++ b/integration/test/Testlib/MockIntegrationService.hs @@ -13,7 +13,7 @@ import Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp.Internal as Warp import qualified Network.Wai.Handler.WarpTLS as Warp -import Testlib.Prelude +import Testlib.Prelude hiding (IntegrationConfig (integrationTestHostName)) import UnliftIO (MonadUnliftIO (withRunInIO)) import UnliftIO.Async import UnliftIO.Chan @@ -86,14 +86,11 @@ mockServerCert = \T45GXxRd18neXtuYa/OoAw9UQFDN5XfXN0g=\n\ \-----END CERTIFICATE-----" -botHost :: String -botHost = "localhost" - withFreePortAnyAddr :: (MonadMask m, MonadIO m) => ((Warp.Port, Socket) -> m a) -> m a withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) -openFreePortAnyAddr = liftIO $ bindRandomPortTCP (fromString "*") +openFreePortAnyAddr = liftIO $ bindRandomPortTCP (fromString "*6") type LiftedApplication = Request -> (Wai.Response -> App ResponseReceived) -> App ResponseReceived @@ -102,10 +99,11 @@ withMockServer :: -- | the mock server (Chan e -> LiftedApplication) -> -- | the test - (Warp.Port -> Chan e -> App a) -> + ((String, Warp.Port) -> Chan e -> App a) -> App a -withMockServer mkApp go = withFreePortAnyAddr $ \(sPort, sock) -> do +withMockServer mkApp go = withFreePortAnyAddr \(sPort, sock) -> do serverStarted <- newEmptyMVar + host <- asks integrationTestHostName let tlss = Warp.tlsSettingsMemory (cs mockServerCert) (cs mockServerPrivKey) let defs = Warp.defaultSettings {Warp.settingsPort = sPort, Warp.settingsBeforeMainLoop = putMVar serverStarted ()} buf <- newChan @@ -114,7 +112,7 @@ withMockServer mkApp go = withFreePortAnyAddr $ \(sPort, sock) -> do inIO $ mkApp buf req (liftIO . respond) srvMVar <- UnliftIO.Timeout.timeout 5_000_000 (takeMVar serverStarted) case srvMVar of - Just () -> go sPort buf `finally` cancel srv + Just () -> go (host, sPort) buf `finally` cancel srv Nothing -> error . show =<< poll srv lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> LiftedApplication @@ -172,8 +170,8 @@ lhMockAppWithPrekeys mks ch req cont = withRunInIO \inIO -> do getRequestHeader :: String -> Wai.Request -> Maybe ByteString getRequestHeader name = lookup (fromString name) . requestHeaders -mkLegalHoldSettings :: Warp.Port -> Value -mkLegalHoldSettings lhPort = +mkLegalHoldSettings :: (String, Warp.Port) -> Value +mkLegalHoldSettings (botHost, lhPort) = object [ "base_url" .= ("https://" <> botHost <> ":" <> show lhPort <> "/legalhold"), "public_key" .= mockServerPubKey, diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index 4009cd99144..430f8d84d0a 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -102,6 +102,7 @@ data GlobalEnv = GlobalEnv { gServiceMap :: Map String ServiceMap, gDomain1 :: String, gDomain2 :: String, + gIntegrationTestHostName :: String, gFederationV0Domain :: String, gDynamicDomains :: [String], gDefaultAPIVersion :: Int, @@ -118,6 +119,7 @@ data IntegrationConfig = IntegrationConfig { backendOne :: BackendConfig, backendTwo :: BackendConfig, federationV0 :: BackendConfig, + integrationTestHostName :: String, dynamicBackends :: Map String DynamicBackendConfig, rabbitmq :: RabbitMQConfig, cassandra :: CassandraConfig @@ -131,6 +133,7 @@ instance FromJSON IntegrationConfig where <$> parseJSON (Object o) <*> o .: fromString "backendTwo" <*> o .: fromString "federation-v0" + <*> o .: fromString "integrationTestHostName" <*> o .: fromString "dynamicBackends" <*> o .: fromString "rabbitmq" <*> o .: fromString "cassandra" @@ -195,6 +198,7 @@ data Env = Env { serviceMap :: Map String ServiceMap, domain1 :: String, domain2 :: String, + integrationTestHostName :: String, federationV0Domain :: String, dynamicDomains :: [String], defaultAPIVersion :: Int, @@ -445,7 +449,17 @@ lookupConfigOverride overrides = \case Stern -> overrides.sternCfg FederatorInternal -> overrides.federatorInternalCfg -data Service = Brig | Galley | Cannon | Gundeck | Cargohold | Nginz | Spar | BackgroundWorker | Stern | FederatorInternal +data Service + = Brig + | Galley + | Cannon + | Gundeck + | Cargohold + | Nginz + | Spar + | BackgroundWorker + | Stern + | FederatorInternal deriving ( Show, Eq, diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/MockServer.hs b/libs/wai-utilities/src/Network/Wai/Utilities/MockServer.hs index d0072d6fbd9..407c0d47863 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/MockServer.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/MockServer.hs @@ -20,7 +20,7 @@ module Network.Wai.Utilities.MockServer where import Control.Concurrent.Async qualified as Async -import Control.Exception (throw) +import Control.Exception (throwIO) import Control.Exception qualified as E import Control.Monad.Catch import Control.Monad.Codensity @@ -83,10 +83,10 @@ startMockServer mtlsSettings app = do me <- Async.poll serverThread case me of Nothing -> Async.cancel serverThread - Just (Left e) -> throw e + Just (Left e) -> throwIO e Just (Right a) -> pure a case serverStartedSignal of Nothing -> do Async.cancel serverThread - throw (MockTimeout port) + throwIO (MockTimeout port) Just _ -> pure (closeMock, port) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 1cd1f785a01..c9a3118bcf6 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -38,22 +38,18 @@ import Data.Range import Data.Time.Clock qualified as Time import Galley.Cassandra.LegalHold import Galley.Env qualified as Galley -import Galley.Options (featureFlags, settings) -import Galley.Types.Teams import Imports import Network.HTTP.Types.Status (status200, status404) import Network.Wai as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Utilities.Error qualified as Error -import System.IO (hPutStrLn) import Test.QuickCheck.Instances () import Test.Tasty -import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import TestHelpers import TestSetup import Wire.API.Connection qualified as Conn -import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) +import Wire.API.Conversation.Role (roleNameWireAdmin) import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.LegalHold @@ -63,21 +59,6 @@ import Wire.API.Team.Permission import Wire.API.Team.Role import Wire.API.User.Client -onlyIfLhWhitelisted :: TestM () -> TestM () -onlyIfLhWhitelisted action = do - featureLegalHold <- view (tsGConf . settings . featureFlags . flagLegalHold) - case featureLegalHold of - FeatureLegalHoldDisabledPermanently -> - liftIO $ hPutStrLn stderr errmsg - FeatureLegalHoldDisabledByDefault -> - liftIO $ hPutStrLn stderr errmsg - FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> action - where - errmsg = - "*** skipping test. This test only works if you manually adjust the server config files\ - \(the 'withLHWhitelist' trick does not work because it does not allow \ - \brig to talk to the dynamically spawned galley)." - tests :: IO TestSetup -> TestTree tests s = testGroup "Legalhold" [testsPublic s, testsInternal s] @@ -93,7 +74,6 @@ testsPublic s = -- behavior of existing end-points testOnlyIfLhWhitelisted s "POST /clients" testCannotCreateLegalHoldDeviceOldAPI, testOnlyIfLhWhitelisted s "POST /register - can add team members above fanout limit when whitelisting is enabled" testAddTeamUserTooLargeWithLegalholdWhitelisted, - testOnlyIfLhWhitelisted s "GET legalhold status in user profile" testGetLegalholdStatus, {- TODO: conversations/{cnv}/otr/messages - possibly show the legal hold device (if missing) as a different device type (or show that on device level, depending on how client teams prefer) GET /team/{tid}/members - show legal hold status of all members @@ -103,32 +83,12 @@ testsPublic s = "settings.legalholdEnabledTeams" -- FUTUREWORK: ungroup this level [ testGroup -- FUTUREWORK: ungroup this level "teams listed" - [ test s "happy flow" testInWhitelist, - testGroup - "Legalhold is activated for user A in a group conversation" - [ testOnlyIfLhWhitelisted s "All admins are consenting: all non-consenters get removed from conversation" (testNoConsentRemoveFromGroupConv LegalholderIsAdmin), - testOnlyIfLhWhitelisted s "Some admins are consenting: all non-consenters get removed from conversation" (testNoConsentRemoveFromGroupConv BothAreAdmins), - testOnlyIfLhWhitelisted s "No admins are consenting: all LH activated/pending users get removed from conversation" (testNoConsentRemoveFromGroupConv PeerIsAdmin) - ], - testGroup + [ testGroup "Users are invited to a group conversation." [ testGroup - "At least one invited user has activated legalhold. At least one admin of the group has given consent." - [ test - s - "If all all users in the invite have given consent then the invite succeeds and all non-consenters from the group get removed" - (onlyIfLhWhitelisted (testGroupConvInvitationHandlesLHConflicts InviteOnlyConsenters)), - test - s - "If any user in the invite has not given consent then the invite fails" - (onlyIfLhWhitelisted (testGroupConvInvitationHandlesLHConflicts InviteAlsoNonConsenters)) - ], - testGroup "The group conversation contains legalhold activated users." - [ testOnlyIfLhWhitelisted s "If any user in the invite has not given consent then the invite fails" testNoConsentCannotBeInvited - ] + [testOnlyIfLhWhitelisted s "If any user in the invite has not given consent then the invite fails" testNoConsentCannotBeInvited] ], - testOnlyIfLhWhitelisted s "Cannot create conversation with both LH activated and non-consenting users" testCannotCreateGroupWithUsersInConflict, test s "bench hack" testBenchHack ] ] @@ -310,185 +270,9 @@ testCannotCreateLegalHoldDeviceOldAPI = do post req !!! const 400 === statusCode assertZeroLegalHoldDevices uid -testInWhitelist :: TestM () -testInWhitelist = do - g <- viewGalley - (owner, tid) <- createBindingTeam - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - cannon <- view tsCannon - - putLHWhitelistTeam tid !!! const 200 === statusCode - - WS.bracketR2 cannon member member $ \(_ws, _ws') -> withDummyTestServiceForTeam owner tid $ \_chan -> do - do - -- members have granted consent (implicitly)... - lhs <- view legalHoldStatus <$> withLHWhitelist tid (getTeamMember' g member tid member) - liftIO $ assertEqual "" lhs UserLegalHoldDisabled - - -- ... and can do so again (idempotency). - _ <- withLHWhitelist tid (void $ putLHWhitelistTeam' g tid) - lhs' <- withLHWhitelist tid $ view legalHoldStatus <$> getTeamMember' g member tid member - liftIO $ assertEqual "" lhs' UserLegalHoldDisabled - - do - -- members can't request LH devices - withLHWhitelist tid (requestLegalHoldDevice' g member member tid) !!! testResponse 403 (Just "operation-denied") - UserLegalHoldStatusResponse userStatus _ _ <- withLHWhitelist tid (getUserStatusTyped' g member tid) - liftIO $ - assertEqual - "User with insufficient permissions should be unable to start flow" - UserLegalHoldDisabled - userStatus - do - -- owners can - withLHWhitelist tid (requestLegalHoldDevice' g owner member tid) !!! testResponse 201 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- withLHWhitelist tid (getUserStatusTyped' g member tid) - liftIO $ - assertEqual - "requestLegalHoldDevice should set user status to Pending" - UserLegalHoldPending - userStatus - do - -- request device is idempotent - withLHWhitelist tid (requestLegalHoldDevice' g owner member tid) !!! testResponse 204 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- withLHWhitelist tid (getUserStatusTyped' g member tid) - liftIO $ - assertEqual - "requestLegalHoldDevice when already pending should leave status as Pending" - UserLegalHoldPending - userStatus - do - -- owner cannot approve legalhold device - withLHWhitelist tid (approveLegalHoldDevice' g (Just defPassword) owner member tid) !!! testResponse 403 (Just "access-denied") - do - -- approve works - withLHWhitelist tid (approveLegalHoldDevice' g (Just defPassword) member member tid) !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus lastPrekey' clientId' <- withLHWhitelist tid (getUserStatusTyped' g member tid) - liftIO $ - do - assertEqual "approving should change status to Enabled" UserLegalHoldEnabled userStatus - assertEqual "last_prekey should be set when LH is pending" (Just (head someLastPrekeys)) lastPrekey' - assertEqual "client.id should be set when LH is pending" (Just someClientId) clientId' - -data GroupConvAdmin - = LegalholderIsAdmin - | PeerIsAdmin - | BothAreAdmins - deriving (Show, Eq, Ord, Bounded, Enum) - -testNoConsentRemoveFromGroupConv :: GroupConvAdmin -> HasCallStack => TestM () -testNoConsentRemoveFromGroupConv whoIsAdmin = do - (legalholder :: UserId, tid) <- createBindingTeam - qLegalHolder <- Qualified legalholder <$> viewFederationDomain - (peer :: UserId, teamPeer) <- createBindingTeam - qPeer <- Qualified peer <$> viewFederationDomain - galley <- viewGalley - - let enableLHForLegalholder :: HasCallStack => TestM () - enableLHForLegalholder = do - requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - - cannon <- view tsCannon - - putLHWhitelistTeam tid !!! const 200 === statusCode - WS.bracketR2 cannon legalholder peer $ \(legalholderWs, peerWs) -> withDummyTestServiceForTeam legalholder tid $ \_chan -> do - postConnection legalholder peer !!! const 201 === statusCode - void $ putConnection peer legalholder Conn.Accepted (qLegalHolder, tid, qPeer, roleNameWireMember) - PeerIsAdmin -> (qPeer, teamPeer, qLegalHolder, roleNameWireMember) - BothAreAdmins -> (qLegalHolder, tid, qPeer, roleNameWireAdmin) - - convId <- createTeamConvWithRole (qUnqualified inviter) tidInviter [qUnqualified invitee] (Just "group chat with external peer") Nothing Nothing inviteeRole - mapM_ (assertConvMemberWithRole roleNameWireAdmin convId) ([inviter] <> [invitee | whoIsAdmin == BothAreAdmins]) - mapM_ (assertConvMemberWithRole roleNameWireMember convId) [invitee | whoIsAdmin /= BothAreAdmins] - pure convId - qconvId <- Qualified convId <$> viewFederationDomain - - checkConvCreateEvent convId legalholderWs - checkConvCreateEvent convId peerWs - - assertConvMember qLegalHolder convId - assertConvMember qPeer convId - - void enableLHForLegalholder - - case whoIsAdmin of - LegalholderIsAdmin -> do - assertConvMember qLegalHolder convId - assertNotConvMember peer convId - checkConvMemberLeaveEvent qconvId qPeer legalholderWs - checkConvMemberLeaveEvent qconvId qPeer peerWs - PeerIsAdmin -> do - assertConvMember qPeer convId - assertNotConvMember legalholder convId - checkConvMemberLeaveEvent qconvId qLegalHolder legalholderWs - checkConvMemberLeaveEvent qconvId qLegalHolder peerWs - BothAreAdmins -> do - assertConvMember qLegalHolder convId - assertNotConvMember peer convId - checkConvMemberLeaveEvent qconvId qPeer legalholderWs - checkConvMemberLeaveEvent qconvId qPeer peerWs - data GroupConvInvCase = InviteOnlyConsenters | InviteAlsoNonConsenters deriving (Show, Eq, Ord, Bounded, Enum) -testGroupConvInvitationHandlesLHConflicts :: HasCallStack => GroupConvInvCase -> TestM () -testGroupConvInvitationHandlesLHConflicts inviteCase = do - localDomain <- viewFederationDomain - -- team that is legalhold whitelisted - (legalholder :: UserId, tid) <- createBindingTeam - let qLegalHolder = Qualified legalholder localDomain - userWithConsent <- (^. Team.userId) <$> addUserToTeam legalholder tid - userWithConsent2 <- do - uid <- (^. Team.userId) <$> addUserToTeam legalholder tid - pure $ Qualified uid localDomain - putLHWhitelistTeam tid !!! const 200 === statusCode - - -- team without legalhold - (peer :: UserId, teamPeer) <- createBindingTeam - peer2 <- (^. Team.userId) <$> addUserToTeam peer teamPeer - let qpeer2 = Qualified peer2 localDomain - - do - postConnection userWithConsent peer !!! const 201 === statusCode - void $ putConnection peer userWithConsent Conn.Accepted do - -- conversation with 1) userWithConsent and 2) peer - convId <- createTeamConvWithRole userWithConsent tid [peer] (Just "corp + us") Nothing Nothing roleNameWireAdmin - let qconvId = Qualified convId localDomain - - -- activate legalhold for legalholder - do - galley <- viewGalley - requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - - case inviteCase of - InviteOnlyConsenters -> do - API.Util.postMembers userWithConsent (qLegalHolder :| [userWithConsent2]) qconvId - !!! const 200 === statusCode - - assertConvMember qLegalHolder convId - assertConvMember userWithConsent2 convId - assertNotConvMember peer convId - InviteAlsoNonConsenters -> do - API.Util.postMembers userWithConsent (qLegalHolder :| [qpeer2]) qconvId - >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") - testNoConsentCannotBeInvited :: HasCallStack => TestM () testNoConsentCannotBeInvited = do localDomain <- viewFederationDomain @@ -532,39 +316,6 @@ testNoConsentCannotBeInvited = do API.Util.postQualifiedMembers userLHNotActivated (Qualified peer2 localdomain :| []) qconvId >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") -testCannotCreateGroupWithUsersInConflict :: HasCallStack => TestM () -testCannotCreateGroupWithUsersInConflict = do - -- team that is legalhold whitelisted - (legalholder :: UserId, tid) <- createBindingTeam - userLHNotActivated <- (^. Team.userId) <$> addUserToTeam legalholder tid - putLHWhitelistTeam tid !!! const 200 === statusCode - - -- team without legalhold - (peer :: UserId, teamPeer) <- createBindingTeam - peer2 <- (^. Team.userId) <$> addUserToTeam peer teamPeer - - do - postConnection userLHNotActivated peer !!! const 201 === statusCode - void $ putConnection peer userLHNotActivated Conn.Accepted do - createTeamConvAccessRaw userLHNotActivated tid [peer, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) - !!! const 201 === statusCode - - -- activate legalhold for legalholder - do - galley <- viewGalley - requestLegalHoldDevice legalholder legalholder tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) legalholder legalholder tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped' galley legalholder tid - liftIO $ assertEqual "approving should change status" UserLegalHoldEnabled userStatus - - createTeamConvAccessRaw userLHNotActivated tid [peer2, legalholder] (Just "corp + us") Nothing Nothing Nothing (Just roleNameWireMember) - >>= errWith 403 (\err -> Error.label err == "missing-legalhold-consent") - testBenchHack :: HasCallStack => TestM () testBenchHack = do {- representative sample run on an old laptop: diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 023da95ed90..a9315929573 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -92,7 +92,6 @@ tests s = testOnlyIfLhEnabled s "POST /clients" testCannotCreateLegalHoldDeviceOldAPI, testOnlyIfLhEnabled s "GET /teams/{tid}/members" testGetTeamMembersIncludesLHStatus, testOnlyIfLhEnabled s "POST /register - cannot add team members above fanout limit" testAddTeamUserTooLargeWithLegalhold, - testOnlyIfLhEnabled s "GET legalhold status in user profile" testGetLegalholdStatus, {- TODO: conversations/{cnv}/otr/messages - possibly show the legal hold device (if missing) as a different device type (or show that on device level, depending on how client teams prefer) GET /team/{tid}/members - show legal hold status of all members diff --git a/services/galley/test/integration/API/Teams/LegalHold/Util.hs b/services/galley/test/integration/API/Teams/LegalHold/Util.hs index e0b2d06481b..fec9706579b 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/Util.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/Util.hs @@ -25,7 +25,6 @@ import Data.ByteString.Char8 qualified as BS import Data.ByteString.Conversion import Data.CallStack import Data.Id -import Data.LegalHold import Data.List.NonEmpty qualified as NonEmpty import Data.List1 qualified as List1 import Data.Misc (PlainTextPassword6) @@ -57,8 +56,6 @@ import Wire.API.Provider.Service import Wire.API.Team.Feature qualified as Public import Wire.API.Team.LegalHold import Wire.API.Team.LegalHold.External -import Wire.API.Team.Member qualified as Team -import Wire.API.User (UserProfile (..)) import Wire.API.User.Client import Wire.API.UserEvent qualified as Ev @@ -221,60 +218,6 @@ publicKeyNotMatchingService = ] in k -testGetLegalholdStatus :: TestM () -testGetLegalholdStatus = do - (owner1, tid1) <- createBindingTeam - member1 <- view Team.userId <$> addUserToTeam owner1 tid1 - - (owner2, tid2) <- createBindingTeam - member2 <- view Team.userId <$> addUserToTeam owner2 tid2 - - personal <- randomUser - - let check :: HasCallStack => UserId -> UserId -> Maybe TeamId -> UserLegalHoldStatus -> TestM () - check getter targetUser targetTeam stat = do - profile <- getUserProfile getter targetUser - when (profileLegalholdStatus profile /= stat) $ do - meminfo <- getUserStatusTyped targetUser `mapM` targetTeam - - liftIO . forM_ meminfo $ \mem -> do - assertEqual "member LH status" stat (ulhsrStatus mem) - assertEqual "team id in brig user record" targetTeam (profileTeam profile) - - liftIO $ assertEqual "user profile status info" stat (profileLegalholdStatus profile) - - requestDev :: HasCallStack => UserId -> UserId -> TeamId -> TestM () - requestDev requestor target tid = do - requestLegalHoldDevice requestor target tid !!! testResponse 201 Nothing - - approveDev :: HasCallStack => UserId -> TeamId -> TestM () - approveDev target tid = do - approveLegalHoldDevice (Just defPassword) target target tid !!! testResponse 200 Nothing - - check owner1 member1 (Just tid1) UserLegalHoldNoConsent - check member1 member1 (Just tid1) UserLegalHoldNoConsent - check owner2 member1 (Just tid1) UserLegalHoldNoConsent - check member2 member1 (Just tid1) UserLegalHoldNoConsent - check personal member1 (Just tid1) UserLegalHoldNoConsent - check owner1 personal Nothing UserLegalHoldNoConsent - check member1 personal Nothing UserLegalHoldNoConsent - check owner2 personal Nothing UserLegalHoldNoConsent - check member2 personal Nothing UserLegalHoldNoConsent - check personal personal Nothing UserLegalHoldNoConsent - - putLHWhitelistTeam tid1 !!! const 200 === statusCode - - withDummyTestServiceForTeam owner1 tid1 $ \_chan -> do - check owner1 member1 (Just tid1) UserLegalHoldDisabled - check member2 member1 (Just tid1) UserLegalHoldDisabled - check personal member1 (Just tid1) UserLegalHoldDisabled - - requestDev owner1 member1 tid1 - check personal member1 (Just tid1) UserLegalHoldPending - - approveDev member1 tid1 - check personal member1 (Just tid1) UserLegalHoldEnabled - ---------------------------------------------------------------------- -- API helpers diff --git a/services/integration.yaml b/services/integration.yaml index 00d54a5efa3..dbfc516bf87 100644 --- a/services/integration.yaml +++ b/services/integration.yaml @@ -61,7 +61,7 @@ federatorExternal: host: 127.0.0.1 port: 8098 -# This domain is configured using coredns runing along with the rest of +# This domain is configured using coredns running along with the rest of # docker-ephemeral setup. There is only an SRV record for # _wire-server-federator._tcp.example.com originDomain: example.com @@ -118,7 +118,6 @@ backendTwo: originDomain: b.example.com - redis2: host: 127.0.0.1 port: 6379 @@ -181,3 +180,5 @@ federation-v0: stern: host: 127.0.0.1 port: 21091 + +integrationTestHostName: "localhost"