From 05d92f28b3f20487f0e0c37f0ace7c537c71985a Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 5 Feb 2024 18:13:25 +0100 Subject: [PATCH 01/21] [fix] use -e flag to abort when `docker-compose` fails --- deploy/dockerephemeral/run.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/deploy/dockerephemeral/run.sh b/deploy/dockerephemeral/run.sh index 57d0e7223ae..8d9a98cc8be 100755 --- a/deploy/dockerephemeral/run.sh +++ b/deploy/dockerephemeral/run.sh @@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -x +set -xe # run.sh should work no matter what is the current directory SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" From 4e4e9d1a9352e48c9c223b0334d5f00507ef407d Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 6 Feb 2024 11:13:29 +0100 Subject: [PATCH 02/21] [feat] port testRequestLegalHoldDevice --- integration/test/API/Brig.hs | 1 - integration/test/API/Galley.hs | 11 ++- integration/test/Notifications.hs | 3 + integration/test/Test/LegalHold.hs | 54 +++++++++++++- .../test/integration/API/Teams/LegalHold.hs | 74 ------------------- 5 files changed, 62 insertions(+), 81 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index c09fc64ec38..a78cbdd7800 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -149,7 +149,6 @@ deleteUser user = do submit "DELETE" $ req & addJSONObject ["password" .= defPassword] --- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients__uid_ addClient :: (HasCallStack, MakesValue user) => user -> diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 14123b112f7..284a2196e54 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -579,6 +579,13 @@ putTeamProperties tid caller properties = do req ) +legalholdUserStatus :: (HasCallStack, MakesValue tid, MakesValue user, MakesValue owner) => tid -> owner -> user -> App Response +legalholdUserStatus tid ownerid user = do + tidS <- asString tid + uid <- objId user + req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidS, "legalhold", uid]) + submit "GET" req + -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings enableLegalHold :: (HasCallStack, MakesValue tid, MakesValue ownerid) => tid -> ownerid -> App Response enableLegalHold tid ownerid = do @@ -587,8 +594,8 @@ enableLegalHold tid ownerid = do submit "PUT" (addJSONObject ["status" .= "enabled", "ttl" .= "unlimited"] req) -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings -postLegalHoldSettings :: (HasCallStack, MakesValue owner, MakesValue tid, MakesValue newService) => owner -> tid -> newService -> App Response -postLegalHoldSettings owner tid newSettings = retrying policy only412 $ \_ -> do +postLegalHoldSettings :: (HasCallStack, MakesValue ownerid, MakesValue tid, MakesValue newService) => tid -> ownerid -> newService -> App Response +postLegalHoldSettings tid owner newSettings = retrying policy only412 $ \_ -> do tidStr <- asString tid req <- baseRequest owner Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "settings"]) newSettingsObj <- make newSettings diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 9ea53706223..885cbefaaff 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -113,6 +113,9 @@ isConvDeleteNotif n = fieldEquals n "payload.0.type" "conversation.delete" isTeamMemberLeaveNotif :: MakesValue a => a -> App Bool isTeamMemberLeaveNotif n = nPayload n %. "type" `isEqual` "team.member-leave" +isUserActivateNotif :: MakesValue a => a -> App Bool +isUserActivateNotif n = nPayload n %. "type" `isEqual` "user.activate" + assertLeaveNotification :: ( HasCallStack, MakesValue fromUser, diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index d35af907b28..32dcb12f794 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -29,6 +29,7 @@ import qualified Data.ProtoLens as Proto import Data.ProtoLens.Labels () import qualified Data.Set as Set import GHC.Stack +import Notifications (awaitNotification, isUserActivateNotif) import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -45,7 +46,7 @@ testLHPreventAddingNonConsentingUsers = do void $ legalholdWhitelistTeam owner tid >>= assertSuccess void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess - void $ postLegalHoldSettings owner tid (mkLegalHoldSettings lhPort) >>= getJSON 201 + void $ postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= getJSON 201 george <- randomUser dom def georgeQId <- george %. "qualified_id" @@ -107,7 +108,7 @@ testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedB void $ legalholdWhitelistTeam owner tid >>= assertSuccess void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess - void $ postLegalHoldSettings owner tid (mkLegalHoldSettings lhPort) >>= getJSON 201 + void $ postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= getJSON 201 conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 @@ -202,8 +203,8 @@ testLHClaimKeys = WithBoundedEnumArg $ \testmode -> do (powner, ptid, [pmem]) <- createTeam dom 2 legalholdWhitelistTeam lowner ltid >>= assertSuccess - legalholdIsTeamInWhitelist lowner ltid >>= assertSuccess - void $ postLegalHoldSettings lowner ltid (mkLegalHoldSettings lhPort) >>= getJSON 201 + legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess + void $ postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhPort) >>= getJSON 201 requestLegalHoldDevice ltid lowner lmem >>= assertSuccess approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess @@ -274,3 +275,48 @@ testLHDeleteClientManually = do -- make sure the reason is the right one, and not eg. "LH service not present", or some -- other unspecific client error. 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 `bindResponse` \resp -> do + resp.status `shouldMatchInt` 403 + resp.json %. "label" `shouldMatch` "legalhold-not-enabled" + + reqNotEnabled alice bob + + withMockServer lhMockApp $ \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 alice tid >>= assertSuccess + postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) >>= assertSuccess + + statusShouldbe "disabled" + + requestLegalHoldDevice tid alice bob >>= assertSuccess + statusShouldbe "pending" + + -- requesting twice should be idempotent wrt the approval + requestLegalHoldDevice tid alice bob `bindResponse` \resp -> + resp.status `shouldMatchInt` 204 + statusShouldbe "pending" + + -- TODO(mangoiv): test if prekeys are in cassandra? + + alicec <- objId $ addClient alice def `bindResponse` getJSON 201 + bobc <- objId $ addClient bob def `bindResponse` getJSON 201 + for_ [(alice, alicec), (bob, bobc)] \(user, client) -> + awaitNotification user client noValue isUserActivateNotif >>= \notif -> do + printJSON notif + notif %. "payload.0.user.managed_by" `shouldMatch` "wire" diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 91315aa036d..5065c555be0 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -104,7 +104,6 @@ testsPublic s = testGroup "Teams LegalHold API (with flag whitelist-teams-and-implicit-consent)" [ -- device handling (CRUD) - testOnlyIfLhWhitelisted s "POST /teams/{tid}/legalhold/{uid}" testRequestLegalHoldDevice, testOnlyIfLhWhitelisted s "PUT /teams/{tid}/legalhold/approve" testApproveLegalHoldDevice, test s "(user denies approval: nothing needs to be done in backend)" (pure ()), testOnlyIfLhWhitelisted s "GET /teams/{tid}/legalhold/{uid}" testGetLegalHoldDeviceStatus, @@ -192,79 +191,6 @@ testWhitelistingTeams = do expectWhitelisted False tid -testRequestLegalHoldDevice :: TestM () -testRequestLegalHoldDevice = withTeam $ \owner tid -> do - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - -- Can't request a device if team feature flag is disabled - requestLegalHoldDevice owner member tid !!! testResponse 403 (Just "legalhold-not-enabled") - cannon <- view tsCannon - -- Assert that the appropriate LegalHold Request notification is sent to the user's - -- clients - WS.bracketR2 cannon member member $ \(ws, ws') -> withDummyTestServiceForTeamNoService $ \lhPort _chan -> do - do - -- test device creation without consent - requestLegalHoldDevice member member tid !!! testResponse 403 (Just "legalhold-not-enabled") - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "User with insufficient permissions should be unable to start flow" - UserLegalHoldNoConsent - userStatus - - do - requestLegalHoldDevice owner member tid !!! testResponse 403 (Just "legalhold-not-enabled") - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "User with insufficient permissions should be unable to start flow" - UserLegalHoldNoConsent - userStatus - - putLHWhitelistTeam tid !!! const 200 === statusCode - newService <- newLegalHoldService lhPort - postSettings owner tid newService !!! testResponse 201 Nothing - - do - requestLegalHoldDevice member member tid !!! testResponse 403 (Just "operation-denied") - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "User with insufficient permissions should be unable to start flow" - UserLegalHoldDisabled - userStatus - - do - requestLegalHoldDevice owner member tid !!! testResponse 201 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "requestLegalHoldDevice should set user status to Pending" - UserLegalHoldPending - userStatus - do - requestLegalHoldDevice owner member tid !!! testResponse 204 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "requestLegalHoldDevice when already pending should leave status as Pending" - UserLegalHoldPending - userStatus - - cassState <- view tsCass - liftIO $ do - storedPrekeys <- Cql.runClient cassState (LegalHoldData.selectPendingPrekeys member) - assertBool "user should have pending prekeys stored" (not . null $ storedPrekeys) - let pluck = \case - (Ev.LegalHoldClientRequested rdata) -> do - Ev.lhcTargetUser rdata @?= member - Ev.lhcLastPrekey rdata @?= head someLastPrekeys - Ev.lhcClientId rdata @?= someClientId - _ -> assertBool "Unexpected event" False - assertNotification ws pluck - -- all devices get notified. - assertNotification ws' pluck - testApproveLegalHoldDevice :: TestM () testApproveLegalHoldDevice = do (owner, tid) <- createBindingTeam From 44e1f4a902b827bd8a4774dbd47d2dbe53601eba Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 6 Feb 2024 17:32:09 +0100 Subject: [PATCH 03/21] [wip] implement add Legalhold Device --- integration/test/API/GalleyInternal.hs | 8 +- integration/test/Test/LegalHold.hs | 102 +++++++++++++----- integration/test/Testlib/HTTP.hs | 25 +++-- .../test/integration/API/Teams/LegalHold.hs | 2 +- 4 files changed, 100 insertions(+), 37 deletions(-) diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 89f3eac5716..664c5e106b1 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -59,14 +59,14 @@ getFederationStatus user domains = "GET" $ req & addJSONObject ["domains" .= domainList] -legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response -legalholdWhitelistTeam uid tid = do +legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response +legalholdWhitelistTeam tid uid = do tidStr <- asString tid req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] submit "PUT" req -legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response -legalholdIsTeamInWhitelist uid tid = do +legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response +legalholdIsTeamInWhitelist tid uid = do tidStr <- asString tid req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] submit "GET" req diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 32dcb12f794..16ea06bf8b1 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wwarn #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2023 Wire Swiss GmbH @@ -23,7 +25,9 @@ import qualified API.BrigInternal as BrigI import API.Common import API.Galley import API.GalleyInternal +import Control.Error (MaybeT (MaybeT), runMaybeT) import Control.Lens ((.~), (^?!)) +import Control.Monad.Trans.Class (lift) import qualified Data.Map as Map import qualified Data.ProtoLens as Proto import Data.ProtoLens.Labels () @@ -37,6 +41,7 @@ import SetupHelpers import Testlib.MockIntegrationService import Testlib.Prekeys import Testlib.Prelude +import UnliftIO (Chan, readChan, timeout) testLHPreventAddingNonConsentingUsers :: App () testLHPreventAddingNonConsentingUsers = do @@ -44,9 +49,9 @@ testLHPreventAddingNonConsentingUsers = do withMockServer lhMockApp $ \lhPort _chan -> do (owner, tid, [alice, alex]) <- createTeam dom 3 - void $ legalholdWhitelistTeam owner tid >>= assertSuccess - void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess - void $ postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= getJSON 201 + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= assertStatus 201 george <- randomUser dom def georgeQId <- george %. "qualified_id" @@ -69,13 +74,11 @@ testLHPreventAddingNonConsentingUsers = do checkConvHasOtherMembers conv alice [alex] -- it should not be possible neither for alex nor for alice to add the guest back - bindResponse (addMembers alex conv def {users = [georgeQId]}) $ \resp -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "not-connected" + addMembers alex conv def {users = [georgeQId]} + >>= assertLabel 403 "not-connected" - bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \resp -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "missing-legalhold-consent" + addMembers alice conv def {users = [georgeQId]} + >>= assertLabel 403 "missing-legalhold-consent" where checkConvHasOtherMembers :: HasCallStack => Value -> Value -> [Value] -> App () checkConvHasOtherMembers conv u us = @@ -106,9 +109,9 @@ testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedB client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 - void $ legalholdWhitelistTeam owner tid >>= assertSuccess - void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess - void $ postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= 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 @@ -131,7 +134,7 @@ testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedB length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 - void $ do + do successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" let successfulMsg = Proto.defMessage @Proto.QualifiedNewOtrMessage @@ -202,9 +205,9 @@ testLHClaimKeys = WithBoundedEnumArg $ \testmode -> do (lowner, ltid, [lmem]) <- createTeam dom 2 (powner, ptid, [pmem]) <- createTeam dom 2 - legalholdWhitelistTeam lowner ltid >>= assertSuccess + legalholdWhitelistTeam ltid lowner >>= assertSuccess legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess - void $ postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhPort) >>= getJSON 201 + postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhPort) >>= assertStatus 201 requestLegalHoldDevice ltid lowner lmem >>= assertSuccess approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess @@ -221,8 +224,8 @@ testLHClaimKeys = WithBoundedEnumArg $ \testmode -> do addc $ Just ["legalhold-implicit-consent"] TCKConsentAndNewClients -> do addc $ Just ["legalhold-implicit-consent"] - void $ legalholdWhitelistTeam powner ptid >>= assertSuccess - void $ legalholdIsTeamInWhitelist powner ptid >>= assertSuccess + legalholdWhitelistTeam ptid powner >>= assertSuccess + legalholdIsTeamInWhitelist ptid powner >>= assertSuccess llhdev :: String <- do let getCls :: Value -> App [String] @@ -255,8 +258,7 @@ testLHAddClientManually :: App () testLHAddClientManually = do (_owner, _tid, [mem1]) <- createTeam OwnDomain 2 bindResponse (addClient mem1 def {ctype = "legalhold"}) $ \resp -> do - resp.status `shouldMatchInt` 400 - resp.json %. "label" `shouldMatch` "client-error" + assertLabel 400 "client-error" resp -- we usually don't test the human-readable "message", but in this case it is important to -- make sure the reason is the right one, and not eg. "LH service not present", or some -- other unspecific client error. @@ -281,13 +283,12 @@ testLHRequestDevice = startDynamicBackends [mempty] $ \[dom] -> do (alice, tid, [bob]) <- createTeam dom 2 let reqNotEnabled requester requestee = - requestLegalHoldDevice tid requester requestee `bindResponse` \resp -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "legalhold-not-enabled" + requestLegalHoldDevice tid requester requestee + >>= assertLabel 403 "legalhold-not-enabled" reqNotEnabled alice bob - withMockServer lhMockApp $ \lhPort _chan -> do + withMockServer lhMockApp \lhPort _chan -> do let statusShouldbe :: String -> App () statusShouldbe status = legalholdUserStatus tid alice bob `bindResponse` \resp -> do @@ -299,7 +300,7 @@ testLHRequestDevice = reqNotEnabled requester bob statusShouldbe "no_consent" - legalholdWhitelistTeam alice tid >>= assertSuccess + legalholdWhitelistTeam tid alice >>= assertSuccess postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) >>= assertSuccess statusShouldbe "disabled" @@ -318,5 +319,56 @@ testLHRequestDevice = bobc <- objId $ addClient bob def `bindResponse` getJSON 201 for_ [(alice, alicec), (bob, bobc)] \(user, client) -> awaitNotification user client noValue isUserActivateNotif >>= \notif -> do - printJSON notif notif %. "payload.0.user.managed_by" `shouldMatch` "wire" + +checkChan :: HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a +checkChan chan match = + maybe (assertFailure "checkChan: timed out") pure =<< timeout 5_000_000 do + let go = readChan chan >>= match >>= maybe go pure + go + +testLHApproveDevice :: App () +testLHApproveDevice = do + startDynamicBackends [mempty] \[dom] -> do + -- team users + -- alice (boss) and bob and charlie (member) + (alice, tid, [bob, charlie]) <- createTeam dom 3 + + -- ollie the outsider + ollie <- do + o <- randomUser dom def + connectTwoUsers o alice + pure o + + -- sandy the stranger + sandy <- randomUser dom def + + legalholdWhitelistTeam tid alice >>= assertStatus 200 + -- TODO(mangoiv): it seems like correct behaviour to throw a 412 + -- here, as we can only approve a device if we're in the pending + -- state. however, the old tests passed with a 403 which makes + -- this suspicious. + approveLegalHoldDevice tid (bob %. "qualified_id") defPassword + >>= assertLabel 412 "legalhold-not-pending" + + withMockServer lhMockApp \lhPort chan -> do + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) + >>= assertStatus 201 + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 + + let match bs = runMaybeT do + val <- MaybeT $ pure $ decode @Value bs + actual_tid <- MaybeT $ lookupField val "team_id" + actual_uid <- MaybeT $ lookupField val "user_id" + tidS <- lift $ asString actual_tid + uidS <- lift $ asString actual_uid + bobUid <- lift $ objId bob + + case (tidS, uidS) `compare` (tid, bobUid) of + EQ -> pure () + _ -> MaybeT $ pure Nothing + + checkChan chan (match . snd) diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 721700df3e2..34bd07b5fba 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -90,18 +90,29 @@ withResponse r k = onFailureAddResponse r (k r) -- | Check response status code, then return body. getBody :: HasCallStack => Int -> Response -> App ByteString -getBody status resp = withResponse resp $ \r -> do - r.status `shouldMatch` status - pure r.body +getBody status = flip withResponse \resp -> do + resp.status `shouldMatch` status + pure resp.body -- | Check response status code, then return JSON body. getJSON :: HasCallStack => Int -> Response -> App Aeson.Value -getJSON status resp = withResponse resp $ \r -> do - r.status `shouldMatch` status - r.json +getJSON status = flip withResponse \resp -> do + resp.status `shouldMatch` status + resp.json +-- | assert a response code in the 2** range assertSuccess :: HasCallStack => Response -> App () -assertSuccess resp = withResponse resp $ \r -> r.status `shouldMatchRange` (200, 299) +assertSuccess = flip withResponse \resp -> resp.status `shouldMatchRange` (200, 299) + +-- | assert a response status code +assertStatus :: HasCallStack => Int -> Response -> App () +assertStatus status = flip withResponse \resp -> resp.status `shouldMatchInt` status + +-- | assert a failure with some failure code and label +assertLabel :: HasCallStack => Int -> String -> Response -> App () +assertLabel status label resp = do + j <- getJSON status resp + j %. "label" `shouldMatch` label onFailureAddResponse :: HasCallStack => Response -> App a -> App a onFailureAddResponse r m = App $ do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 5065c555be0..0ce7170c19e 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -49,7 +49,6 @@ import Data.Time.Clock qualified as Time import Data.Timeout import Galley.Cassandra.Client (lookupClients) import Galley.Cassandra.LegalHold -import Galley.Cassandra.LegalHold qualified as LegalHoldData import Galley.Env qualified as Galley import Galley.Options (featureFlags, settings) import Galley.Types.Clients qualified as Clients @@ -217,6 +216,7 @@ testApproveLegalHoldDevice = do liftIO . assertMatchJSON chan $ \(RequestNewLegalHoldClient userId' teamId') -> do assertEqual "userId == member" userId' member assertEqual "teamId == tid" teamId' tid + -- we're here -- Only the user themself can approve adding a LH device approveLegalHoldDevice (Just defPassword) owner member tid !!! testResponse 403 (Just "access-denied") -- Requires password From 6fc66a108d47f941082902b6b6bb799c816cfe55 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 12 Feb 2024 18:21:15 +0100 Subject: [PATCH 04/21] [feat] test no. 2 and some fixes on test no. 1 --- integration/test/API/Brig.hs | 6 + integration/test/API/Galley.hs | 10 +- integration/test/MLS/Util.hs | 8 +- integration/test/Notifications.hs | 27 +++-- integration/test/Test/LegalHold.hs | 113 ++++++++++++++---- .../test/Testlib/MockIntegrationService.hs | 51 +++++--- libs/brig-types/src/Brig/Types/User/Event.hs | 5 +- .../test/integration/API/Teams/LegalHold.hs | 72 ----------- 8 files changed, 160 insertions(+), 132 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index a78cbdd7800..4c91304bd33 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -629,3 +629,9 @@ getMultiUserPrekeyBundle :: (HasCallStack, MakesValue caller, ToJSON userClients getMultiUserPrekeyBundle caller userClients = do req <- baseRequest caller Brig Versioned $ joinHttpPath ["users", "list-prekeys"] submit "POST" (addJSON userClients req) + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_access +renewToken :: (HasCallStack, MakesValue uid) => uid -> String -> App Response +renewToken caller cookie = do + req <- baseRequest caller Brig Versioned "access" + submit "POST" (addHeader "Cookie" ("zuid=" <> cookie) req) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 284a2196e54..21d1d0ae379 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -616,10 +616,16 @@ requestLegalHoldDevice tid ownerid uid = do submit "POST" req -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve +-- +-- like approveLegalHoldDevice' but approves for the requesting party approveLegalHoldDevice :: (HasCallStack, MakesValue tid, MakesValue uid) => tid -> uid -> String -> App Response -approveLegalHoldDevice tid uid pwd = do +approveLegalHoldDevice tid uid = approveLegalHoldDevice' tid uid uid + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve +approveLegalHoldDevice' :: (HasCallStack, MakesValue tid, MakesValue uid, MakesValue forUid) => tid -> uid -> forUid -> String -> App Response +approveLegalHoldDevice' tid uid forUid pwd = do tidStr <- asString tid - uidStr <- asString $ uid %. "id" + uidStr <- asString $ forUid %. "id" req <- baseRequest uid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr, "approve"]) submit "PUT" (addJSONObject ["password" .= pwd] req) diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index 2f42556489a..f1dd2492a1d 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -3,7 +3,6 @@ module MLS.Util where import API.Brig -import qualified API.BrigCommon as BrigC import API.Galley import Control.Concurrent.Async hiding (link) import Control.Monad @@ -37,7 +36,6 @@ import System.IO hiding (print, putStrLn) import System.IO.Temp import System.Posix.Files import System.Process -import Testlib.App import Testlib.Assertions import Testlib.HTTP import Testlib.JSON @@ -127,9 +125,9 @@ argSubst from to_ s = createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity createWireClient u = do - lpk <- getLastPrekey - c <- addClient u def {BrigC.lastPrekey = Just lpk} >>= getJSON 201 - mkClientIdentity u c + addClient u def + >>= getJSON 201 + >>= mkClientIdentity u data CredentialType = BasicCredentialType | X509CredentialType diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 885cbefaaff..b19e829ea44 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -24,12 +24,11 @@ awaitNotifications user client since0 n selector = do go 0 _ res = pure res go timeRemaining since res0 = do c <- make client & asString - notifs <- bindResponse - ( getNotifications - user - def {since = since, client = Just c} - ) - $ \resp -> asList (resp.json %. "notifications") + notifs <- + getNotifications + user + def {since = since, client = Just c} + `bindResponse` \resp -> asList (resp.json %. "notifications") lastNotifId <- case notifs of [] -> pure since _ -> Just <$> objId (last notifs) @@ -110,11 +109,23 @@ isConvCreateNotif n = fieldEquals n "payload.0.type" "conversation.create" isConvDeleteNotif :: MakesValue a => a -> App Bool isConvDeleteNotif n = fieldEquals n "payload.0.type" "conversation.delete" +notifTypeIsEqual :: MakesValue a => String -> a -> App Bool +notifTypeIsEqual typ n = nPayload n %. "type" `isEqual` typ + isTeamMemberLeaveNotif :: MakesValue a => a -> App Bool -isTeamMemberLeaveNotif n = nPayload n %. "type" `isEqual` "team.member-leave" +isTeamMemberLeaveNotif = notifTypeIsEqual "team.member-leave" isUserActivateNotif :: MakesValue a => a -> App Bool -isUserActivateNotif n = nPayload n %. "type" `isEqual` "user.activate" +isUserActivateNotif = notifTypeIsEqual "user.activate" + +isUserClientAddNotif :: MakesValue a => a -> App Bool +isUserClientAddNotif = notifTypeIsEqual "user.client-add" + +isUserLegalholdRequestNotif :: MakesValue a => a -> App Bool +isUserLegalholdRequestNotif = notifTypeIsEqual "user.legalhold-request" + +isUserLegalholdEnabledNotif :: MakesValue a => a -> App Bool +isUserLegalholdEnabledNotif = notifTypeIsEqual "user.legalhold-enable" assertLeaveNotification :: ( HasCallStack, diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 16ea06bf8b1..8a2507810b0 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -20,7 +20,7 @@ module Test.LegalHold where import API.Brig -import API.BrigCommon +import API.BrigCommon as BrigC import qualified API.BrigInternal as BrigI import API.Common import API.Galley @@ -28,12 +28,13 @@ import API.GalleyInternal import Control.Error (MaybeT (MaybeT), runMaybeT) import Control.Lens ((.~), (^?!)) import Control.Monad.Trans.Class (lift) +import Data.ByteString.Lazy (LazyByteString) import qualified Data.Map as Map import qualified Data.ProtoLens as Proto import Data.ProtoLens.Labels () import qualified Data.Set as Set import GHC.Stack -import Notifications (awaitNotification, isUserActivateNotif) +import Notifications (awaitNotification, isUserClientAddNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -288,7 +289,10 @@ testLHRequestDevice = reqNotEnabled alice bob - withMockServer lhMockApp \lhPort _chan -> do + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer (lhMockApp' $ Just (lpk, pks)) \lhPort _chan -> do let statusShouldbe :: String -> App () statusShouldbe status = legalholdUserStatus tid alice bob `bindResponse` \resp -> do @@ -305,28 +309,38 @@ testLHRequestDevice = statusShouldbe "disabled" - requestLegalHoldDevice tid alice bob >>= assertSuccess + requestLegalHoldDevice tid alice bob >>= assertStatus 201 statusShouldbe "pending" + -- FIXME(mangoiv): we send two notifications to the client + -- which I'm pretty sure is not correct + -- requesting twice should be idempotent wrt the approval - requestLegalHoldDevice tid alice bob `bindResponse` \resp -> - resp.status `shouldMatchInt` 204 + requestLegalHoldDevice tid alice bob >>= assertStatus 204 statusShouldbe "pending" -- TODO(mangoiv): test if prekeys are in cassandra? - alicec <- objId $ addClient alice def `bindResponse` getJSON 201 - bobc <- objId $ addClient bob def `bindResponse` getJSON 201 - for_ [(alice, alicec), (bob, bobc)] \(user, client) -> - awaitNotification user client noValue isUserActivateNotif >>= \notif -> do - notif %. "payload.0.user.managed_by" `shouldMatch` "wire" + [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 checkChan :: HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a checkChan chan match = maybe (assertFailure "checkChan: timed out") pure =<< timeout 5_000_000 do let go = readChan chan >>= match >>= maybe go pure go +-- | like 'checkChan' but throws away the request and decodes the body +checkChanVal :: HasCallStack => Chan (t, LazyByteString) -> (Value -> MaybeT App a) -> App a +checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do + MaybeT (pure (decode bs)) >>= match + testLHApproveDevice :: App () testLHApproveDevice = do startDynamicBackends [mempty] \[dom] -> do @@ -335,13 +349,15 @@ testLHApproveDevice = do (alice, tid, [bob, charlie]) <- createTeam dom 3 -- ollie the outsider - ollie <- do - o <- randomUser dom def - connectTwoUsers o alice - pure o + -- ollie <- do + -- o <- randomUser dom def + -- connectTwoUsers o alice + -- pure o -- sandy the stranger - sandy <- randomUser dom def + -- sandy <- randomUser dom def + -- + -- for sandy and ollie see below legalholdWhitelistTeam tid alice >>= assertStatus 200 -- TODO(mangoiv): it seems like correct behaviour to throw a 412 @@ -359,16 +375,61 @@ testLHApproveDevice = do requestLegalHoldDevice tid alice bob >>= assertStatus 201 - let match bs = runMaybeT do - val <- MaybeT $ pure $ decode @Value bs - actual_tid <- MaybeT $ lookupField val "team_id" - actual_uid <- MaybeT $ lookupField val "user_id" - tidS <- lift $ asString actual_tid - uidS <- lift $ asString actual_uid + let uidsAndTidMatch val = do + actualTid <- + MaybeT (lookupField val "team_id") + >>= lift . asString + actualUid <- + MaybeT (lookupField val "user_id") + >>= lift . asString bobUid <- lift $ objId bob - case (tidS, uidS) `compare` (tid, bobUid) of - EQ -> pure () - _ -> MaybeT $ pure Nothing + -- 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 = + MaybeT (val `lookupField` "refresh_token") + >>= lift . asString - checkChan chan (match . snd) + checkChanVal chan matchAuthToken + >>= renewToken bob + >>= assertStatus 200 + + -- TODO(mangoiv): more CQL checks? + -- also look at whether it makes sense to check the client id of the + -- legalhold device... + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + 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 + printJSON =<< objId bob + + awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do + notif %. "payload.0.id" `shouldMatch` objId bob + +-- TODO(mangoiv): there's no reasonable check that sandy and ollie don't get any notifs +-- as we never know when to timeout as we don't have any consistency guarantees diff --git a/integration/test/Testlib/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs index 4d7c64a5150..49f0a417ae4 100644 --- a/integration/test/Testlib/MockIntegrationService.hs +++ b/integration/test/Testlib/MockIntegrationService.hs @@ -1,4 +1,4 @@ -module Testlib.MockIntegrationService (withMockServer, lhMockApp, mkLegalHoldSettings) where +module Testlib.MockIntegrationService (withMockServer, lhMockApp', lhMockApp, mkLegalHoldSettings) where import Control.Monad.Catch import Control.Monad.Reader @@ -13,8 +13,8 @@ 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.Prekeys import Testlib.Prelude +import UnliftIO (MonadUnliftIO (withRunInIO)) import UnliftIO.Async import UnliftIO.Chan import UnliftIO.MVar @@ -95,10 +95,12 @@ withFreePortAnyAddr = bracket openFreePortAnyAddr (liftIO . Socket.close . snd) openFreePortAnyAddr :: MonadIO m => m (Warp.Port, Socket) openFreePortAnyAddr = liftIO $ bindRandomPortTCP (fromString "*") +type LiftedApplication = Request -> (Wai.Response -> App ResponseReceived) -> App ResponseReceived + withMockServer :: - HasCallStack => + (HasCallStack) => -- | the mock server - (Chan e -> Application) -> + (Chan e -> LiftedApplication) -> -- | the test (Warp.Port -> Chan e -> App a) -> App a @@ -107,30 +109,43 @@ withMockServer mkApp go = withFreePortAnyAddr $ \(sPort, sock) -> do let tlss = Warp.tlsSettingsMemory (cs mockServerCert) (cs mockServerPrivKey) let defs = Warp.defaultSettings {Warp.settingsPort = sPort, Warp.settingsBeforeMainLoop = putMVar serverStarted ()} buf <- newChan - srv <- async . liftIO . Warp.runTLSSocket tlss defs sock $ mkApp buf + srv <- async $ withRunInIO \inIO -> do + Warp.runTLSSocket tlss defs sock \req respond -> 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 Nothing -> error . show =<< poll srv +lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> LiftedApplication +lhMockApp = lhMockApp' Nothing + -- | LegalHold service. Just fake the API, do not maintain any internal state. -lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> Wai.Application -lhMockApp ch req cont = do +lhMockApp' :: Maybe (Value, [Value]) -> Chan (Wai.Request, LBS.ByteString) -> LiftedApplication +lhMockApp' mks ch req cont = withRunInIO \inIO -> do reqBody <- Wai.strictRequestBody req writeChan ch (req, reqBody) - case (cs <$> pathInfo req, cs $ requestMethod req, cs @_ @String <$> getRequestHeader "Authorization" req) of - (["legalhold", "status"], "GET", _) -> cont respondOk - (_, _, Nothing) -> cont missingAuth - (["legalhold", "initiate"], "POST", Just _) -> cont initiateResp - (["legalhold", "confirm"], "POST", Just _) -> cont respondOk - (["legalhold", "remove"], "POST", Just _) -> cont respondOk - _ -> cont respondBad + inIO do + (nextLastPrekey, threePrekeys) <- + case mks of + Nothing -> + (,) + <$> getLastPrekey + <*> replicateM 3 getPrekey + Just pks -> pure pks + case (cs <$> pathInfo req, cs $ requestMethod req, cs @_ @String <$> getRequestHeader "Authorization" req) of + (["legalhold", "status"], "GET", _) -> cont respondOk + (_, _, Nothing) -> cont missingAuth + (["legalhold", "initiate"], "POST", Just _) -> cont (initiateResp nextLastPrekey threePrekeys) + (["legalhold", "confirm"], "POST", Just _) -> cont respondOk + (["legalhold", "remove"], "POST", Just _) -> cont respondOk + _ -> cont respondBad where - initiateResp :: Wai.Response - initiateResp = + initiateResp :: Value -> [Value] -> Wai.Response + initiateResp npk pks = responseLBS status200 [(hContentType, cs "application/json")] . encode . Data.Aeson.object $ - [ "prekeys" .= drop 3 somePrekeysRendered, - "last_prekey" .= (someLastPrekeysRendered !! 2) + [ "prekeys" .= pks, + "last_prekey" .= npk ] respondOk :: Wai.Response diff --git a/libs/brig-types/src/Brig/Types/User/Event.hs b/libs/brig-types/src/Brig/Types/User/Event.hs index 19bfc56315e..96aed364a76 100644 --- a/libs/brig-types/src/Brig/Types/User/Event.hs +++ b/libs/brig-types/src/Brig/Types/User/Event.hs @@ -102,8 +102,11 @@ data UserIdentityRemovedData = UserIdentityRemovedData deriving stock (Show) data LegalHoldClientRequestedData = LegalHoldClientRequestedData - { lhcTargetUser :: !UserId, + { -- | the user that is under legalhold + lhcTargetUser :: !UserId, + -- | the last prekey of the user that is under legalhold lhcLastPrekey :: !LastPrekey, + -- | the client id of the legalhold device lhcClientId :: !ClientId } deriving stock (Show) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 0ce7170c19e..c9b389c7d76 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -32,14 +32,12 @@ import Bilge.Assert import Brig.Types.Intra (UserSet (..)) import Brig.Types.Test.Arbitrary () import Brig.Types.User.Event qualified as Ev -import Cassandra.Exec qualified as Cql import Control.Category ((>>>)) import Control.Concurrent.Chan import Control.Lens hiding ((#)) import Data.Id import Data.LegalHold import Data.List.NonEmpty (NonEmpty (..)) -import Data.List1 qualified as List1 import Data.Map.Strict qualified as Map import Data.PEM import Data.Qualified (Qualified (..)) @@ -47,11 +45,9 @@ import Data.Range import Data.Set qualified as Set import Data.Time.Clock qualified as Time import Data.Timeout -import Galley.Cassandra.Client (lookupClients) import Galley.Cassandra.LegalHold import Galley.Env qualified as Galley import Galley.Options (featureFlags, settings) -import Galley.Types.Clients qualified as Clients import Galley.Types.Teams import Imports import Network.HTTP.Types.Status (status200, status404) @@ -72,7 +68,6 @@ import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Feature qualified as Public import Wire.API.Team.LegalHold -import Wire.API.Team.LegalHold.External import Wire.API.Team.Member import Wire.API.Team.Member qualified as Team import Wire.API.Team.Permission @@ -103,7 +98,6 @@ testsPublic s = testGroup "Teams LegalHold API (with flag whitelist-teams-and-implicit-consent)" [ -- device handling (CRUD) - testOnlyIfLhWhitelisted s "PUT /teams/{tid}/legalhold/approve" testApproveLegalHoldDevice, test s "(user denies approval: nothing needs to be done in backend)" (pure ()), testOnlyIfLhWhitelisted s "GET /teams/{tid}/legalhold/{uid}" testGetLegalHoldDeviceStatus, testOnlyIfLhWhitelisted s "DELETE /teams/{tid}/legalhold/{uid}" testDisableLegalHoldForUser, @@ -190,72 +184,6 @@ testWhitelistingTeams = do expectWhitelisted False tid -testApproveLegalHoldDevice :: TestM () -testApproveLegalHoldDevice = do - (owner, tid) <- createBindingTeam - member <- do - usr <- randomUser - addTeamMemberInternal tid usr (rolePermissions RoleMember) Nothing - pure usr - member2 <- do - usr <- randomUser - addTeamMemberInternal tid usr (rolePermissions RoleMember) Nothing - pure usr - outsideContact <- do - usr <- randomUser - connectUsers member (List1.singleton usr) - pure usr - stranger <- randomUser - putLHWhitelistTeam tid !!! const 200 === statusCode - approveLegalHoldDevice (Just defPassword) owner member tid - !!! testResponse 403 (Just "access-denied") - cannon <- view tsCannon - WS.bracketRN cannon [owner, member, member, member2, outsideContact, stranger] $ - \[ows, mws, mws', member2Ws, outsideContactWs, strangerWs] -> withDummyTestServiceForTeam owner tid $ \chan -> do - requestLegalHoldDevice owner member tid !!! testResponse 201 Nothing - liftIO . assertMatchJSON chan $ \(RequestNewLegalHoldClient userId' teamId') -> do - assertEqual "userId == member" userId' member - assertEqual "teamId == tid" teamId' tid - -- we're here - -- Only the user themself can approve adding a LH device - approveLegalHoldDevice (Just defPassword) owner member tid !!! testResponse 403 (Just "access-denied") - -- Requires password - approveLegalHoldDevice Nothing member member tid !!! const 403 === statusCode - approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing - -- checks if the cookie we give to the legalhold service is actually valid - assertMatchJSON chan $ \(LegalHoldServiceConfirm _clientId _uid _tid authToken) -> - renewToken authToken - cassState <- view tsCass - liftIO $ do - clients' <- Cql.runClient cassState $ lookupClients [member] - assertBool "Expect clientId to be saved on the user" $ - Clients.contains member someClientId clients' - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "After approval user legalhold status should be Enabled" - UserLegalHoldEnabled - userStatus - let pluck = \case - Ev.ClientAdded _ eClient -> do - clientId eClient @?= someClientId - clientType eClient @?= LegalHoldClientType - clientClass eClient @?= Just LegalHoldClient - _ -> assertBool "Unexpected event" False - assertNotification mws pluck - assertNotification mws' pluck - -- Other team users should get a user.legalhold-enable event - let pluck' = \case - Ev.UserLegalHoldEnabled eUser -> eUser @?= member - _ -> assertBool "Unexpected event" False - assertNotification ows pluck' - -- We send to all members of a team. which includes the team-settings - assertNotification member2Ws pluck' - when False $ do - -- this doesn't work any more since consent (personal users cannot grant consent). - assertNotification outsideContactWs pluck' - assertNoNotification strangerWs - testGetLegalHoldDeviceStatus :: TestM () testGetLegalHoldDeviceStatus = do (owner, tid) <- createBindingTeam From c3c52c8e28b05706c76f2e47de077dff293c6756 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 13 Feb 2024 12:38:13 +0100 Subject: [PATCH 05/21] [feat] port over test number 3 --- integration/test/Test/LegalHold.hs | 58 +++++++++++++++++-- integration/test/Testlib/Types.hs | 3 + .../test/integration/API/Teams/LegalHold.hs | 55 ------------------ 3 files changed, 57 insertions(+), 59 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 8a2507810b0..6bdb0ea4886 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -27,6 +27,7 @@ import API.Galley import API.GalleyInternal import Control.Error (MaybeT (MaybeT), runMaybeT) import Control.Lens ((.~), (^?!)) +import Control.Monad.Reader (asks) import Control.Monad.Trans.Class (lift) import Data.ByteString.Lazy (LazyByteString) import qualified Data.Map as Map @@ -331,8 +332,10 @@ testLHRequestDevice = -- | pops a channel until it finds an event that returns a 'Just' -- upon running the matcher function checkChan :: HasCallStack => Chan t -> (t -> App (Maybe a)) -> App a -checkChan chan match = - maybe (assertFailure "checkChan: timed out") pure =<< timeout 5_000_000 do +checkChan chan match = do + tSecs <- asks ((* 1_000_000) . timeOutSeconds) + + maybe (assertFailure "checkChan: timed out") pure =<< timeout tSecs do let go = readChan chan >>= match >>= maybe go pure go @@ -426,10 +429,57 @@ testLHApproveDevice = do -- legalhold device being approved in their team for_ [alice, charlie] \user -> do client <- objId $ addClient user def `bindResponse` getJSON 201 - printJSON =<< objId bob - awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do notif %. "payload.0.id" `shouldMatch` objId bob -- TODO(mangoiv): there's no reasonable check that sandy and ollie don't get any notifs -- as we never know when to timeout as we don't have any consistency guarantees + +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" + + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + let lookupM field jason = MaybeT (lookupField jason field) + + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer (lhMockApp' (Just (lpk, pks))) \lhPort _chan -> do + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "disabled" + lookupField resp.json "last_prekey" + >>= assertNothing + runMaybeT (lookupM "client" resp.json >>= lookupM "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 + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + resp.json %. "last_prekey" `shouldMatch` lpk + -- TODO(mangoiv): where do we take the LH device client + -- id from?? + -- resp.json %. "client.id" `shouldMatch` _ + + requestLegalHoldDevice tid alice bob + >>= assertLabel 409 "legalhold-already-enabled" diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index 025ef39ba76..2a8c63f169e 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -359,6 +359,9 @@ assertJust :: HasCallStack => String -> Maybe a -> App a assertJust _ (Just x) = pure x assertJust msg Nothing = assertFailure msg +assertNothing :: (HasCallStack) => Maybe a -> App () +assertNothing = maybe (pure ()) $ const $ assertFailure "Maybe value was Just, not Nothing" + addFailureContext :: String -> App a -> App a addFailureContext msg = modifyFailureMsg (\m -> m <> "\nThis failure happened in this context:\n" <> msg) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index c9b389c7d76..34d550c5954 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -98,8 +98,6 @@ testsPublic s = testGroup "Teams LegalHold API (with flag whitelist-teams-and-implicit-consent)" [ -- device handling (CRUD) - test s "(user denies approval: nothing needs to be done in backend)" (pure ()), - testOnlyIfLhWhitelisted s "GET /teams/{tid}/legalhold/{uid}" testGetLegalHoldDeviceStatus, testOnlyIfLhWhitelisted s "DELETE /teams/{tid}/legalhold/{uid}" testDisableLegalHoldForUser, -- legal hold settings testOnlyIfLhWhitelisted s "POST /teams/{tid}/legalhold/settings" testCreateLegalHoldTeamSettings, @@ -184,59 +182,6 @@ testWhitelistingTeams = do expectWhitelisted False tid -testGetLegalHoldDeviceStatus :: TestM () -testGetLegalHoldDeviceStatus = do - (owner, tid) <- createBindingTeam - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - forM_ [owner, member] $ \uid -> do - status <- getUserStatusTyped uid tid - liftIO $ - assertEqual - "unexpected status" - (UserLegalHoldStatusResponse UserLegalHoldNoConsent Nothing Nothing) - status - - putLHWhitelistTeam tid !!! const 200 === statusCode - withDummyTestServiceForTeamNoService $ \lhPort _chan -> do - do - UserLegalHoldStatusResponse userStatus lastPrekey' clientId' <- getUserStatusTyped member tid - liftIO $ - do - assertEqual "User legal hold status should start as disabled" UserLegalHoldDisabled userStatus - assertEqual "last_prekey should be Nothing when LH is disabled" Nothing lastPrekey' - assertEqual "client.id should be Nothing when LH is disabled" Nothing clientId' - - do - newService <- newLegalHoldService lhPort - postSettings owner tid newService !!! testResponse 201 Nothing - requestLegalHoldDevice owner member tid !!! testResponse 201 Nothing - assertZeroLegalHoldDevices member - UserLegalHoldStatusResponse userStatus lastPrekey' clientId' <- getUserStatusTyped member tid - liftIO $ - do - assertEqual "requestLegalHoldDevice should set user status to Pending" UserLegalHoldPending 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' - do - requestLegalHoldDevice owner member tid !!! testResponse 204 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid - liftIO $ - assertEqual - "requestLegalHoldDevice when already pending should leave status as Pending" - UserLegalHoldPending - userStatus - do - approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus lastPrekey' clientId' <- getUserStatusTyped 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' - assertExactlyOneLegalHoldDevice member - requestLegalHoldDevice owner member tid !!! testResponse 409 (Just "legalhold-already-enabled") - testDisableLegalHoldForUser :: TestM () testDisableLegalHoldForUser = withTeam $ \owner tid -> do member <- randomUser From 6ffcac68accc899fe4ec53529b3e130cd05b4213 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 13 Feb 2024 14:40:25 +0100 Subject: [PATCH 06/21] [feat] test number 4 --- integration/test/API/Galley.hs | 30 ++++++++--- integration/test/Notifications.hs | 6 +++ integration/test/Test/LegalHold.hs | 54 ++++++++++++++++++- .../test/integration/API/Teams/LegalHold.hs | 46 +--------------- 4 files changed, 84 insertions(+), 52 deletions(-) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 21d1d0ae379..a1b0b20a139 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -593,16 +593,32 @@ enableLegalHold tid ownerid = do req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) submit "PUT" (addJSONObject ["status" .= "enabled", "ttl" .= "unlimited"] req) +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/delete_teams__tid__legalhold__uid_ +disableLegalHold :: + (HasCallStack, MakesValue tid, MakesValue ownerid, MakesValue uid) => + tid -> + ownerid -> + uid -> + -- | the password for user with $uid$ + String -> + App Response +disableLegalHold tid ownerid uid pw = do + tidStr <- asString tid + uidStr <- objId uid + req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) + submit "DELETE" (addJSONObject ["password" .= pw] req) + -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings postLegalHoldSettings :: (HasCallStack, MakesValue ownerid, MakesValue tid, MakesValue newService) => tid -> ownerid -> newService -> App Response -postLegalHoldSettings tid owner newSettings = retrying policy only412 $ \_ -> do - tidStr <- asString tid - req <- baseRequest owner Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "settings"]) - newSettingsObj <- make newSettings - submit "POST" (addJSON newSettingsObj req) +postLegalHoldSettings tid owner newSettings = + asks ((* 1_000_000) . timeOutSeconds) >>= \tSecs -> retrying (policy tSecs) only412 $ \_ -> do + tidStr <- asString tid + req <- baseRequest owner Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "settings"]) + newSettingsObj <- make newSettings + submit "POST" (addJSON newSettingsObj req) where - policy :: RetryPolicy - policy = limitRetriesByCumulativeDelay 5_000_000 $ exponentialBackoff 50 + policy :: Int -> RetryPolicy + policy tSecs = limitRetriesByCumulativeDelay tSecs $ exponentialBackoff 50 only412 :: RetryStatus -> Response -> App Bool only412 _ resp = pure $ resp.status == 412 diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index b19e829ea44..c3350982aba 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -121,12 +121,18 @@ isUserActivateNotif = notifTypeIsEqual "user.activate" isUserClientAddNotif :: MakesValue a => a -> App Bool isUserClientAddNotif = notifTypeIsEqual "user.client-add" +isUserClientRemoveNotif :: MakesValue a => a -> App Bool +isUserClientRemoveNotif = notifTypeIsEqual "user.client-remove" + isUserLegalholdRequestNotif :: MakesValue a => a -> App Bool isUserLegalholdRequestNotif = notifTypeIsEqual "user.legalhold-request" isUserLegalholdEnabledNotif :: MakesValue a => a -> App Bool isUserLegalholdEnabledNotif = notifTypeIsEqual "user.legalhold-enable" +isUserLegalholdDisabledNotif :: MakesValue a => a -> App Bool +isUserLegalholdDisabledNotif = notifTypeIsEqual "user.legalhold-disable" + assertLeaveNotification :: ( HasCallStack, MakesValue fromUser, diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 6bdb0ea4886..bc17bbfd874 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -29,13 +29,16 @@ import Control.Error (MaybeT (MaybeT), runMaybeT) import Control.Lens ((.~), (^?!)) import Control.Monad.Reader (asks) import Control.Monad.Trans.Class (lift) +import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Lazy (LazyByteString) import qualified Data.Map as Map import qualified Data.ProtoLens as Proto import Data.ProtoLens.Labels () import qualified Data.Set as Set +import qualified Data.Text as T import GHC.Stack -import Notifications (awaitNotification, isUserClientAddNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) +import Network.Wai (Request (pathInfo, requestMethod)) +import Notifications (awaitNotification, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -483,3 +486,52 @@ testLHGetDeviceStatus = requestLegalHoldDevice tid alice bob >>= assertLabel 409 "legalhold-already-enabled" + +testLHDisableForUser :: App () +testLHDisableForUser = + startDynamicBackends [mempty] \[dom] -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam dom 2 + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + withMockServer lhMockApp \lhPort chan -> do + -- 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 + + 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" + + -- 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 defPassword + >>= assertStatus 200 + + checkChan chan \(req, _) -> runMaybeT do + unless + do + BS8.unpack req.requestMethod == "POST" + && req.pathInfo == (T.pack <$> ["legalhold", "remove"]) + mzero + + void do + awaitNotification bob bobc noValue isUserClientRemoveNotif + *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif + +-- TODO(mangoiv): assert zero legalhold devices diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 34d550c5954..6754e3c1877 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -20,10 +20,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module API.Teams.LegalHold - ( tests, - ) -where +module API.Teams.LegalHold (tests) where import API.Teams.LegalHold.Util import API.Util @@ -97,9 +94,7 @@ testsPublic s = -- See also Client Tests in Brig; where behaviour around deleting/adding LH clients is tested testGroup "Teams LegalHold API (with flag whitelist-teams-and-implicit-consent)" - [ -- device handling (CRUD) - testOnlyIfLhWhitelisted s "DELETE /teams/{tid}/legalhold/{uid}" testDisableLegalHoldForUser, - -- legal hold settings + [ -- legal hold settings testOnlyIfLhWhitelisted s "POST /teams/{tid}/legalhold/settings" testCreateLegalHoldTeamSettings, testOnlyIfLhWhitelisted s "GET /teams/{tid}/legalhold/settings" testGetLegalHoldTeamSettings, testOnlyIfLhWhitelisted s "Not implemented: DELETE /teams/{tid}/legalhold/settings" testRemoveLegalHoldFromTeam, @@ -182,43 +177,6 @@ testWhitelistingTeams = do expectWhitelisted False tid -testDisableLegalHoldForUser :: TestM () -testDisableLegalHoldForUser = withTeam $ \owner tid -> do - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - cannon <- view tsCannon - putLHWhitelistTeam tid !!! const 200 === statusCode - WS.bracketR2 cannon owner member $ \(ows, mws) -> withDummyTestServiceForTeam owner tid $ \chan -> do - requestLegalHoldDevice owner member tid !!! testResponse 201 Nothing - approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing - assertNotification mws $ \case - Ev.ClientAdded _ client -> do - clientId client @?= someClientId - clientType client @?= LegalHoldClientType - clientClass client @?= Just LegalHoldClient - _ -> assertBool "Unexpected event" False - -- Only the admin can disable legal hold - disableLegalHoldForUser (Just defPassword) tid member member !!! testResponse 403 (Just "operation-denied") - assertExactlyOneLegalHoldDevice member - -- Require password to disable for usern - disableLegalHoldForUser Nothing tid owner member !!! const 403 === statusCode - assertExactlyOneLegalHoldDevice member - disableLegalHoldForUser (Just defPassword) tid owner member !!! testResponse 200 Nothing - liftIO . assertMatchChan chan $ \(req, _) -> do - assertEqual "method" "POST" (requestMethod req) - assertEqual "path" (pathInfo req) ["legalhold", "remove"] - assertNotification mws $ \case - Ev.ClientEvent (Ev.ClientRemoved _ clientId') -> clientId' @?= someClientId - _ -> assertBool "Unexpected event" False - assertNotification mws $ \case - Ev.UserEvent (Ev.UserLegalHoldDisabled uid) -> uid @?= member - _ -> assertBool "Unexpected event" False - -- Other users should also get the event - assertNotification ows $ \case - Ev.UserLegalHoldDisabled uid -> uid @?= member - _ -> assertBool "Unexpected event" False - assertZeroLegalHoldDevices member - data IsWorking = Working | NotWorking deriving (Eq, Show) From 66a4242c20bb53dc0c99ca2f524e528e63d4cc5d Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 13 Feb 2024 15:57:56 +0100 Subject: [PATCH 07/21] [fix] don't depend on the order of notifications --- integration/test/Test/LegalHold.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index bc17bbfd874..ea7f5816433 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -38,7 +38,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import GHC.Stack import Network.Wai (Request (pathInfo, requestMethod)) -import Notifications (awaitNotification, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) +import Notifications (awaitNotification, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif, awaitNotifications) import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -531,7 +531,9 @@ testLHDisableForUser = mzero void do - awaitNotification bob bobc noValue isUserClientRemoveNotif - *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif + -- this is awkward, but it's because the order is not clear + notifs <- awaitNotifications bob bobc Nothing 2 \notif -> (||) <$> isUserClientRemoveNotif notif <*> isUserLegalholdDisabledNotif notif + assertBool "we have a client remove notif" . not . null =<< filterM isUserClientRemoveNotif notifs + assertBool "we have a legalhold disable notif" . not . null =<< filterM isUserLegalholdDisabledNotif notifs -- TODO(mangoiv): assert zero legalhold devices From 5e0e65731d4d9c503ffb33a5e1ce011aee4cee91 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 13 Feb 2024 17:47:18 +0100 Subject: [PATCH 08/21] [feat] test number 5 --- integration/test/API/GalleyInternal.hs | 6 ++ integration/test/Test/LegalHold.hs | 71 +++++++++++++++---- integration/test/Testlib/HTTP.hs | 2 + .../test/integration/API/Teams/LegalHold.hs | 30 -------- 4 files changed, 64 insertions(+), 45 deletions(-) diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 664c5e106b1..f2688c31062 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -70,3 +70,9 @@ legalholdIsTeamInWhitelist tid uid = do tidStr <- asString tid req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] submit "GET" req + +legalholdIsEnabled :: (HasCallStack, MakesValue tid, MakesValue uid) => tid -> uid -> App Response +legalholdIsEnabled tid uid = do + tidStr <- asString tid + baseRequest uid Galley Unversioned do joinHttpPath ["i", "teams", tidStr, "features", "legalhold"] + >>= submit "GET" diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index ea7f5816433..8d040432ef6 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -38,7 +38,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import GHC.Stack import Network.Wai (Request (pathInfo, requestMethod)) -import Notifications (awaitNotification, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif, awaitNotifications) +import Notifications (awaitNotification, awaitNotifications, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -347,6 +347,28 @@ checkChanVal :: HasCallStack => Chan (t, LazyByteString) -> (Value -> MaybeT App checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do MaybeT (pure (decode bs)) >>= match +setUpLHDevice :: + (HasCallStack, MakesValue tid, MakesValue owner, MakesValue uid) => + tid -> + owner -> + uid -> + -- | the port the LH service is running on + Int -> + App () +setUpLHDevice tid alice bob lhPort = do + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + -- 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 + testLHApproveDevice :: App () testLHApproveDevice = do startDynamicBackends [mempty] \[dom] -> do @@ -449,15 +471,15 @@ testLHGetDeviceStatus = resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "no_consent" - legalholdWhitelistTeam tid alice - >>= assertStatus 200 - let lookupM field jason = MaybeT (lookupField jason field) lpk <- getLastPrekey pks <- replicateM 3 getPrekey withMockServer (lhMockApp' (Just (lpk, 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" @@ -493,19 +515,9 @@ testLHDisableForUser = -- team users -- alice (team owner) and bob (member) (alice, tid, [bob]) <- createTeam dom 2 - legalholdWhitelistTeam tid alice - >>= assertStatus 200 withMockServer lhMockApp \lhPort chan -> do - -- 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 + setUpLHDevice tid alice bob lhPort bobc <- objId $ addClient bob def `bindResponse` getJSON 201 @@ -537,3 +549,32 @@ testLHDisableForUser = assertBool "we have a legalhold disable notif" . not . null =<< filterM isUserLegalholdDisabledNotif notifs -- TODO(mangoiv): assert zero legalhold devices + +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 + resp.status `shouldMatchInt` 200 + resp.json %. "lockStatus" `shouldMatch` "unlocked" + resp.json %. "status" `shouldMatch` "disabled" + + withMockServer lhMockApp \lhPort _chan -> do + setUpLHDevice tid alice bob lhPort + tidStr <- asString tid + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + + baseRequest alice Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) + >>= submit "PUT" + . addJSONObject ["status" .= "disabled", "ttl" .= "unlimited"] + `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" diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 34bd07b5fba..86311ca1c36 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -85,6 +85,8 @@ contentTypeMixed = addHeader "Content-Type" "multipart/mixed" bindResponse :: HasCallStack => App Response -> (Response -> App a) -> App a bindResponse m k = m >>= \r -> withResponse r k +infixl 1 `bindResponse` + withResponse :: HasCallStack => Response -> (Response -> App a) -> App a withResponse r k = onFailureAddResponse r (k r) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 6754e3c1877..3275c25787a 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -63,7 +63,6 @@ import Wire.API.Connection qualified as Conn import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) import Wire.API.Provider.Service import Wire.API.Routes.Internal.Brig.Connection -import Wire.API.Team.Feature qualified as Public import Wire.API.Team.LegalHold import Wire.API.Team.Member import Wire.API.Team.Member qualified as Team @@ -98,7 +97,6 @@ testsPublic s = testOnlyIfLhWhitelisted s "POST /teams/{tid}/legalhold/settings" testCreateLegalHoldTeamSettings, testOnlyIfLhWhitelisted s "GET /teams/{tid}/legalhold/settings" testGetLegalHoldTeamSettings, testOnlyIfLhWhitelisted s "Not implemented: DELETE /teams/{tid}/legalhold/settings" testRemoveLegalHoldFromTeam, - testOnlyIfLhWhitelisted s "GET [/i]?/teams/{tid}/legalhold" testEnablePerTeam, -- behavior of existing end-points testOnlyIfLhWhitelisted s "POST /clients" testCannotCreateLegalHoldDeviceOldAPI, testOnlyIfLhWhitelisted s "GET /teams/{tid}/members" testGetTeamMembersIncludesLHStatus, @@ -291,34 +289,6 @@ testRemoveLegalHoldFromTeam = do -- fails if LH for team is disabled deleteSettings (Just defPassword) owner tid !!! testResponse 403 (Just "legalhold-disable-unimplemented") -testEnablePerTeam :: TestM () -testEnablePerTeam = withTeam $ \owner tid -> do - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - do - status :: Public.WithStatusNoLock Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid do - putLHWhitelistTeam tid !!! const 200 === statusCode - requestLegalHoldDevice owner member tid !!! const 201 === statusCode - approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing - do - UserLegalHoldStatusResponse status _ _ <- getUserStatusTyped member tid - liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status - do - putEnabled' id tid Public.FeatureStatusDisabled !!! testResponse 403 (Just "legalhold-whitelisted-only") - status :: Public.WithStatusNoLock Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid TestM () testAddTeamUserTooLargeWithLegalholdWhitelisted = withTeam $ \owner tid -> do o <- view tsGConf From b24f80616de8b78bd938992272c7569f7103bc5b Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 14 Feb 2024 11:12:00 +0100 Subject: [PATCH 09/21] [feat] test number 6 --- integration/test/Test/LegalHold.hs | 42 +++++++++++++++++++ .../test/integration/API/Teams/LegalHold.hs | 34 --------------- 2 files changed, 42 insertions(+), 34 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 8d040432ef6..18ab2eb0b62 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -578,3 +578,45 @@ testLHEnablePerTeam = do 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 + + 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 \lhPort _chan -> do + statusShouldbe "no_consent" + + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + -- the status messages for these have already been tested + postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) + >>= assertStatus 201 + + -- legalhold has been requested but is disabled + statusShouldbe "disabled" + + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 + + -- legalhold has been set to pending after requesting device + statusShouldbe "pending" + + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 + + -- bob has accepted the legalhold device + statusShouldbe "enabled" diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 3275c25787a..98a4fd56fae 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -99,7 +99,6 @@ testsPublic s = testOnlyIfLhWhitelisted s "Not implemented: DELETE /teams/{tid}/legalhold/settings" testRemoveLegalHoldFromTeam, -- behavior of existing end-points testOnlyIfLhWhitelisted s "POST /clients" testCannotCreateLegalHoldDeviceOldAPI, - testOnlyIfLhWhitelisted s "GET /teams/{tid}/members" testGetTeamMembersIncludesLHStatus, 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: @@ -325,39 +324,6 @@ testCannotCreateLegalHoldDeviceOldAPI = do post req !!! const 400 === statusCode assertZeroLegalHoldDevices uid -testGetTeamMembersIncludesLHStatus :: TestM () -testGetTeamMembersIncludesLHStatus = do - (owner, tid) <- createBindingTeam - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - - let findMemberStatus :: [TeamMember] -> Maybe UserLegalHoldStatus - findMemberStatus ms = - ms ^? traversed . filtered (has $ Team.userId . only member) . legalHoldStatus - - let check :: HasCallStack => UserLegalHoldStatus -> String -> TestM () - check status msg = do - members' <- view teamMembers <$> getTeamMembers owner tid - liftIO $ - assertEqual - ("legal hold status should be " <> msg) - (Just status) - (findMemberStatus members') - - check UserLegalHoldNoConsent "disabled when it is disabled for the team" - withDummyTestServiceForTeamNoService $ \lhPort _chan -> do - check UserLegalHoldNoConsent "no_consent on new team members" - - putLHWhitelistTeam tid !!! const 200 === statusCode - newService <- newLegalHoldService lhPort - postSettings owner tid newService !!! testResponse 201 Nothing - - check UserLegalHoldDisabled "disabled on team members that have granted consent" - requestLegalHoldDevice owner member tid !!! testResponse 201 Nothing - check UserLegalHoldPending "pending after requesting device" - approveLegalHoldDevice (Just defPassword) member member tid !!! testResponse 200 Nothing - check UserLegalHoldEnabled "enabled after confirming device" - testInWhitelist :: TestM () testInWhitelist = do g <- viewGalley From b1b3af098e0bca07ed4c5f7f76b6bc70c96cc240 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 14 Feb 2024 16:08:47 +0100 Subject: [PATCH 10/21] [feat] make `HasTests` easier to use - delegate only the testcase generation to the user - use an OVERLAPPABLE default instance if the type is a Generic Enum - cover more cases - don't use newtype Wrappers wherever possible --- integration/test/MLS/Util.hs | 9 +- integration/test/Test/LegalHold.hs | 9 +- integration/test/Test/MLS/One2One.hs | 11 +- integration/test/Test/MLS/SubConversation.hs | 18 ++- integration/test/Test/Search.hs | 4 +- integration/test/Test/User.hs | 13 +- integration/test/Test/Version.hs | 15 +-- integration/test/Testlib/App.hs | 2 + integration/test/Testlib/HTTP.hs | 2 + integration/test/Testlib/PTest.hs | 120 ++++++++++++++----- integration/test/Testlib/Types.hs | 2 +- 11 files changed, 133 insertions(+), 72 deletions(-) diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index f1dd2492a1d..68b43c37616 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -135,10 +135,11 @@ instance MakesValue CredentialType where make BasicCredentialType = make "basic" make X509CredentialType = make "x509" -instance (HasTests x) => HasTests (CredentialType -> x) where - mkTests m n s f x = - mkTests m (n <> "[ctype=basic]") s f (x BasicCredentialType) - <> mkTests m (n <> "[ctype=x509]") s f (x X509CredentialType) +instance TestCases CredentialType where + testCases = + [ MkTestCase "[ctype=basic]" BasicCredentialType, + MkTestCase "[ctype=x509]" X509CredentialType + ] data InitMLSClient = InitMLSClient {credType :: CredentialType} diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 18ab2eb0b62..51e69775868 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -200,11 +200,11 @@ testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedB data TestClaimKeys = TCKConsentMissing -- (team not whitelisted, that is) | TCKConsentAndNewClients - deriving (Show, Bounded, Enum) + deriving (Show, Generic) -- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients. -testLHClaimKeys :: WithBoundedEnumArg TestClaimKeys (App ()) -testLHClaimKeys = WithBoundedEnumArg $ \testmode -> do +testLHClaimKeys :: TestClaimKeys -> App () +testLHClaimKeys testmode = do startDynamicBackends [mempty] $ \[dom] -> do withMockServer lhMockApp $ \lhPort _chan -> do (lowner, ltid, [lmem]) <- createTeam dom 2 @@ -620,3 +620,6 @@ testLHGetMembersIncludesStatus = do -- bob has accepted the legalhold device statusShouldbe "enabled" + +testLHNoConsentBlockOne2OneConv :: Bool -> Bool -> Bool -> Bool -> App () +testLHNoConsentBlockOne2OneConv = undefined diff --git a/integration/test/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index ccd8365477e..77c9ecb54c8 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -68,11 +68,12 @@ data One2OneScenario | -- | One user is remote, conversation is remote One2OneScenarioRemoteConv -instance HasTests x => HasTests (One2OneScenario -> x) where - mkTests m n s f x = - mkTests m (n <> "[domain=own]") s f (x One2OneScenarioLocal) - <> mkTests m (n <> "[domain=other;conv=own]") s f (x One2OneScenarioLocalConv) - <> mkTests m (n <> "[domain=other;conv=other]") s f (x One2OneScenarioRemoteConv) +instance TestCases One2OneScenario where + testCases = + [ MkTestCase "[domain=own]" One2OneScenarioLocal, + MkTestCase "[domain=other;conv=own]" One2OneScenarioLocalConv, + MkTestCase "[domain=other;conv=other]" One2OneScenarioRemoteConv + ] one2OneScenarioDomain :: One2OneScenario -> Domain one2OneScenarioDomain One2OneScenarioLocal = OwnDomain diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index 42cdb0ec95f..d73095030da 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -102,15 +102,11 @@ testDeleteSubConversation otherDomain = do sub2' <- getSubConversation alice1 qcnv "conference2" >>= getJSON 200 sub2 `shouldNotMatch` sub2' -data LeaveSubConvVariant = AliceLeaves | BobLeaves +data Leaver = Alice | Bob + deriving stock (Generic) -instance HasTests x => HasTests (LeaveSubConvVariant -> x) where - mkTests m n s f x = - mkTests m (n <> "[leaver=alice]") s f (x AliceLeaves) - <> mkTests m (n <> "[leaver=bob]") s f (x BobLeaves) - -testLeaveSubConv :: HasCallStack => LeaveSubConvVariant -> App () -testLeaveSubConv variant = do +testLeaveSubConv :: HasCallStack => Leaver -> App () +testLeaveSubConv leaver = do [alice, bob, charlie] <- createAndConnectUsers [OwnDomain, OwnDomain, OtherDomain] clients@[alice1, bob1, bob2, charlie1] <- traverse (createMLSClient def) [alice, bob, bob, charlie] traverse_ uploadNewKeyPackage [bob1, bob2, charlie1] @@ -126,9 +122,9 @@ testLeaveSubConv variant = do void $ createExternalCommit charlie1 Nothing >>= sendAndConsumeCommitBundle -- a member leaves the subconversation - let (firstLeaver, idxFirstLeaver) = case variant of - BobLeaves -> (bob1, 0) - AliceLeaves -> (alice1, 1) + let (firstLeaver, idxFirstLeaver) = case leaver of + Bob -> (bob1, 0) + Alice -> (alice1, 1) let idxCharlie1 = 3 let others = filter (/= firstLeaver) clients diff --git a/integration/test/Test/Search.hs b/integration/test/Test/Search.hs index ac66155b1b6..7d93b4ff015 100644 --- a/integration/test/Test/Search.hs +++ b/integration/test/Test/Search.hs @@ -76,7 +76,7 @@ data FedUserSearchTestCase = FedUserSearchTestCase testFederatedUserSearch :: HasCallStack => App () testFederatedUserSearch = do - let testCases = + let tcs = [ -- no search FedUserSearchTestCase "no_search" AllowAll AllowAll False False, FedUserSearchTestCase "no_search" TeamAllowed TeamAllowed False False, @@ -100,7 +100,7 @@ testFederatedUserSearch = do startDynamicBackends [def, def] $ \[d1, d2] -> do void $ BrigI.createFedConn d2 (BrigI.FedConn d1 "full_search" Nothing) void $ BrigI.createFedConn d1 (BrigI.FedConn d2 "full_search" Nothing) - forM_ testCases (federatedUserSearch d1 d2) + forM_ tcs (federatedUserSearch d1 d2) federatedUserSearch :: HasCallStack => String -> String -> FedUserSearchTestCase -> App () federatedUserSearch d1 d2 test = do diff --git a/integration/test/Test/User.hs b/integration/test/Test/User.hs index 903de5a0724..2c5df564377 100644 --- a/integration/test/Test/User.hs +++ b/integration/test/Test/User.hs @@ -120,8 +120,8 @@ testUpdateHandle = do -- | For now this only tests attempts to update one's own display name, email address, or -- language in E2EId-enabled teams (ie., everything except handle). More tests can be found -- under `/services/brig/test/integration` (and should be moved here). -testUpdateSelf :: HasCallStack => TestUpdateSelfMode -> App () -testUpdateSelf mode = do +testUpdateSelf :: HasCallStack => Tagged "mode" TestUpdateSelfMode -> App () +testUpdateSelf (MkTagged mode) = do -- create team with one member, without scim, but with `mlsE2EId` enabled. (owner, team, [mem1]) <- createTeam OwnDomain 2 @@ -162,11 +162,4 @@ data TestUpdateSelfMode = TestUpdateDisplayName | TestUpdateEmailAddress | TestUpdateLocale - deriving (Eq, Show, Bounded, Enum) - -instance HasTests x => HasTests (TestUpdateSelfMode -> x) where - mkTests m n s f x = - mconcat - [ mkTests m (n <> "[mode=" <> show mode <> "]") s f (x mode) - | mode <- [minBound ..] - ] + deriving (Eq, Show, Generic) diff --git a/integration/test/Test/Version.hs b/integration/test/Test/Version.hs index e6996107fc2..31295918468 100644 --- a/integration/test/Test/Version.hs +++ b/integration/test/Test/Version.hs @@ -8,13 +8,14 @@ import Testlib.Prelude newtype Versioned' = Versioned' Versioned -- | This instance is used to generate tests for some of the versions. (Not checking all of them for time efficiency reasons) -instance HasTests x => HasTests (Versioned' -> x) where - mkTests m n s f x = - mkTests m (n <> "[version=unversioned]") s f (x (Versioned' Unversioned)) - <> mkTests m (n <> "[version=versioned]") s f (x (Versioned' Versioned)) - <> mkTests m (n <> "[version=v1]") s f (x (Versioned' (ExplicitVersion 1))) - <> mkTests m (n <> "[version=v3]") s f (x (Versioned' (ExplicitVersion 3))) - <> mkTests m (n <> "[version=v6]") s f (x (Versioned' (ExplicitVersion 6))) +instance TestCases Versioned' where + testCases = + [ MkTestCase "[version=unversioned]" (Versioned' Unversioned), + MkTestCase "[version=versioned]" (Versioned' Versioned), + MkTestCase "[version=v1]" (Versioned' (ExplicitVersion 1)), + MkTestCase "[version=v3]" (Versioned' (ExplicitVersion 3)), + MkTestCase "[version=v6]" (Versioned' (ExplicitVersion 6)) + ] testVersion :: Versioned' -> App () testVersion (Versioned' v) = withModifiedBackend diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index e0978f4e382..f34bf2a5033 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -7,6 +7,7 @@ import Data.IORef import qualified Data.Text as T import qualified Data.Yaml as Yaml import GHC.Exception +import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import System.FilePath import Testlib.JSON @@ -52,6 +53,7 @@ readServiceConfig' srvName = do Right value -> pure value data Domain = OwnDomain | OtherDomain + deriving stock (Eq, Show, Generic) instance MakesValue Domain where make OwnDomain = asks (String . T.pack . (.domain1)) diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index 86311ca1c36..e21b6e3c588 100644 --- a/integration/test/Testlib/HTTP.hs +++ b/integration/test/Testlib/HTTP.hs @@ -16,6 +16,7 @@ import Data.String import Data.String.Conversions (cs) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import GHC.Generics import GHC.Stack import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types (hLocation) @@ -123,6 +124,7 @@ onFailureAddResponse r m = App $ do E.throw (AssertionFailure stack (Just r) msg) data Versioned = Versioned | Unversioned | ExplicitVersion Int + deriving stock (Generic) -- | If you don't know what domain is for or what you should put in there, try `rawBaseRequest -- OwnDomain ...`. diff --git a/integration/test/Testlib/PTest.hs b/integration/test/Testlib/PTest.hs index 56d6d7be10c..3aa16c6fcc8 100644 --- a/integration/test/Testlib/PTest.hs +++ b/integration/test/Testlib/PTest.hs @@ -1,8 +1,12 @@ module Testlib.PTest where +import Data.Bifunctor (bimap) +import Data.Char (toLower) +import Data.Functor ((<&>)) +import Data.Kind import Data.Proxy +import GHC.Generics import GHC.TypeLits -import Testlib.App import Testlib.Env import Testlib.Types import Prelude @@ -15,38 +19,96 @@ class HasTests x where instance HasTests (App ()) where mkTests m n s f x = [(m, n, s, f, x)] -instance HasTests x => HasTests (Domain -> x) where +instance (HasTests x, TestCases a) => HasTests (a -> x) where mkTests m n s f x = - mkTests m (n <> "[domain=own]") s f (x OwnDomain) - <> mkTests m (n <> "[domain=other]") s f (x OtherDomain) + flip foldMap (testCases @a) \tc -> + mkTests m (n <> tc.testCaseName) s f (x tc.testCase) -instance HasTests x => HasTests (Ciphersuite -> x) where - mkTests m n s f x = - mconcat - [ mkTests m (n <> "[suite=" <> suite.code <> "]") s f (x suite) - | suite <- allCiphersuites - ] +data TestCase a = MkTestCase {testCaseName :: String, testCase :: a} + deriving stock (Eq, Ord, Show, Generic) --- | this is to resolve overlapping instances issues. -newtype WithBoundedEnumArg arg x = WithBoundedEnumArg (arg -> x) +-- | enumerate all members of a bounded enum type +-- +-- >>> testCases @Bool +-- [MkTestCase {testCaseName = "[bool=false]", testCase = False},MkTestCase {testCaseName = "[bool=true]", testCase = True}] +-- >>> testCases @Domain +-- [MkTestCase {testCaseName = "[domain=owndomain]", testCase = OwnDomain},MkTestCase {testCaseName = "[domain=otherdomain]", testCase = OtherDomain}] +-- >>> testCases @Ciphersuite +-- [MkTestCase {testCaseName = "[suite=0x0001]", testCase = Ciphersuite {code = "0x0001"}},MkTestCase {testCaseName = "[suite=0xf031]", testCase = Ciphersuite {code = "0xf031"}}] +-- >>> testCases @(Tagged "foo" Bool) +-- [MkTestCase {testCaseName = "[foo=false]", testCase = MkTagged {unTagged = False}},MkTestCase {testCaseName = "[foo=true]", testCase = MkTagged {unTagged = True}}] +class TestCases a where + testCases :: [TestCase a] -instance (HasTests x, Enum arg, Bounded arg, Show arg) => HasTests (WithBoundedEnumArg arg x) where - mkTests m n s f (WithBoundedEnumArg x) = - mconcat - [ mkTests m (n <> "[" <> show arg <> "]") s f (x arg) - | arg <- [minBound ..] - ] +type Tagged :: Symbol -> Type -> Type +newtype Tagged s a = MkTagged {unTagged :: a} + deriving stock (Eq, Ord, Show, Generic) --- | bool with a tag to prevent boolean blindness in test output. -newtype TaggedBool (tag :: Symbol) = TaggedBool {untag :: Bool} - deriving newtype (Eq, Ord, Bounded, Enum) +type TaggedBool s = Tagged s Bool -instance KnownSymbol tag => Show (TaggedBool tag) where - show (TaggedBool b) = show (symbolVal (Proxy @tag)) <> "=" <> show b +pattern TaggedBool :: Bool -> Tagged s Bool +pattern TaggedBool a = MkTagged a -instance (KnownSymbol tag, HasTests x) => HasTests (TaggedBool tag -> x) where - mkTests m n s f x = - mconcat - [ mkTests m (n <> "[" <> show arg <> "]") s f (x arg) - | arg <- [minBound ..] - ] +{-# COMPLETE TaggedBool #-} + +-- | only works for toplevel types +-- +-- >>> testCases @(Tagged "bla" Bool) +instance (GEnum (Rep a), KnownSymbol s, Generic a) => TestCases (Tagged s a) where + testCases = + uni @(Rep a) <&> \case + -- replace the toplevel + (Left _ : ls, tc) -> + MkTestCase + { testCaseName = foldr mkName "" (Left (symbolVal @s Proxy) : ls), + testCase = MkTagged $ to tc + } + _ -> error "tagged test cases: impossible" + +instance TestCases Ciphersuite where + testCases = do + suite <- allCiphersuites + pure $ + MkTestCase + { testCaseName = mkName (Left "suite") suite.code, + testCase = suite + } + +-- | a default instance, normally we don't do such things but this is more convenient in +-- the test suite as you don't have to derive anything +instance {-# OVERLAPPABLE #-} (Generic a, GEnum (Rep a)) => TestCases a where + testCases = + uni @(Rep a) <&> \(tcn, tc) -> + MkTestCase + { testCaseName = foldr mkName "" tcn, + testCase = to tc + } + +{-# INLINE [1] mkName #-} +mkName :: Either String String -> String -> String +mkName (Left a) = \acc -> mconcat ["[", toLower <$> a, "=" <> acc <> "]"] +mkName (Right (fmap toLower -> a)) = \case + [] -> a + acc@('[' : _) -> a <> acc + acc -> a <> "." <> acc + +class GEnum f where + uni :: [([Either String String], f x)] + +instance (GEnum k, KnownSymbol n) => GEnum (D1 (MetaData n m p b) k) where + uni = bimap (Left (symbolVal @n Proxy) :) M1 <$> uni @k + +instance (GEnum k) => GEnum (S1 md k) where + uni = fmap M1 <$> uni @k + +instance (GEnum k, KnownSymbol n) => GEnum (C1 (MetaCons n p b) k) where + uni = bimap (Right (symbolVal @n Proxy) :) M1 <$> uni @k + +instance (GEnum k1, GEnum k2) => GEnum (k1 :+: k2) where + uni = (fmap L1 <$> uni @k1) <> (fmap R1 <$> uni @k2) + +instance GEnum U1 where + uni = [([Right ""], U1)] + +instance (GEnum (Rep k), Generic k) => GEnum (K1 r k) where + uni = fmap (K1 . to) <$> uni @(Rep k) diff --git a/integration/test/Testlib/Types.hs b/integration/test/Testlib/Types.hs index 2a8c63f169e..d9a2dd5414c 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -225,7 +225,7 @@ data ClientIdentity = ClientIdentity deriving stock (Show, Eq, Ord, Generic) newtype Ciphersuite = Ciphersuite {code :: String} - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) instance Default Ciphersuite where def = Ciphersuite "0x0001" From b3b8d03582225c004745d4bec0919be159cf7b43 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 14 Feb 2024 18:58:16 +0100 Subject: [PATCH 11/21] [wip] test no 7 --- integration/test/API/BrigInternal.hs | 6 ++ integration/test/Test/LegalHold.hs | 74 ++++++++++++++++++- .../test/integration/API/Teams/LegalHold.hs | 6 +- 3 files changed, 83 insertions(+), 3 deletions(-) diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index 7292946956e..d140df32a1a 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -236,3 +236,9 @@ addClient user args = do req <- baseRequest user Brig Unversioned $ "/i/clients/" <> uid val <- mkAddClientValue args submit "POST" $ req & addJSONObject val + +getClientsFull :: (HasCallStack, MakesValue users, MakesValue uid) => uid -> users -> App Response +getClientsFull user users = do + val <- make users + baseRequest user Brig Unversioned do joinHttpPath ["i", "clients", "full"] + >>= submit "POST" . addJSONObject ["users" .= val] diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 51e69775868..d8d625c716f 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -621,5 +621,75 @@ testLHGetMembersIncludesStatus = do -- bob has accepted the legalhold device statusShouldbe "enabled" -testLHNoConsentBlockOne2OneConv :: Bool -> Bool -> Bool -> Bool -> App () -testLHNoConsentBlockOne2OneConv = undefined +type TB s = TaggedBool s + +ut :: TB s -> Bool +ut = unTagged + +testLHNoConsentBlockOne2OneConv :: TB "connect first" -> TB "team peer" -> TB "approve LH" -> TB "test pending connection" -> App () +testLHNoConsentBlockOne2OneConv + (ut -> connectFirst) + (ut -> teampeer) + (ut -> approveLH) + (ut -> testPendingConnection) = do + startDynamicBackends [mempty, mempty] \[dom1, dom2] -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, []) <- createTeam dom1 1 + alicec <- addClient alice def + bob <- + if teampeer + then do + (walice, _tid, []) <- createTeam dom2 1 + 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 do + aliceId <- objId alice + BrigI.getClientsFull alice [aliceId] `bindResponse` \resp -> do + [lhd] <- + resp.json %. aliceId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + lhdid <- lhd %. "id" & asString + pure (Just lhdid) + else pure Nothing + + doDisableLH :: HasCallStack => App () + doDisableLH = + disableLegalHold tid alice alice defPassword + >>= assertStatus 200 + + 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 + postConnection alice bob + >>= assertStatus 201 diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 98a4fd56fae..47782cac5e7 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -415,7 +415,11 @@ testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnect >>> Set.toList >>> listToMaybe >>> fmap clientId - else pure Nothing + else -- this looks like it's actually incorrect, + -- we might either get alices own device or her + -- legalhold device, depending on the order in which + -- the json is serialised + pure Nothing doDisableLH :: HasCallStack => TestM () doDisableLH = do From 8892000f2d99ad63d463070c47b0eb401c333b91 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Fri, 16 Feb 2024 00:26:49 +0100 Subject: [PATCH 12/21] [feat] test number 7 and (hopefull) fix flakes --- .envrc | 2 +- integration/test/API/Brig.hs | 6 +- integration/test/API/Galley.hs | 2 +- integration/test/Notifications.hs | 21 +++++ integration/test/Test/LegalHold.hs | 121 +++++++++++++++++++++---- integration/test/Test/MLS.hs | 2 +- integration/test/Testlib/Assertions.hs | 2 +- integration/test/Testlib/Env.hs | 2 +- integration/test/Testlib/JSON.hs | 13 +++ integration/test/Testlib/ModService.hs | 4 +- 10 files changed, 147 insertions(+), 28 deletions(-) diff --git a/.envrc b/.envrc index b7b3f2c35fd..d9a16210890 100644 --- a/.envrc +++ b/.envrc @@ -59,7 +59,7 @@ export AWS_ACCESS_KEY_ID="dummykey" export AWS_SECRET_ACCESS_KEY="dummysecret" # integration test suite timeout -export TEST_TIMEOUT_SECONDS=2 +export TEST_TIMEOUT_SECONDS=5 # allow local .envrc overrides [[ -f .envrc.local ]] && source_env .envrc.local diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 4c91304bd33..e2ada6779c7 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -319,9 +319,9 @@ uploadKeyPackages cid kps = do "/mls/key-packages/self/" <> cid.client submit "POST" - ( req + do + req & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps] - ) claimKeyPackagesWithParams :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> [(String, String)] -> App Response claimKeyPackagesWithParams suite u v params = do @@ -333,7 +333,7 @@ claimKeyPackagesWithParams suite u v params = do req & addQueryParams ([("ciphersuite", suite.code)] <> params) -claimKeyPackages :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response +claimKeyPackages :: (HasCallStack, MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response claimKeyPackages suite u v = claimKeyPackagesWithParams suite u v [] countKeyPackages :: Ciphersuite -> ClientIdentity -> App Response diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index a1b0b20a139..2618a199c0a 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -238,7 +238,7 @@ postProteusMessage user conv msgs = do convDomain <- objDomain conv convId <- objId conv let bytes = Proto.encodeMessage msgs - req <- baseRequest user Galley Versioned ("/conversations/" <> convDomain <> "/" <> convId <> "/proteus/messages") + req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", convDomain, convId, "proteus", "messages"]) submit "POST" (addProtobuf bytes req) mkProteusRecipient :: (HasCallStack, MakesValue user, MakesValue client) => user -> client -> String -> App Proto.QualifiedUserEntry diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index c3350982aba..cb8ea9ae5b4 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -4,6 +4,7 @@ module Notifications where import API.Gundeck import Control.Monad.Extra import Control.Monad.Reader (asks) +import GHC.Generics ((:.:) (Comp1, unComp1)) import Testlib.Prelude import UnliftIO.Concurrent @@ -133,6 +134,26 @@ isUserLegalholdEnabledNotif = notifTypeIsEqual "user.legalhold-enable" isUserLegalholdDisabledNotif :: MakesValue a => a -> App Bool isUserLegalholdDisabledNotif = notifTypeIsEqual "user.legalhold-disable" +isUserConnectionNotif :: MakesValue a => a -> App Bool +isUserConnectionNotif = notifTypeIsEqual "user.connection" + +-- | compose two predicates on notifications with a boolean relation +notifBoolRel :: MakesValue a => (Bool -> Bool -> Bool) -> (a -> App Bool) -> (a -> App Bool) -> a -> App Bool +notifBoolRel rel p1 p2 = unComp1 do + rel <$> Comp1 p1 <*> Comp1 p2 + +-- | compose two predicates on notifications with a '(||)' +notifOr :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool +notifOr = notifBoolRel (||) + +infixr 2 `notifOr` + +-- | compose two predicates on notifications with a '(&&)' +notifAnd :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool +notifAnd = notifBoolRel (&&) + +infixr 3 `notifAnd` + assertLeaveNotification :: ( HasCallStack, MakesValue fromUser, diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index d8d625c716f..4eddfc3313a 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -38,7 +38,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import GHC.Stack import Network.Wai (Request (pathInfo, requestMethod)) -import Notifications (awaitNotification, awaitNotifications, isUserClientAddNotif, isUserClientRemoveNotif, isUserLegalholdDisabledNotif, isUserLegalholdEnabledNotif, isUserLegalholdRequestNotif) +import Notifications import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -405,10 +405,10 @@ testLHApproveDevice = do let uidsAndTidMatch val = do actualTid <- - MaybeT (lookupField val "team_id") + lookupFieldM val "team_id" >>= lift . asString actualUid <- - MaybeT (lookupField val "user_id") + lookupFieldM val "user_id" >>= lift . asString bobUid <- lift $ objId bob @@ -429,7 +429,7 @@ testLHApproveDevice = do >>= assertStatus 200 let matchAuthToken val = - MaybeT (val `lookupField` "refresh_token") + lookupFieldM val "refresh_token" >>= lift . asString checkChanVal chan matchAuthToken @@ -471,8 +471,6 @@ testLHGetDeviceStatus = resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "no_consent" - let lookupM field jason = MaybeT (lookupField jason field) - lpk <- getLastPrekey pks <- replicateM 3 getPrekey @@ -485,7 +483,7 @@ testLHGetDeviceStatus = resp.json %. "status" `shouldMatch` "disabled" lookupField resp.json "last_prekey" >>= assertNothing - runMaybeT (lookupM "client" resp.json >>= lookupM "id") + runMaybeT (lookupFieldM resp.json "client" >>= flip lookupFieldM "id") >>= assertNothing -- the status messages for these have already been tested @@ -543,10 +541,8 @@ testLHDisableForUser = mzero void do - -- this is awkward, but it's because the order is not clear - notifs <- awaitNotifications bob bobc Nothing 2 \notif -> (||) <$> isUserClientRemoveNotif notif <*> isUserLegalholdDisabledNotif notif - assertBool "we have a client remove notif" . not . null =<< filterM isUserClientRemoveNotif notifs - assertBool "we have a legalhold disable notif" . not . null =<< filterM isUserLegalholdDisabledNotif notifs + awaitNotification bob bobc noValue isUserClientRemoveNotif + *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif -- TODO(mangoiv): assert zero legalhold devices @@ -632,15 +628,16 @@ testLHNoConsentBlockOne2OneConv (ut -> teampeer) (ut -> approveLH) (ut -> testPendingConnection) = do - startDynamicBackends [mempty, mempty] \[dom1, dom2] -> do + startDynamicBackends [mempty] \[dom1] -> do -- team users -- alice (team owner) and bob (member) (alice, tid, []) <- createTeam dom1 1 - alicec <- addClient alice def bob <- if teampeer then do - (walice, _tid, []) <- createTeam dom2 1 + (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 @@ -658,9 +655,7 @@ testLHNoConsentBlockOne2OneConv >>= assertStatus 200 legalholdUserStatus tid alice alice `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 - resp.json - %. "status" - `shouldMatch` if approveLH then "enabled" else "pending" + resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" if approveLH then do aliceId <- objId alice @@ -690,6 +685,96 @@ testLHNoConsentBlockOne2OneConv postConnection bob alice >>= assertLabel 403 "missing-legalhold-consent" - else + 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.id" + + -- 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 sendMessageFromBobToAlice assertion = + for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do + successfulMsgForOtherUsers <- mkProteusRecipients bob [(alice, alicec), (alice, device)] "hey alice (and eve)" + let bobaliceMessage = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (bobc2 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + postProteusMessage bob convId bobaliceMessage + >>= assertion + + sendMessageFromBobToAlice \resp -> do + resp.status `shouldMatchInt` 404 + printJSON resp.json + -- now we disable legalhold + + doDisableLH + + for_ mbLHDevice \lhd -> + 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 \resp -> do + resp.status `shouldMatchInt` 201 + printJSON resp.json diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index 049d3d8d4a7..413963c2d59 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -24,7 +24,7 @@ testSendMessageNoReturnToSender = do -- the message withWebSockets [alice1, alice2, bob1, bob2] $ \(wsSender : wss) -> do mp <- createApplicationMessage alice1 "hello, bob" - void . bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do + bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do resp.status `shouldMatchInt` 201 for_ wss $ \ws -> do n <- awaitMatch (\n -> nPayload n %. "type" `isEqual` "conversation.mls-message-add") ws diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index 390615730c9..2668a84b745 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -55,7 +55,7 @@ shouldMatch :: a `shouldMatch` b = do xa <- make a xb <- make b - unless (xa == xb) $ do + unless (xa == xb) do pa <- prettyJSON xa pb <- prettyJSON xb assertFailure $ "Actual:\n" <> pa <> "\nExpected:\n" <> pb diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 39f274b1f94..264aecca61f 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -92,7 +92,7 @@ mkGlobalEnv cfgFile = do tempDir <- Codensity $ withSystemTempDirectory "test" timeOutSeconds <- liftIO $ - fromMaybe 10 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") + fromMaybe 20 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") pure GlobalEnv { gServiceMap = sm, diff --git a/integration/test/Testlib/JSON.hs b/integration/test/Testlib/JSON.hs index 59aa2400ff4..ee21cf2f7f7 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -189,6 +189,15 @@ renameField old new obj = o :: Value <- maybe mzero pure =<< lift (lookupField obj old) lift (removeField old obj >>= setField new o) +-- | like 'lookupField' but wrapped in 'MaybeT' for convenience +lookupFieldM :: + (HasCallStack, MakesValue a) => + a -> + -- | A plain key, e.g. "id", or a nested key "user.profile.id" + String -> + MaybeT App Value +lookupFieldM = fmap MaybeT . lookupField + -- | Look up (nested) field of a JSON object -- -- If the field key has no dots then returns Nothing if the key is missing from the @@ -292,6 +301,10 @@ assertFailureWithJSON v msg = do printJSON :: MakesValue a => a -> App () printJSON = prettyJSON >=> liftIO . putStrLn +-- | useful for debugging, same as 'printJSON' but returns input JSON +traceJSON :: MakesValue a => a -> App a +traceJSON a = printJSON a $> a + prettyJSON :: MakesValue a => a -> App String prettyJSON x = make x <&> LC8.unpack . Aeson.encodePretty diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 98084b097b9..f4390d7286f 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -117,7 +117,7 @@ traverseConcurrentlyCodensity f args = do pure result -startDynamicBackends :: HasCallStack => [ServiceOverrides] -> (HasCallStack => [String] -> App a) -> App a +startDynamicBackends :: [ServiceOverrides] -> ([String] -> App a) -> App a startDynamicBackends beOverrides k = runCodensity do @@ -128,7 +128,7 @@ startDynamicBackends beOverrides k = pure $ map (.berDomain) resources k -startDynamicBackend :: HasCallStack => BackendResource -> ServiceOverrides -> Codensity App () +startDynamicBackend :: BackendResource -> ServiceOverrides -> Codensity App () startDynamicBackend resource beOverrides = do let overrides = mconcat From 008239649a0493886d4c144d3365ca332c8019e6 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Fri, 16 Feb 2024 00:29:26 +0100 Subject: [PATCH 13/21] [chore] delete ported test --- .../test/integration/API/Teams/LegalHold.hs | 152 ------------------ 1 file changed, 152 deletions(-) diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 47782cac5e7..1cd1f785a01 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -26,22 +26,16 @@ import API.Teams.LegalHold.Util import API.Util import Bilge hiding (accept, head, timeout, trace) import Bilge.Assert -import Brig.Types.Intra (UserSet (..)) import Brig.Types.Test.Arbitrary () -import Brig.Types.User.Event qualified as Ev -import Control.Category ((>>>)) import Control.Concurrent.Chan import Control.Lens hiding ((#)) import Data.Id import Data.LegalHold import Data.List.NonEmpty (NonEmpty (..)) -import Data.Map.Strict qualified as Map import Data.PEM import Data.Qualified (Qualified (..)) import Data.Range -import Data.Set qualified as Set import Data.Time.Clock qualified as Time -import Data.Timeout import Galley.Cassandra.LegalHold import Galley.Env qualified as Galley import Galley.Options (featureFlags, settings) @@ -58,7 +52,6 @@ import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import TestHelpers import TestSetup -import Wire.API.Connection (UserConnection) import Wire.API.Connection qualified as Conn import Wire.API.Conversation.Role (roleNameWireAdmin, roleNameWireMember) import Wire.API.Provider.Service @@ -111,13 +104,6 @@ testsPublic s = [ testGroup -- FUTUREWORK: ungroup this level "teams listed" [ test s "happy flow" testInWhitelist, - testGroup "no-consent" $ do - connectFirst <- ("connectFirst",) <$> [False, True] - teamPeer <- ("teamPeer",) <$> [False, True] - approveLH <- ("approveLH",) <$> [False, True] - testPendingConnection <- ("testPendingConnection",) <$> [False, True] - let name = intercalate ", " $ map (\(n, b) -> n <> "=" <> show b) [connectFirst, teamPeer, approveLH, testPendingConnection] - pure . test s name $ testNoConsentBlockOne2OneConv (snd connectFirst) (snd teamPeer) (snd approveLH) (snd testPendingConnection), 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), @@ -385,144 +371,6 @@ testInWhitelist = do 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' --- If LH is activated for other user in 1:1 conv, 1:1 conv is blocked -testNoConsentBlockOne2OneConv :: HasCallStack => Bool -> Bool -> Bool -> Bool -> TestM () -testNoConsentBlockOne2OneConv connectFirst teamPeer approveLH testPendingConnection = do - -- FUTUREWORK: maybe regular user for legalholder? - (legalholder :: UserId, tid) <- createBindingTeam - regularClient <- randomClient legalholder (head someLastPrekeys) - - peer :: UserId <- if teamPeer then fst <$> createBindingTeam else randomUser - galley <- viewGalley - - putLHWhitelistTeam tid !!! const 200 === statusCode - - let doEnableLH :: HasCallStack => TestM (Maybe ClientId) - doEnableLH = do - -- register & (possibly) approve LH device for legalholder - withLHWhitelist tid (requestLegalHoldDevice' galley legalholder legalholder tid) !!! testResponse 201 Nothing - when approveLH $ - withLHWhitelist tid (approveLegalHoldDevice' galley (Just defPassword) legalholder legalholder tid) !!! testResponse 200 Nothing - UserLegalHoldStatusResponse userStatus _ _ <- withLHWhitelist tid (getUserStatusTyped' galley legalholder tid) - liftIO $ assertEqual "approving should change status" (if approveLH then UserLegalHoldEnabled else UserLegalHoldPending) userStatus - if approveLH - then - getInternalClientsFull (UserSet $ Set.singleton legalholder) - <&> do - userClientsFull - >>> Map.elems - >>> Set.unions - >>> Set.toList - >>> listToMaybe - >>> fmap clientId - else -- this looks like it's actually incorrect, - -- we might either get alices own device or her - -- legalhold device, depending on the order in which - -- the json is serialised - pure Nothing - - doDisableLH :: HasCallStack => TestM () - doDisableLH = do - -- remove (only) LH device again - withLHWhitelist tid (disableLegalHoldForUser' galley (Just defPassword) tid legalholder legalholder) - !!! testResponse 200 Nothing - - cannon <- view tsCannon - - WS.bracketR2 cannon legalholder peer $ \(legalholderWs, peerWs) -> withDummyTestServiceForTeam legalholder tid $ \_chan -> do - if not connectFirst - then do - void doEnableLH - postConnection legalholder peer !!! do testResponse 403 (Just "missing-legalhold-consent") - postConnection peer legalholder !!! do testResponse 403 (Just "missing-legalhold-consent") - else do - postConnection legalholder peer !!! const 201 === statusCode - - mbConn :: Maybe UserConnection <- - if testPendingConnection - then pure Nothing - else do - res <- putConnection peer legalholder Conn.Accepted do - assertNotification ws $ - \case - (Ev.ConnectionEvent (Ev.ConnectionUpdated (Conn.ucStatus -> rel) _prev _name)) -> do - rel @?= Conn.MissingLegalholdConsent - _ -> assertBool "wrong event type" False - - forM_ [(legalholder, peer), (peer, legalholder)] $ \(one, two) -> do - putConnection one two Conn.Accepted - !!! testResponse 403 (Just "bad-conn-update") - - assertConnections legalholder [ConnectionStatus legalholder peer Conn.MissingLegalholdConsent] - assertConnections peer [ConnectionStatus peer legalholder Conn.MissingLegalholdConsent] - - -- peer can't send message to legalhodler. the conversation appears gone. - peerClient <- randomClient peer (someLastPrekeys !! 2) - for_ ((,) <$> (mbConn >>= Conn.ucConvId) <*> mbLegalholderLHDevice) $ \(convId, legalholderLHDevice) -> do - postOtrMessage - id - peer - peerClient - (qUnqualified convId) - [ (legalholder, legalholderLHDevice, "cipher"), - (legalholder, regularClient, "cipher") - ] - !!! do - const 404 === statusCode - const (Right "no-conversation") === fmap Error.label . responseJsonEither - - do - doDisableLH - - when approveLH $ do - legalholderLHDevice <- assertJust mbLegalholderLHDevice - WS.assertMatch_ (5 # Second) legalholderWs $ - wsAssertClientRemoved legalholderLHDevice - - assertConnections - legalholder - [ ConnectionStatus legalholder peer $ - if testPendingConnection then Conn.Sent else Conn.Accepted - ] - assertConnections - peer - [ ConnectionStatus peer legalholder $ - if testPendingConnection then Conn.Pending else Conn.Accepted - ] - - forM_ [legalholderWs, peerWs] $ \ws -> do - assertNotification ws $ - \case - (Ev.ConnectionEvent (Ev.ConnectionUpdated (Conn.ucStatus -> rel) _prev _name)) -> do - assertBool "" (rel `elem` [Conn.Sent, Conn.Pending, Conn.Accepted]) - _ -> assertBool "wrong event type" False - - -- conversation reappears. peer can send message to legalholder again - for_ ((,) <$> (mbConn >>= Conn.ucConvId) <*> mbLegalholderLHDevice) $ \(convId, legalholderLHDevice) -> do - postOtrMessage - id - peer - peerClient - (qUnqualified convId) - [ (legalholder, legalholderLHDevice, "cipher"), - (legalholder, regularClient, "cipher") - ] - !!! do - const 201 === statusCode - assertMismatchWithMessage - (Just "legalholderLHDevice is deleted") - [] - [] - [(legalholder, Set.singleton legalholderLHDevice)] - data GroupConvAdmin = LegalholderIsAdmin | PeerIsAdmin From f25989aff19aaa26506a2714c6bcfc430fc3c524 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Fri, 16 Feb 2024 10:56:51 +0100 Subject: [PATCH 14/21] [test] REVERT: set ridiculously high timeout --- integration/test/Testlib/Env.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 264aecca61f..445e4e769cc 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -92,7 +92,7 @@ mkGlobalEnv cfgFile = do tempDir <- Codensity $ withSystemTempDirectory "test" timeOutSeconds <- liftIO $ - fromMaybe 20 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") + fromMaybe 90 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") pure GlobalEnv { gServiceMap = sm, From 84feffadc1cf1e18507b14875940a470d569b7fa Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Mon, 19 Feb 2024 13:15:22 +0100 Subject: [PATCH 15/21] [fix] fix message receiving not working --- integration/test/Test/LegalHold.hs | 31 +++++++++++++++++++++--------- integration/test/Testlib/Env.hs | 2 +- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 4eddfc3313a..aa784753d66 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use :" #-} -- This file is part of the Wire Server implementation. -- @@ -699,7 +701,7 @@ testLHNoConsentBlockOne2OneConv <$> do putConnection bob alice "accepted" >>= getJSON 200 - %. "qualified_conversation.id" + %. "qualified_conversation" -- we need to take away the pending/ sent status for the connections [lastNotifAlice, lastNotifBob] <- for [(alice, alicec), (bob, bobc)] \(user, client) -> do @@ -735,22 +737,31 @@ testLHNoConsentBlockOne2OneConv bobc2 <- objId $ addClient bob def >>= getJSON 201 - let sendMessageFromBobToAlice assertion = + let sendMessageFromBobToAlice :: HasCallStack => (String -> [String]) -> (Response -> App ()) -> App () + sendMessageFromBobToAlice recipients assertion = for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do - successfulMsgForOtherUsers <- mkProteusRecipients bob [(alice, alicec), (alice, device)] "hey alice (and eve)" + 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 - >>= assertion + `bindResponse` assertion - sendMessageFromBobToAlice \resp -> do + sendMessageFromBobToAlice (\device -> [alicec, device]) \resp -> do resp.status `shouldMatchInt` 404 - printJSON resp.json - -- now we disable legalhold + -- now we disable legalhold doDisableLH for_ mbLHDevice \lhd -> @@ -775,6 +786,8 @@ testLHNoConsentBlockOne2OneConv awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> notif %. "payload.0.connection.status" `shouldMatchOneOf` ["sent", "pending", "accepted"] - sendMessageFromBobToAlice \resp -> do + sendMessageFromBobToAlice (const [alicec]) \resp -> do resp.status `shouldMatchInt` 201 - printJSON resp.json + + sendMessageFromBobToAlice (\device -> [device]) \resp -> do + resp.status `shouldMatchInt` 412 diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 445e4e769cc..81ebac371da 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -92,7 +92,7 @@ mkGlobalEnv cfgFile = do tempDir <- Codensity $ withSystemTempDirectory "test" timeOutSeconds <- liftIO $ - fromMaybe 90 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") + fromMaybe 90 . (readMaybe @Int =<<) <$> lookupEnv "TEST_TIMEOUT_SECONDS" pure GlobalEnv { gServiceMap = sm, From 402d6ec2a4403abcfc10ffcd8f735d7653c1854d Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 20 Feb 2024 16:27:39 +0100 Subject: [PATCH 16/21] [fix] set high timeout for events for tests that don't work reliably because of message queueing --- .envrc | 2 +- integration/test/Test/LegalHold.hs | 20 +++++++++++++++----- integration/test/Testlib/Env.hs | 2 +- 3 files changed, 17 insertions(+), 7 deletions(-) diff --git a/.envrc b/.envrc index d9a16210890..b7b3f2c35fd 100644 --- a/.envrc +++ b/.envrc @@ -59,7 +59,7 @@ export AWS_ACCESS_KEY_ID="dummykey" export AWS_SECRET_ACCESS_KEY="dummysecret" # integration test suite timeout -export TEST_TIMEOUT_SECONDS=5 +export TEST_TIMEOUT_SECONDS=2 # allow local .envrc overrides [[ -f .envrc.local ]] && source_env .envrc.local diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index aa784753d66..8d170b789b7 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,5 +1,6 @@ -{-# OPTIONS_GHC -Wwarn #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wwarn #-} + {-# HLINT ignore "Use :" #-} -- This file is part of the Wire Server implementation. @@ -29,7 +30,7 @@ import API.Galley import API.GalleyInternal import Control.Error (MaybeT (MaybeT), runMaybeT) import Control.Lens ((.~), (^?!)) -import Control.Monad.Reader (asks) +import Control.Monad.Reader (asks, local) import Control.Monad.Trans.Class (lift) import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Lazy (LazyByteString) @@ -509,9 +510,18 @@ testLHGetDeviceStatus = 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 +-- and that's why client.remove events arrive really late +-- +-- FUTUREWORK(mangoiv): improve the speed of internal +-- event queuing +setTimeoutTo :: Int -> Env -> Env +setTimeoutTo tSecs env = env {timeOutSeconds = tSecs} + testLHDisableForUser :: App () testLHDisableForUser = - startDynamicBackends [mempty] \[dom] -> do + local (setTimeoutTo 30) $ startDynamicBackends [mempty] \[dom] -> do -- team users -- alice (team owner) and bob (member) (alice, tid, [bob]) <- createTeam dom 2 @@ -629,8 +639,8 @@ testLHNoConsentBlockOne2OneConv (ut -> connectFirst) (ut -> teampeer) (ut -> approveLH) - (ut -> testPendingConnection) = do - startDynamicBackends [mempty] \[dom1] -> do + (ut -> testPendingConnection) = + local (setTimeoutTo 30) $ startDynamicBackends [mempty] \[dom1] -> do -- team users -- alice (team owner) and bob (member) (alice, tid, []) <- createTeam dom1 1 diff --git a/integration/test/Testlib/Env.hs b/integration/test/Testlib/Env.hs index 81ebac371da..3c7b939a44f 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -92,7 +92,7 @@ mkGlobalEnv cfgFile = do tempDir <- Codensity $ withSystemTempDirectory "test" timeOutSeconds <- liftIO $ - fromMaybe 90 . (readMaybe @Int =<<) <$> lookupEnv "TEST_TIMEOUT_SECONDS" + fromMaybe 10 . (readMaybe @Int =<<) <$> lookupEnv "TEST_TIMEOUT_SECONDS" pure GlobalEnv { gServiceMap = sm, From a193a78755a36175995b395a8aa96501af6d2b06 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 21 Feb 2024 12:53:45 +0100 Subject: [PATCH 17/21] [fix] some minor fixups --- .hlint.yaml | 1 + integration/test/Notifications.hs | 87 +++++++++++++++++++++--------- integration/test/Test/LegalHold.hs | 43 +++++++-------- 3 files changed, 84 insertions(+), 47 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 66e3cff5d97..b5b237ee5fa 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -11,6 +11,7 @@ - ignore: { name: Avoid lambda using `infix` } - ignore: { name: Eta reduce } - ignore: { name: Use section } +- ignore: { name: "Use :" } - ignore: { name: Use underscore } # custom rules: diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index cb8ea9ae5b4..79fb628f818 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -2,12 +2,49 @@ module Notifications where import API.Gundeck +import Control.Error (lastMay) import Control.Monad.Extra import Control.Monad.Reader (asks) import GHC.Generics ((:.:) (Comp1, unComp1)) import Testlib.Prelude +import UnliftIO (timeout) import UnliftIO.Concurrent +-- | assert that no notifications with the predicate happen within the timeout +assertNoNotifications :: + (HasCallStack, MakesValue user, MakesValue client) => + -- | the user + user -> + -- | the client of that user + client -> + -- | the last notif + Maybe String -> + -- | the predicate + (Value -> App Bool) -> + App () +assertNoNotifications u uc since0 p = do + ucid <- objId uc + let go since = do + notifs <- + getNotifications u def {client = Just ucid, since = since} + `bindResponse` asList + . (%. "notifications") + . (.json) + partitionM p notifs >>= \case + ([], nonMatching) -> + threadDelay 1_000 *> case nonMatching of + (lastMay -> Just lst) -> objId lst >>= go . Just + _ -> go Nothing + (matching, _) -> do + pj <- prettyJSON matching + assertFailure $ + unlines + [ "Expected no matching events but got:", + pj + ] + Nothing <- asks timeOutSeconds >>= flip timeout (go since0) + pure () + awaitNotifications :: (HasCallStack, MakesValue user, MakesValue client) => user -> @@ -22,30 +59,32 @@ awaitNotifications user client since0 n selector = do tSecs <- asks timeOutSeconds assertAwaitResult =<< go tSecs since0 (AwaitResult False n [] []) where - go 0 _ res = pure res - go timeRemaining since res0 = do - c <- make client & asString - notifs <- - getNotifications - user - def {since = since, client = Just c} - `bindResponse` \resp -> asList (resp.json %. "notifications") - lastNotifId <- case notifs of - [] -> pure since - _ -> Just <$> objId (last notifs) - (matching, notMatching) <- partitionM selector notifs - let matchesSoFar = res0.matches <> matching - res = - res0 - { matches = matchesSoFar, - nonMatches = res0.nonMatches <> notMatching, - success = length matchesSoFar >= res0.nMatchesExpected - } - if res.success - then pure res - else do - threadDelay (1_000_000) - go (timeRemaining - 1) lastNotifId res + go timeRemaining since res0 + | timeRemaining <= 0 = pure res0 + | otherwise = + do + c <- make client & asString + notifs <- + getNotifications + user + def {since = since, client = Just c} + `bindResponse` \resp -> asList (resp.json %. "notifications") + lastNotifId <- case notifs of + [] -> pure since + _ -> Just <$> objId (last notifs) + (matching, notMatching) <- partitionM selector notifs + let matchesSoFar = res0.matches <> matching + res = + res0 + { matches = matchesSoFar, + nonMatches = res0.nonMatches <> notMatching, + success = length matchesSoFar >= res0.nMatchesExpected + } + if res.success + then pure res + else do + threadDelay 1_000 + go (timeRemaining - 1) lastNotifId res awaitNotification :: (HasCallStack, MakesValue user, MakesValue client, MakesValue lastNotifId) => diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 8d170b789b7..0da7f60b0fc 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1,8 +1,3 @@ -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# OPTIONS_GHC -Wwarn #-} - -{-# HLINT ignore "Use :" #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2023 Wire Swiss GmbH @@ -319,15 +314,12 @@ testLHRequestDevice = requestLegalHoldDevice tid alice bob >>= assertStatus 201 statusShouldbe "pending" - -- FIXME(mangoiv): we send two notifications to the client - -- which I'm pretty sure is not correct - -- 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" - -- TODO(mangoiv): test if prekeys are in cassandra? - [bobc1, bobc2] <- replicateM 2 do objId $ addClient bob def `bindResponse` getJSON 201 for_ [bobc1, bobc2] \client -> @@ -380,15 +372,13 @@ testLHApproveDevice = do (alice, tid, [bob, charlie]) <- createTeam dom 3 -- ollie the outsider - -- ollie <- do - -- o <- randomUser dom def - -- connectTwoUsers o alice - -- pure o + ollie <- do + o <- randomUser dom def + connectTwoUsers o alice + pure o -- sandy the stranger - -- sandy <- randomUser dom def - -- - -- for sandy and ollie see below + sandy <- randomUser dom def legalholdWhitelistTeam tid alice >>= assertStatus 200 -- TODO(mangoiv): it seems like correct behaviour to throw a 412 @@ -439,11 +429,18 @@ testLHApproveDevice = do >>= renewToken bob >>= assertStatus 200 - -- TODO(mangoiv): more CQL checks? - -- also look at whether it makes sense to check the client id of the - -- legalhold device... + bobId <- objId bob + lhdId <- + BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do + [lhd] <- + resp.json %. bobId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + lhd %. "id" & asString + 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 @@ -459,9 +456,9 @@ testLHApproveDevice = do client <- objId $ addClient user def `bindResponse` getJSON 201 awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do notif %. "payload.0.id" `shouldMatch` objId bob - --- TODO(mangoiv): there's no reasonable check that sandy and ollie don't get any notifs --- as we never know when to timeout as we don't have any consistency guarantees + for_ [ollie, sandy] \outsider -> do + outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201 + assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif testLHGetDeviceStatus :: App () testLHGetDeviceStatus = From df9ce7f6fe7e49b5b66fb1dbc99e47de8c85f0fe Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 21 Feb 2024 12:56:32 +0100 Subject: [PATCH 18/21] [feat] change location for `local`, fix bug in time measuring for notifs --- integration/test/Notifications.hs | 2 +- integration/test/Test/LegalHold.hs | 11 ++++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 79fb628f818..f5aa92c30af 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -56,7 +56,7 @@ awaitNotifications :: (Value -> App Bool) -> App [Value] awaitNotifications user client since0 n selector = do - tSecs <- asks timeOutSeconds + tSecs <- asks ((* 1000) . timeOutSeconds) assertAwaitResult =<< go tSecs since0 (AwaitResult False n [] []) where go timeRemaining since res0 diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 0da7f60b0fc..5ed502b435a 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -518,7 +518,7 @@ setTimeoutTo tSecs env = env {timeOutSeconds = tSecs} testLHDisableForUser :: App () testLHDisableForUser = - local (setTimeoutTo 30) $ startDynamicBackends [mempty] \[dom] -> do + startDynamicBackends [mempty] \[dom] -> do -- team users -- alice (team owner) and bob (member) (alice, tid, [bob]) <- createTeam dom 2 @@ -549,7 +549,7 @@ testLHDisableForUser = && req.pathInfo == (T.pack <$> ["legalhold", "remove"]) mzero - void do + void $ local (setTimeoutTo 90) do awaitNotification bob bobc noValue isUserClientRemoveNotif *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif @@ -637,7 +637,7 @@ testLHNoConsentBlockOne2OneConv (ut -> teampeer) (ut -> approveLH) (ut -> testPendingConnection) = - local (setTimeoutTo 30) $ startDynamicBackends [mempty] \[dom1] -> do + startDynamicBackends [mempty] \[dom1] -> do -- team users -- alice (team owner) and bob (member) (alice, tid, []) <- createTeam dom1 1 @@ -772,8 +772,9 @@ testLHNoConsentBlockOne2OneConv doDisableLH for_ mbLHDevice \lhd -> - awaitNotification alice alicec noValue isUserClientRemoveNotif >>= \notif -> - notif %. "payload.0.client.id" `shouldMatch` 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 From 25cf9bfd5110a0a66c6a3b3511590460c3a2d7ca Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Wed, 21 Feb 2024 15:07:19 +0100 Subject: [PATCH 19/21] Update integration/test/Testlib/PTest.hs Co-authored-by: Matthias Fischmann --- integration/test/Testlib/PTest.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Testlib/PTest.hs b/integration/test/Testlib/PTest.hs index 3aa16c6fcc8..0364232dad5 100644 --- a/integration/test/Testlib/PTest.hs +++ b/integration/test/Testlib/PTest.hs @@ -51,7 +51,7 @@ pattern TaggedBool a = MkTagged a {-# COMPLETE TaggedBool #-} --- | only works for toplevel types +-- | only works for outer-most use of `Tagged` (not: `Maybe (Tagged "bla" Bool)`) -- -- >>> testCases @(Tagged "bla" Bool) instance (GEnum (Rep a), KnownSymbol s, Generic a) => TestCases (Tagged s a) where From fe70861368bb8294267c6316d23942aac6998b27 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Thu, 22 Feb 2024 14:49:53 +0100 Subject: [PATCH 20/21] [fix] implement all the suggestions by @fisx --- integration/test/API/Brig.hs | 7 +- integration/test/API/BrigInternal.hs | 1 + integration/test/API/Galley.hs | 18 ++ integration/test/API/GalleyInternal.hs | 3 + integration/test/Notifications.hs | 18 -- integration/test/SetupHelpers.hs | 38 ++++ integration/test/Test/LegalHold.hs | 171 ++++++++---------- .../test/Testlib/MockIntegrationService.hs | 32 +++- 8 files changed, 159 insertions(+), 129 deletions(-) diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index e2ada6779c7..908a0db996d 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -131,6 +131,7 @@ getUserByHandle user domain handle = do joinHttpPath ["users", "by-handle", domainStr, handle] submit "GET" req +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_clients__client_ getClient :: (HasCallStack, MakesValue user, MakesValue client) => user -> @@ -143,12 +144,14 @@ getClient u cli = do joinHttpPath ["clients", c] submit "GET" req +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/delete_self deleteUser :: (HasCallStack, MakesValue user) => user -> App Response deleteUser user = do req <- baseRequest user Brig Versioned "/self" submit "DELETE" $ req & addJSONObject ["password" .= defPassword] +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_clients addClient :: (HasCallStack, MakesValue user) => user -> @@ -319,9 +322,7 @@ uploadKeyPackages cid kps = do "/mls/key-packages/self/" <> cid.client submit "POST" - do - req - & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps] + (req & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps]) claimKeyPackagesWithParams :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> [(String, String)] -> App Response claimKeyPackagesWithParams suite u v params = do diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index d140df32a1a..5eef85edea8 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -237,6 +237,7 @@ addClient user args = do val <- mkAddClientValue args submit "POST" $ req & addJSONObject val +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients_full getClientsFull :: (HasCallStack, MakesValue users, MakesValue uid) => uid -> users -> App Response getClientsFull user users = do val <- make users diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 2618a199c0a..5def97cc126 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -579,6 +579,7 @@ putTeamProperties tid caller properties = do req ) +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/get_teams__tid__legalhold__uid_ legalholdUserStatus :: (HasCallStack, MakesValue tid, MakesValue user, MakesValue owner) => tid -> owner -> user -> App Response legalholdUserStatus tid ownerid user = do tidS <- asString tid @@ -638,6 +639,8 @@ approveLegalHoldDevice :: (HasCallStack, MakesValue tid, MakesValue uid) => tid approveLegalHoldDevice tid uid = approveLegalHoldDevice' tid uid uid -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve +-- +-- useful for testing unauthorized requests approveLegalHoldDevice' :: (HasCallStack, MakesValue tid, MakesValue uid, MakesValue forUid) => tid -> uid -> forUid -> String -> App Response approveLegalHoldDevice' tid uid forUid pwd = do tidStr <- asString tid @@ -659,3 +662,18 @@ getLegalHoldStatus tid zusr = do uidStr <- asString $ zusr %. "id" req <- baseRequest zusr Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr]) submit "GET" req + +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__features_legalhold +putLegalholdStatus :: + (HasCallStack, MakesValue tid, MakesValue usr) => + tid -> + usr -> + -- | the status to put to + String -> + App Response +putLegalholdStatus tid usr status = do + tidStr <- asString tid + + baseRequest usr Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) + >>= submit "PUT" + . addJSONObject ["status" .= status, "ttl" .= "unlimited"] diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index f2688c31062..4b5ad4cc970 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -59,18 +59,21 @@ getFederationStatus user domains = "GET" $ req & addJSONObject ["domains" .= domainList] +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/put_i_legalhold_whitelisted_teams__tid_ legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response legalholdWhitelistTeam tid uid = do tidStr <- asString tid req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] submit "PUT" req +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/get_i_legalhold_whitelisted_teams__tid_ legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response legalholdIsTeamInWhitelist tid uid = do tidStr <- asString tid req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr] submit "GET" req +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/galley/#/galley/get_i_teams__tid__features_legalhold legalholdIsEnabled :: (HasCallStack, MakesValue tid, MakesValue uid) => tid -> uid -> App Response legalholdIsEnabled tid uid = do tidStr <- asString tid diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index f5aa92c30af..b82fca54b29 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -5,7 +5,6 @@ import API.Gundeck import Control.Error (lastMay) import Control.Monad.Extra import Control.Monad.Reader (asks) -import GHC.Generics ((:.:) (Comp1, unComp1)) import Testlib.Prelude import UnliftIO (timeout) import UnliftIO.Concurrent @@ -176,23 +175,6 @@ isUserLegalholdDisabledNotif = notifTypeIsEqual "user.legalhold-disable" isUserConnectionNotif :: MakesValue a => a -> App Bool isUserConnectionNotif = notifTypeIsEqual "user.connection" --- | compose two predicates on notifications with a boolean relation -notifBoolRel :: MakesValue a => (Bool -> Bool -> Bool) -> (a -> App Bool) -> (a -> App Bool) -> a -> App Bool -notifBoolRel rel p1 p2 = unComp1 do - rel <$> Comp1 p1 <*> Comp1 p2 - --- | compose two predicates on notifications with a '(||)' -notifOr :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool -notifOr = notifBoolRel (||) - -infixr 2 `notifOr` - --- | compose two predicates on notifications with a '(&&)' -notifAnd :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool -notifAnd = notifBoolRel (&&) - -infixr 3 `notifAnd` - assertLeaveNotification :: ( HasCallStack, MakesValue fromUser, diff --git a/integration/test/SetupHelpers.hs b/integration/test/SetupHelpers.hs index 2f765cea618..7a9eab93257 100644 --- a/integration/test/SetupHelpers.hs +++ b/integration/test/SetupHelpers.hs @@ -7,6 +7,7 @@ import API.Brig import API.BrigInternal import API.Common import API.Galley +import API.GalleyInternal (legalholdWhitelistTeam) import Control.Monad.Reader import Crypto.Random (getRandomBytes) import Data.Aeson hiding ((.=)) @@ -18,6 +19,7 @@ import Data.Function import Data.UUID.V1 (nextUUID) import Data.UUID.V4 (nextRandom) import GHC.Stack +import Testlib.MockIntegrationService (mkLegalHoldSettings) import Testlib.Prelude randomUser :: (HasCallStack, MakesValue domain) => domain -> CreateUser -> App Value @@ -276,3 +278,39 @@ setupProvider u np@(NewProvider {..}) = do pure (k, c) activateProvider dom key code loginProvider dom newProviderEmail pass $> provider + +-- | setup a legalhold device for @uid@, authorised by @owner@ +-- at the specified port +setUpLHDevice :: + (HasCallStack, MakesValue tid, MakesValue owner, MakesValue uid) => + tid -> + owner -> + uid -> + -- | the port the LH service is running on + Int -> + App () +setUpLHDevice tid alice bob lhPort = do + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + -- 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 + +lhDeviceIdOf :: MakesValue user => user -> App String +lhDeviceIdOf bob = do + bobId <- objId bob + getClientsFull bob [bobId] `bindResponse` \resp -> + do + resp.json %. bobId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + >>= assertOne + >>= (%. "id") + >>= asString diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 5ed502b435a..af2968206f8 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -294,9 +294,9 @@ testLHRequestDevice = lpk <- getLastPrekey pks <- replicateM 3 getPrekey - withMockServer (lhMockApp' $ Just (lpk, pks)) \lhPort _chan -> do - let statusShouldbe :: String -> App () - statusShouldbe status = + 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 @@ -304,21 +304,21 @@ testLHRequestDevice = -- the user has not agreed to be under legalhold for_ [alice, bob] \requester -> do reqNotEnabled requester bob - statusShouldbe "no_consent" + statusShouldBe "no_consent" legalholdWhitelistTeam tid alice >>= assertSuccess postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) >>= assertSuccess - statusShouldbe "disabled" + statusShouldBe "disabled" requestLegalHoldDevice tid alice bob >>= assertStatus 201 - statusShouldbe "pending" + 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" + statusShouldBe "pending" [bobc1, bobc2] <- replicateM 2 do objId $ addClient bob def `bindResponse` getJSON 201 @@ -342,28 +342,6 @@ checkChanVal :: HasCallStack => Chan (t, LazyByteString) -> (Value -> MaybeT App checkChanVal chan match = checkChan chan \(_, bs) -> runMaybeT do MaybeT (pure (decode bs)) >>= match -setUpLHDevice :: - (HasCallStack, MakesValue tid, MakesValue owner, MakesValue uid) => - tid -> - owner -> - uid -> - -- | the port the LH service is running on - Int -> - App () -setUpLHDevice tid alice bob lhPort = do - legalholdWhitelistTeam tid alice - >>= assertStatus 200 - - -- 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 - testLHApproveDevice :: App () testLHApproveDevice = do startDynamicBackends [mempty] \[dom] -> do @@ -381,10 +359,6 @@ testLHApproveDevice = do sandy <- randomUser dom def legalholdWhitelistTeam tid alice >>= assertStatus 200 - -- TODO(mangoiv): it seems like correct behaviour to throw a 412 - -- here, as we can only approve a device if we're in the pending - -- state. however, the old tests passed with a 403 which makes - -- this suspicious. approveLegalHoldDevice tid (bob %. "qualified_id") defPassword >>= assertLabel 412 "legalhold-not-pending" @@ -429,14 +403,7 @@ testLHApproveDevice = do >>= renewToken bob >>= assertStatus 200 - bobId <- objId bob - lhdId <- - BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do - [lhd] <- - resp.json %. bobId - & asList - >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) - lhd %. "id" & asString + lhdId <- lhDeviceIdOf bob legalholdUserStatus tid alice bob `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 @@ -474,38 +441,39 @@ testLHGetDeviceStatus = lpk <- getLastPrekey pks <- replicateM 3 getPrekey - withMockServer (lhMockApp' (Just (lpk, 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 + 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 + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 - approveLegalHoldDevice tid bob defPassword - >>= assertStatus 200 + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 - legalholdUserStatus tid alice bob `bindResponse` \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. "status" `shouldMatch` "enabled" - resp.json %. "last_prekey" `shouldMatch` lpk - -- TODO(mangoiv): where do we take the LH device client - -- id from?? - -- resp.json %. "client.id" `shouldMatch` _ + 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 @@ -553,7 +521,14 @@ testLHDisableForUser = awaitNotification bob bobc noValue isUserClientRemoveNotif *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif --- TODO(mangoiv): assert zero legalhold devices + bobId <- objId bob + lhClients <- + BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do + resp.json %. bobId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + + shouldBeEmpty lhClients testLHEnablePerTeam :: App () testLHEnablePerTeam = do @@ -568,15 +543,12 @@ testLHEnablePerTeam = do withMockServer lhMockApp \lhPort _chan -> do setUpLHDevice tid alice bob lhPort - tidStr <- asString tid legalholdUserStatus tid alice bob `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` "enabled" - baseRequest alice Galley Versioned (joinHttpPath ["teams", tidStr, "features", "legalhold"]) - >>= submit "PUT" - . addJSONObject ["status" .= "disabled", "ttl" .= "unlimited"] + putLegalholdStatus tid alice "disabled" `bindResponse` assertLabel 403 "legalhold-whitelisted-only" -- the put doesn't have any influence on the status being "enabled" @@ -591,8 +563,8 @@ testLHGetMembersIncludesStatus = do -- alice (team owner) and bob (member) (alice, tid, [bob]) <- createTeam dom 2 - let statusShouldbe :: String -> App () - statusShouldbe status = do + let statusShouldBe :: String -> App () + statusShouldBe status = do getTeamMembers alice tid `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 [bobMember] <- @@ -600,9 +572,9 @@ testLHGetMembersIncludesStatus = do (==) <$> asString (u %. "user") <*> objId bob bobMember %. "legalhold_status" `shouldMatch` status - statusShouldbe "no_consent" + statusShouldBe "no_consent" withMockServer lhMockApp \lhPort _chan -> do - statusShouldbe "no_consent" + statusShouldBe "no_consent" legalholdWhitelistTeam tid alice >>= assertStatus 200 @@ -612,31 +584,28 @@ testLHGetMembersIncludesStatus = do >>= assertStatus 201 -- legalhold has been requested but is disabled - statusShouldbe "disabled" + statusShouldBe "disabled" requestLegalHoldDevice tid alice bob >>= assertStatus 201 -- legalhold has been set to pending after requesting device - statusShouldbe "pending" + statusShouldBe "pending" approveLegalHoldDevice tid bob defPassword >>= assertStatus 200 -- bob has accepted the legalhold device - statusShouldbe "enabled" + statusShouldBe "enabled" type TB s = TaggedBool s -ut :: TB s -> Bool -ut = unTagged - testLHNoConsentBlockOne2OneConv :: TB "connect first" -> TB "team peer" -> TB "approve LH" -> TB "test pending connection" -> App () testLHNoConsentBlockOne2OneConv - (ut -> connectFirst) - (ut -> teampeer) - (ut -> approveLH) - (ut -> testPendingConnection) = + (MkTagged connectFirst) + (MkTagged teampeer) + (MkTagged approveLH) + (MkTagged testPendingConnection) = startDynamicBackends [mempty] \[dom1] -> do -- team users -- alice (team owner) and bob (member) @@ -666,15 +635,7 @@ testLHNoConsentBlockOne2OneConv resp.status `shouldMatchInt` 200 resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" if approveLH - then do - aliceId <- objId alice - BrigI.getClientsFull alice [aliceId] `bindResponse` \resp -> do - [lhd] <- - resp.json %. aliceId - & asList - >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) - lhdid <- lhd %. "id" & asString - pure (Just lhdid) + then Just <$> lhDeviceIdOf alice else pure Nothing doDisableLH :: HasCallStack => App () @@ -744,7 +705,21 @@ testLHNoConsentBlockOne2OneConv bobc2 <- objId $ addClient bob def >>= getJSON 201 - let sendMessageFromBobToAlice :: HasCallStack => (String -> [String]) -> (Response -> App ()) -> App () + 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 <- diff --git a/integration/test/Testlib/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs index 49f0a417ae4..c7c279211e4 100644 --- a/integration/test/Testlib/MockIntegrationService.hs +++ b/integration/test/Testlib/MockIntegrationService.hs @@ -1,4 +1,4 @@ -module Testlib.MockIntegrationService (withMockServer, lhMockApp', lhMockApp, mkLegalHoldSettings) where +module Testlib.MockIntegrationService (withMockServer, lhMockAppWithPrekeys, lhMockApp, mkLegalHoldSettings, CreateMock (..)) where import Control.Monad.Catch import Control.Monad.Reader @@ -118,21 +118,33 @@ withMockServer mkApp go = withFreePortAnyAddr $ \(sPort, sock) -> do Nothing -> error . show =<< poll srv lhMockApp :: Chan (Wai.Request, LBS.ByteString) -> LiftedApplication -lhMockApp = lhMockApp' Nothing +lhMockApp = lhMockAppWithPrekeys def + +data CreateMock f = MkCreateMock + { -- | how to obtain the next last prekey of a mock app + nextLastPrey :: f Value, + -- | how to obtain some prekeys of a mock app + somePrekeys :: f [Value] + } + +instance (App ~ f) => Default (CreateMock f) where + def = + MkCreateMock + { nextLastPrey = getLastPrekey, + somePrekeys = replicateM 3 getPrekey + } -- | LegalHold service. Just fake the API, do not maintain any internal state. -lhMockApp' :: Maybe (Value, [Value]) -> Chan (Wai.Request, LBS.ByteString) -> LiftedApplication -lhMockApp' mks ch req cont = withRunInIO \inIO -> do +lhMockAppWithPrekeys :: + CreateMock App -> Chan (Wai.Request, LBS.ByteString) -> LiftedApplication +lhMockAppWithPrekeys mks ch req cont = withRunInIO \inIO -> do reqBody <- Wai.strictRequestBody req writeChan ch (req, reqBody) inIO do (nextLastPrekey, threePrekeys) <- - case mks of - Nothing -> - (,) - <$> getLastPrekey - <*> replicateM 3 getPrekey - Just pks -> pure pks + (,) + <$> mks.nextLastPrey + <*> mks.somePrekeys case (cs <$> pathInfo req, cs $ requestMethod req, cs @_ @String <$> getRequestHeader "Authorization" req) of (["legalhold", "status"], "GET", _) -> cont respondOk (_, _, Nothing) -> cont missingAuth From ecc35624704b87e1ccf8caeeb7a4507aa0257a5b Mon Sep 17 00:00:00 2001 From: mangoiv Date: Fri, 23 Feb 2024 11:04:18 +0100 Subject: [PATCH 21/21] [chore] add changelog entry --- changelog.d/5-internal/WPB-5687 | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/WPB-5687 diff --git a/changelog.d/5-internal/WPB-5687 b/changelog.d/5-internal/WPB-5687 new file mode 100644 index 00000000000..24f8fcd8e61 --- /dev/null +++ b/changelog.d/5-internal/WPB-5687 @@ -0,0 +1 @@ +port flaking LH tests to new integration and improve the ergonomics of our testing library