From 87283d76012c9281a97478e7e9bc88681016a05c Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Wed, 24 Jul 2024 14:14:12 +0200 Subject: [PATCH] WPB-9733 backport flakiness fixes (#4168) * WPB-5845 guests should not be able to join conversations under legalhold (#3853) * Clean up LH tests (#3830) * Use HasTests to save a few LOC. * Fix/extend client CRUD api. - moved internal add from API.Brig to API.BrigInternal - created API.BrigCommon for data structured needed in both - added public add * Tranlate tests: manually add/delete client. * Fiddle with test case type abstractions. * Remove obsolete test from integration/test/Test/Demo.hs * Unblock release. (#3871) * WIP: [WPB-5687] port flaking LH tests to new integration (#3876) * [fix] use -e flag to abort when `docker-compose` fails * [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 * [feat] port over flaking Legalhold tests and delete them from galley integration * [feat] minor testlib improvements and additions --------- Co-authored-by: Matthias Fischmann * wip * fix integration tests --------- Co-authored-by: fisx Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> --- .hlint.yaml | 1 + changelog.d/3-bug-fixes/WPB-5845 | 1 + changelog.d/5-internal/WPB-5687 | 1 + .../WPB-6254-translate-LH-tests-part-1 | 1 + deploy/dockerephemeral/run.sh | 2 +- integration/integration.cabal | 1 + integration/test/API/Brig.hs | 60 +- integration/test/API/BrigCommon.hs | 44 + integration/test/API/BrigInternal.hs | 20 + integration/test/API/Galley.hs | 69 +- integration/test/API/GalleyInternal.hs | 17 +- integration/test/MLS/Util.hs | 13 +- integration/test/Notifications.hs | 116 +- integration/test/SetupHelpers.hs | 38 + integration/test/Test/Conversation.hs | 50 +- integration/test/Test/Demo.hs | 11 - integration/test/Test/LegalHold.hs | 1019 ++++++++++++----- integration/test/Test/MLS.hs | 2 +- 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 | 21 +- integration/test/Testlib/App.hs | 2 + integration/test/Testlib/Assertions.hs | 2 +- integration/test/Testlib/Env.hs | 2 +- integration/test/Testlib/HTTP.hs | 25 +- integration/test/Testlib/JSON.hs | 13 + .../test/Testlib/MockIntegrationService.hs | 63 +- integration/test/Testlib/ModService.hs | 2 +- integration/test/Testlib/PTest.hs | 117 +- integration/test/Testlib/Types.hs | 5 +- libs/brig-types/src/Brig/Types/User/Event.hs | 5 +- .../brig/test/integration/API/User/Client.hs | 30 +- .../src/Galley/API/LegalHold/Conflicts.hs | 2 +- services/galley/src/Galley/API/Util.hs | 7 +- .../test/integration/API/Teams/LegalHold.hs | 459 +------- 37 files changed, 1263 insertions(+), 1004 deletions(-) create mode 100644 changelog.d/3-bug-fixes/WPB-5845 create mode 100644 changelog.d/5-internal/WPB-5687 create mode 100644 changelog.d/5-internal/WPB-6254-translate-LH-tests-part-1 create mode 100644 integration/test/API/BrigCommon.hs 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/changelog.d/3-bug-fixes/WPB-5845 b/changelog.d/3-bug-fixes/WPB-5845 new file mode 100644 index 00000000000..187771f4622 --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-5845 @@ -0,0 +1 @@ +Guests should not be added to conversations that are under legalhold 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 diff --git a/changelog.d/5-internal/WPB-6254-translate-LH-tests-part-1 b/changelog.d/5-internal/WPB-6254-translate-LH-tests-part-1 new file mode 100644 index 00000000000..adf72fba616 --- /dev/null +++ b/changelog.d/5-internal/WPB-6254-translate-LH-tests-part-1 @@ -0,0 +1 @@ +Translate integration tests: manually add / delete LH device \ No newline at end of file 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 )" diff --git a/integration/integration.cabal b/integration/integration.cabal index e71206e00b1..3fd43a73d59 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -90,6 +90,7 @@ library -- cabal-fmt: expand test exposed-modules: API.Brig + API.BrigCommon API.BrigInternal API.Cargohold API.Common diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 3e01a5401cd..10956be294c 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -1,5 +1,6 @@ module API.Brig where +import API.BrigCommon import API.Common import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base64 as Base64 @@ -130,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 -> @@ -142,58 +144,23 @@ 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] -data AddClient = AddClient - { ctype :: String, - internal :: Bool, - clabel :: String, - model :: String, - prekeys :: Maybe [Value], - lastPrekey :: Maybe Value, - password :: String, - acapabilities :: Maybe [String] - } - -instance Default AddClient where - def = - AddClient - { ctype = "permanent", - internal = False, - clabel = "Test Device", - model = "Test Model", - prekeys = Nothing, - lastPrekey = Nothing, - password = defPassword, - acapabilities = Just ["legalhold-implicit-consent"] - } - --- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients__uid_ +-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_clients addClient :: (HasCallStack, MakesValue user) => user -> AddClient -> App Response addClient user args = do - uid <- objId user - req <- baseRequest user Brig Unversioned $ "/i/clients/" <> uid - pks <- maybe (fmap pure getPrekey) pure args.prekeys - lpk <- maybe getLastPrekey pure args.lastPrekey - submit "POST" $ - req - & addJSONObject - [ "prekeys" .= pks, - "lastkey" .= lpk, - "type" .= args.ctype, - "label" .= args.clabel, - "model" .= args.model, - "password" .= args.password, - "capabilities" .= args.acapabilities - ] + req <- baseRequest user Brig Versioned $ "/clients" + val <- mkAddClientValue args + submit "POST" $ req & addJSONObject val data UpdateClient = UpdateClient { prekeys :: [Value], @@ -230,6 +197,7 @@ updateClient cid args = do <> ["mls_public_keys" .= k | k <- toList args.mlsPublicKeys] ) +-- | https://staging-nginz-https.zinfra.io/v6/api/swagger-ui/#/default/delete_clients__client_ deleteClient :: (HasCallStack, MakesValue user, MakesValue client) => user -> @@ -354,9 +322,7 @@ uploadKeyPackages cid kps = do "/mls/key-packages/self/" <> cid.client submit "POST" - ( 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 @@ -368,7 +334,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 @@ -664,3 +630,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/BrigCommon.hs b/integration/test/API/BrigCommon.hs new file mode 100644 index 00000000000..c38615dd8a2 --- /dev/null +++ b/integration/test/API/BrigCommon.hs @@ -0,0 +1,44 @@ +module API.BrigCommon where + +import API.Common +import Data.Aeson.Types (Pair) +import Data.Maybe +import Testlib.Prelude as Prelude + +data AddClient = AddClient + { ctype :: String, -- "temporary", "permanent", "legalhold" + internal :: Bool, + clabel :: String, + model :: String, + prekeys :: Maybe [Value], + lastPrekey :: Maybe Value, + password :: String, + acapabilities :: Maybe [String] + } + +instance Default AddClient where + def = + AddClient + { ctype = "permanent", + internal = False, + clabel = "Test Device", + model = "Test Model", + prekeys = Nothing, + lastPrekey = Nothing, + password = defPassword, + acapabilities = Just ["legalhold-implicit-consent"] + } + +mkAddClientValue :: AddClient -> App [Pair] +mkAddClientValue args = do + pks <- maybe (fmap pure getPrekey) pure args.prekeys + lpk <- maybe getLastPrekey pure args.lastPrekey + pure + [ "prekeys" .= pks, + "lastkey" .= lpk, + "type" .= args.ctype, + "label" .= args.clabel, + "model" .= args.model, + "password" .= args.password, + "capabilities" .= args.acapabilities + ] diff --git a/integration/test/API/BrigInternal.hs b/integration/test/API/BrigInternal.hs index 03903bfdfee..5eef85edea8 100644 --- a/integration/test/API/BrigInternal.hs +++ b/integration/test/API/BrigInternal.hs @@ -1,5 +1,6 @@ module API.BrigInternal where +import API.BrigCommon import API.Common import qualified Data.Aeson as Aeson import Data.Aeson.Types (Pair) @@ -223,3 +224,22 @@ getProviderActivationCodeInternal dom email = do rawBaseRequest d Brig Unversioned $ joinHttpPath ["i", "provider", "activation-code"] submit "GET" (addQueryParams [("email", email)] req) + +-- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients__uid_ +addClient :: + (HasCallStack, MakesValue user) => + user -> + AddClient -> + App Response +addClient user args = do + uid <- objId user + req <- baseRequest user Brig Unversioned $ "/i/clients/" <> uid + 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 + baseRequest user Brig Unversioned do joinHttpPath ["i", "clients", "full"] + >>= submit "POST" . addJSONObject ["users" .= val] diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 578393cf0c7..900469f0a27 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -243,7 +243,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 @@ -520,6 +520,14 @@ getTeamMembers user tid = do req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tidStr, "members"]) submit "GET" 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 + 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 @@ -527,16 +535,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/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 +-- | 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 - req <- baseRequest owner Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", "settings"]) - newSettingsObj <- make newSettings - submit "POST" (addJSON newSettingsObj req) + 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 = + 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 @@ -550,10 +574,18 @@ 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 +-- +-- 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 - 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) @@ -590,3 +622,18 @@ getTeamFeature user tid featureName = do tidStr <- asString tid req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tidStr, "features", featureName]) 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 daf35201060..ff9843c7a51 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -58,14 +58,16 @@ getFederationStatus user domains = "GET" $ req & addJSONObject ["domains" .= domainList] -legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response -legalholdWhitelistTeam uid tid = do +-- | 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 -legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response -legalholdIsTeamInWhitelist uid tid = do +-- | 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 @@ -77,3 +79,10 @@ setTeamFeatureConfig versioned domain team featureName payload = do p <- make payload req <- baseRequest domain Galley versioned $ joinHttpPath ["teams", tid, "features", fn] submit "PUT" $ req & addJSON p + +-- | 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 + baseRequest uid Galley Unversioned do joinHttpPath ["i", "teams", tidStr, "features", "legalhold"] + >>= submit "GET" diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs index dee0a35c5a9..2a59f980579 100644 --- a/integration/test/MLS/Util.hs +++ b/integration/test/MLS/Util.hs @@ -36,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 @@ -140,15 +139,9 @@ argSubst from to_ s = createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity createWireClient u = do - lpk <- getLastPrekey - c <- addClient u def {lastPrekey = Just lpk} >>= getJSON 201 - mkClientIdentity u c - --- data CredentialType = BasicCredentialType | X509CredentialType --- --- instance MakesValue CredentialType where --- make BasicCredentialType = make "basic" --- make X509CredentialType = make "x509" + addClient u def + >>= getJSON 201 + >>= mkClientIdentity u data InitMLSClient = InitMLSClient {credType :: CredentialType} diff --git a/integration/test/Notifications.hs b/integration/test/Notifications.hs index 9ea53706223..b82fca54b29 100644 --- a/integration/test/Notifications.hs +++ b/integration/test/Notifications.hs @@ -2,11 +2,48 @@ module Notifications where import API.Gundeck +import Control.Error (lastMay) import Control.Monad.Extra import Control.Monad.Reader (asks) 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 -> @@ -18,34 +55,35 @@ 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 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") - 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) => @@ -110,8 +148,32 @@ 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 = 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" + +isUserConnectionNotif :: MakesValue a => a -> App Bool +isUserConnectionNotif = notifTypeIsEqual "user.connection" assertLeaveNotification :: ( HasCallStack, 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/Conversation.hs b/integration/test/Test/Conversation.hs index 67f5327ae9f..9426f1a41c1 100644 --- a/integration/test/Test/Conversation.hs +++ b/integration/test/Test/Conversation.hs @@ -20,7 +20,7 @@ module Test.Conversation where import API.Brig -import API.BrigInternal +import qualified API.BrigInternal as BrigI import API.Galley import API.GalleyInternal import Control.Applicative @@ -41,9 +41,9 @@ testDynamicBackendsFullyConnectedWhenAllowAll = do -- The default setting is 'allowAll' startDynamicBackends [def, def, def] $ \dynDomains -> do [domainA, domainB, domainC] <- pure dynDomains - uidA <- randomUser domainA def {team = True} - uidB <- randomUser domainA def {team = True} - uidC <- randomUser domainA def {team = True} + uidA <- randomUser domainA def {BrigI.team = True} + uidB <- randomUser domainA def {BrigI.team = True} + uidC <- randomUser domainA def {BrigI.team = True} assertConnected uidA domainB domainC assertConnected uidB domainA domainC assertConnected uidC domainA domainB @@ -64,7 +64,7 @@ testDynamicBackendsNotFederating = do setField "optSettings.setFederationStrategy" "allowNone" } startDynamicBackends [overrides, overrides, overrides] $ \[domainA, domainB, domainC] -> do - uidA <- randomUser domainA def {team = True} + uidA <- randomUser domainA def {BrigI.team = True} retryT $ bindResponse (getFederationStatus uidA [domainB, domainC]) @@ -78,14 +78,14 @@ testDynamicBackendsFullyConnectedWhenAllowDynamic = do -- Allowing 'full_search' or any type of search is how we enable federation -- between backends when the federation strategy is 'allowDynamic'. sequence_ - [ createFedConn x (FedConn y "full_search" Nothing) + [ BrigI.createFedConn x (BrigI.FedConn y "full_search" Nothing) | x <- [domainA, domainB, domainC], y <- [domainA, domainB, domainC], x /= y ] - uidA <- randomUser domainA def {team = True} - uidB <- randomUser domainB def {team = True} - uidC <- randomUser domainC def {team = True} + uidA <- randomUser domainA def {BrigI.team = True} + uidB <- randomUser domainB def {BrigI.team = True} + uidC <- randomUser domainC def {BrigI.team = True} let assertConnected u d d' = bindResponse (getFederationStatus u [d, d']) @@ -100,11 +100,11 @@ testDynamicBackendsNotFullyConnected :: HasCallStack => App () testDynamicBackendsNotFullyConnected = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do -- A is connected to B and C, but B and C are not connected to each other - void $ createFedConn domainA $ FedConn domainB "full_search" Nothing - void $ createFedConn domainB $ FedConn domainA "full_search" Nothing - void $ createFedConn domainA $ FedConn domainC "full_search" Nothing - void $ createFedConn domainC $ FedConn domainA "full_search" Nothing - uidA <- randomUser domainA def {team = True} + void $ BrigI.createFedConn domainA $ BrigI.FedConn domainB "full_search" Nothing + void $ BrigI.createFedConn domainB $ BrigI.FedConn domainA "full_search" Nothing + void $ BrigI.createFedConn domainA $ BrigI.FedConn domainC "full_search" Nothing + void $ BrigI.createFedConn domainC $ BrigI.FedConn domainA "full_search" Nothing + uidA <- randomUser domainA def {BrigI.team = True} retryT $ bindResponse (getFederationStatus uidA [domainB, domainC]) @@ -115,7 +115,7 @@ testDynamicBackendsNotFullyConnected = do testFederationStatus :: HasCallStack => App () testFederationStatus = do - uid <- randomUser OwnDomain def {team = True} + uid <- randomUser OwnDomain def {BrigI.team = True} federatingRemoteDomain <- asString OtherDomain let invalidDomain = "c.example.com" -- Does not have any srv records bindResponse @@ -149,10 +149,10 @@ testCreateConversationNonFullyConnected :: HasCallStack => App () testCreateConversationNonFullyConnected = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do -- A is connected to B and C, but B and C are not connected to each other - void $ createFedConn domainA $ FedConn domainB "full_search" Nothing - void $ createFedConn domainB $ FedConn domainA "full_search" Nothing - void $ createFedConn domainA $ FedConn domainC "full_search" Nothing - void $ createFedConn domainC $ FedConn domainA "full_search" Nothing + void $ BrigI.createFedConn domainA $ BrigI.FedConn domainB "full_search" Nothing + void $ BrigI.createFedConn domainB $ BrigI.FedConn domainA "full_search" Nothing + void $ BrigI.createFedConn domainA $ BrigI.FedConn domainC "full_search" Nothing + void $ BrigI.createFedConn domainC $ BrigI.FedConn domainA "full_search" Nothing liftIO $ threadDelay (2 * 1000 * 1000) u1 <- randomUser domainA def @@ -184,10 +184,10 @@ testAddMembersFullyConnectedProteus = do testAddMembersNonFullyConnectedProteus :: HasCallStack => App () testAddMembersNonFullyConnectedProteus = do withFederatingBackendsAllowDynamic $ \(domainA, domainB, domainC) -> do - void $ createFedConn domainA (FedConn domainB "full_search" Nothing) - void $ createFedConn domainB (FedConn domainA "full_search" Nothing) - void $ createFedConn domainA (FedConn domainC "full_search" Nothing) - void $ createFedConn domainC (FedConn domainA "full_search" Nothing) + void $ BrigI.createFedConn domainA (BrigI.FedConn domainB "full_search" Nothing) + void $ BrigI.createFedConn domainB (BrigI.FedConn domainA "full_search" Nothing) + void $ BrigI.createFedConn domainA (BrigI.FedConn domainC "full_search" Nothing) + void $ BrigI.createFedConn domainC (BrigI.FedConn domainA "full_search" Nothing) liftIO $ threadDelay (2 * 1000 * 1000) -- wait for federation status to be updated -- add users @@ -386,7 +386,7 @@ testAddingUserNonFullyConnectedFederation = do -- Ensure that dynamic backend only federates with own domain, but not other -- domain. - void $ createFedConn dynBackend (FedConn own "full_search" Nothing) + void $ BrigI.createFedConn dynBackend (BrigI.FedConn own "full_search" Nothing) alice <- randomUser own def bob <- randomUser other def @@ -818,7 +818,7 @@ testUpdateConversationByRemoteAdmin = do testGuestCreatesConversation :: HasCallStack => App () testGuestCreatesConversation = do - alice <- randomUser OwnDomain def {activate = False} + alice <- randomUser OwnDomain def {BrigI.activate = False} bindResponse (postConversation alice defProteus) $ \resp -> do resp.status `shouldMatchInt` 403 resp.json %. "label" `shouldMatch` "operation-denied" diff --git a/integration/test/Test/Demo.hs b/integration/test/Test/Demo.hs index b99fba73e57..bd45cb3c334 100644 --- a/integration/test/Test/Demo.hs +++ b/integration/test/Test/Demo.hs @@ -17,17 +17,6 @@ import Testlib.ModService.ServiceInstance import Testlib.Prelude import UnliftIO.Directory --- | Legalhold clients cannot be deleted. -testCantDeleteLHClient :: HasCallStack => App () -testCantDeleteLHClient = do - user <- randomUser OwnDomain def - client <- - BrigP.addClient user def {BrigP.ctype = "legalhold", BrigP.internal = True} - >>= getJSON 201 - - bindResponse (BrigP.deleteClient user client) $ \resp -> do - resp.status `shouldMatchInt` 400 - -- | Deleting unknown clients should fail with 404. testDeleteUnknownClient :: HasCallStack => App () testDeleteUnknownClient = do diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 09f0f8b4cad..af2968206f8 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -18,15 +18,25 @@ module Test.LegalHold where import API.Brig +import API.BrigCommon as BrigC +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.Reader (asks, local) +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 Network.Wai (Request (pathInfo, requestMethod)) +import Notifications import Numeric.Lens (hex) import qualified Proto.Otr as Proto import qualified Proto.Otr_Fields as Proto @@ -34,318 +44,733 @@ import SetupHelpers import Testlib.MockIntegrationService import Testlib.Prekeys import Testlib.Prelude +import UnliftIO (Chan, readChan, timeout) -abstractTestLHMessageExchange :: HasCallStack => String -> Int -> Bool -> Bool -> Bool -> Bool -> App () -abstractTestLHMessageExchange dom lhPort clients1New clients2New consentFrom1 consentFrom2 = do - (owner, tid, [mem1, mem2]) <- createTeam dom 3 - - let clientSettings :: Bool -> AddClient - clientSettings allnew = - if allnew - then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) - else def {acapabilities = Nothing} - client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 - _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 - - void $ legalholdWhitelistTeam owner tid >>= assertSuccess - void $ legalholdIsTeamInWhitelist owner tid >>= assertSuccess - void $ postLegalHoldSettings owner tid (mkLegalHoldSettings lhPort) >>= getJSON 201 - - conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 - - requestLegalHoldDevice tid owner mem1 >>= assertSuccess - requestLegalHoldDevice tid owner mem2 >>= assertSuccess - when consentFrom1 $ do - approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess - when consentFrom2 $ do - approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess - - let getCls :: Value -> App [String] - getCls mem = do - res <- getClientsQualified mem dom mem - val <- getJSON 200 res - cls <- asList val - objId `mapM` cls - cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. - cs2 :: [String] <- getCls mem2 - - length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 - length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 - - void $ do - successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" - let successfulMsg = - Proto.defMessage @Proto.QualifiedNewOtrMessage - & #sender . Proto.client .~ (client1 ^?! hex) - & #recipients .~ [successfulMsgForOtherUsers] - & #reportAll .~ Proto.defMessage - bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do - let check :: HasCallStack => Int -> Maybe String -> App () - check status Nothing = do - resp.status `shouldMatchInt` status - check status (Just label) = do - resp.status `shouldMatchInt` status - resp.json %. "label" `shouldMatch` label - - let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): - _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - (_, _, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, _, _) -> - if consentFrom1 /= consentFrom2 - then -- no old clients, but users disagree on LH +testLHPreventAddingNonConsentingUsers :: App () +testLHPreventAddingNonConsentingUsers = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + (owner, tid, [alice, alex]) <- createTeam dom 3 + + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= assertStatus 201 + + george <- randomUser dom def + georgeQId <- george %. "qualified_id" + connectUsers =<< forM [alice, george] make + connectUsers =<< forM [alex, george] make + conv <- postConversation alice (defProteus {qualifiedUsers = [alex], team = Just tid}) >>= getJSON 201 + + -- the guest should be added to the conversation + bindResponse (addMembers alice conv def {users = [georgeQId]}) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "type" `shouldMatch` "conversation.member-join" + + -- assert that the guest is in the conversation + checkConvHasOtherMembers conv alice [alex, george] + + -- now request legalhold for alex (but not alice) + requestLegalHoldDevice tid owner alex >>= assertSuccess + + -- the guest should be removed from the conversation + checkConvHasOtherMembers conv alice [alex] + + -- it should not be possible neither for alex nor for alice to add the guest back + addMembers alex conv def {users = [georgeQId]} + >>= assertLabel 403 "not-connected" + + addMembers alice conv def {users = [georgeQId]} + >>= assertLabel 403 "missing-legalhold-consent" + where + checkConvHasOtherMembers :: HasCallStack => Value -> Value -> [Value] -> App () + checkConvHasOtherMembers conv u us = + bindResponse (getConversation u conv) $ \resp -> do + resp.status `shouldMatchInt` 200 + mems <- + resp.json %. "members.others" & asList >>= traverse \m -> do + m %. "qualified_id" + mems `shouldMatchSet` forM us (\m -> m %. "qualified_id") + +testLHMessageExchange :: + HasCallStack => + TaggedBool "clients1New" -> + TaggedBool "clients2New" -> + TaggedBool "consentFrom1" -> + TaggedBool "consentFrom2" -> + App () +testLHMessageExchange (TaggedBool clients1New) (TaggedBool clients2New) (TaggedBool consentFrom1) (TaggedBool consentFrom2) = do + startDynamicBackends [mempty] $ \[dom] -> do + withMockServer lhMockApp $ \lhPort _chan -> do + (owner, tid, [mem1, mem2]) <- createTeam dom 3 + + let clientSettings :: Bool -> AddClient + clientSettings allnew = + if allnew + then def -- (`{acapabilities = Just ["legalhold-implicit-consent"]}` is the default) + else def {acapabilities = Nothing} + client1 <- objId $ addClient (mem1 %. "qualified_id") (clientSettings clients1New) >>= getJSON 201 + _client2 <- objId $ addClient (mem2 %. "qualified_id") (clientSettings clients2New) >>= getJSON 201 + + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + postLegalHoldSettings tid owner (mkLegalHoldSettings lhPort) >>= assertStatus 201 + + conv <- postConversation mem1 (defProteus {qualifiedUsers = [mem2], team = Just tid}) >>= getJSON 201 + + requestLegalHoldDevice tid owner mem1 >>= assertSuccess + requestLegalHoldDevice tid owner mem2 >>= assertSuccess + when consentFrom1 $ do + approveLegalHoldDevice tid (mem1 %. "qualified_id") defPassword >>= assertSuccess + when consentFrom2 $ do + approveLegalHoldDevice tid (mem2 %. "qualified_id") defPassword >>= assertSuccess + + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem dom mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + cs1 :: [String] <- getCls mem1 -- it's ok to include the sender, backend will filter it out. + cs2 :: [String] <- getCls mem2 + + length cs1 `shouldMatchInt` if consentFrom1 then 2 else 1 + length cs2 `shouldMatchInt` if consentFrom2 then 2 else 1 + + do + successfulMsgForOtherUsers <- mkProteusRecipients mem1 [(mem1, cs1), (mem2, cs2)] "hey there" + let successfulMsg = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (client1 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + bindResponse (postProteusMessage mem1 (conv %. "qualified_id") successfulMsg) $ \resp -> do + let check :: HasCallStack => Int -> Maybe String -> App () + check status Nothing = do + resp.status `shouldMatchInt` status + check status (Just label) = do + resp.status `shouldMatchInt` status + resp.json %. "label" `shouldMatch` label + + let -- there are two equally valid ways to write this down (feel free to remove one if it gets in your way): + _oneWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + (_, _, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, _, _) -> + if consentFrom1 /= consentFrom2 + then -- no old clients, but users disagree on LH + check 403 (Just "missing-legalhold-consent") + else -- everybody likes LH + check 201 Nothing + _ -> + -- everything else + check 403 (Just "missing-legalhold-consent-old-clients") + + theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of + -- NB: "consent" always implies "has an active LH device" + (False, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (False, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, False, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, False, False) -> + -- no LH in the picture + check 201 Nothing + (True, True, False, True) -> + -- all clients new, no consent from sender, recipient has LH device check 403 (Just "missing-legalhold-consent") - else -- everybody likes LH + (True, True, True, False) -> + -- all clients new, no consent from recipient, sender has LH device + check 403 (Just "missing-legalhold-consent") + (True, True, True, True) -> + -- everybody happy with LH check 201 Nothing - _ -> - -- everything else - check 403 (Just "missing-legalhold-consent-old-clients") - - theOtherWay = case (clients1New, clients2New, consentFrom1, consentFrom2) of - -- NB: "consent" always implies "has an active LH device" - (False, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (False, False, False, True) -> - -- sender has old clients and not given consent, recipient has LH device - check 403 (Just "missing-legalhold-consent-old-clients") - (False, False, True, False) -> - -- recipient has old clients and not given consent, sender has LH device - check 403 (Just "missing-legalhold-consent-old-clients") - (False, False, True, True) -> - -- both sender, recipient have has old clients and LH devices, but given consent - check 403 (Just "missing-legalhold-consent-old-clients") - (False, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (False, True, False, True) -> - -- sender has old clients and not given consent, recipient has LH device (and only new clients) - check 403 (Just "missing-legalhold-consent-old-clients") - (False, True, True, False) -> - -- sender has old clients but given consent and LH device; recipient has not given consent - check 403 (Just "missing-legalhold-consent-old-clients") - (False, True, True, True) -> - -- sender has old clients but given consent and LH device; recipient has LH device (and only new clients) - check 403 (Just "missing-legalhold-consent-old-clients") - (True, False, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, False, False, True) -> - -- recipient has given consent and LH device, but old clients (and sender has not given consent) - check 403 (Just "missing-legalhold-consent-old-clients") - (True, False, True, False) -> - -- recipient has old clients and not given consent, sender has LH device - check 403 (Just "missing-legalhold-consent-old-clients") - (True, False, True, True) -> - -- old clients with recipient, LH devices by all - check 403 (Just "missing-legalhold-consent-old-clients") - (True, True, False, False) -> - -- no LH in the picture - check 201 Nothing - (True, True, False, True) -> - -- all clients new, no consent from sender, recipient has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, False) -> - -- all clients new, no consent from recipient, sender has LH device - check 403 (Just "missing-legalhold-consent") - (True, True, True, True) -> - -- everybody happy with LH - check 201 Nothing - - -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! - theOtherWay + _ -> pure () + + -- _oneWay -- run this if you want to make sure both ways are equivalent, but please don't commit! + theOtherWay data TestClaimKeys = TCKConsentMissing -- (team not whitelisted, that is) - | TCKOldClient | TCKConsentAndNewClients - deriving (Bounded, Enum) + deriving (Show, Generic) -- | Cannot fetch prekeys of LH users if requester has not given consent or has old clients. -abstractTestLHClaimKeys :: String -> Int -> TestClaimKeys -> App () -abstractTestLHClaimKeys dom lhPort testmode = do - (lowner, ltid, [lmem]) <- createTeam dom 2 - (powner, ptid, [pmem]) <- createTeam dom 2 - - legalholdWhitelistTeam lowner ltid >>= assertSuccess - legalholdIsTeamInWhitelist lowner ltid >>= assertSuccess - void $ postLegalHoldSettings lowner ltid (mkLegalHoldSettings lhPort) >>= getJSON 201 - - requestLegalHoldDevice ltid lowner lmem >>= assertSuccess - approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess - - let addc caps = addClient pmem (settings caps) >>= assertSuccess - settings caps = - def - { prekeys = Just $ take 10 somePrekeysRendered, - lastPrekey = Just $ head someLastPrekeysRendered, - acapabilities = caps - } - in case testmode of - TCKConsentMissing -> - addc $ Just ["legalhold-implicit-consent"] - TCKOldClient -> do - addc Nothing - void $ legalholdWhitelistTeam powner ptid >>= assertSuccess - void $ legalholdIsTeamInWhitelist powner ptid >>= assertSuccess - TCKConsentAndNewClients -> do - addc $ Just ["legalhold-implicit-consent"] - void $ legalholdWhitelistTeam powner ptid >>= assertSuccess - void $ legalholdIsTeamInWhitelist powner ptid >>= assertSuccess - - llhdev :: String <- do - let getCls :: Value -> App [String] - getCls mem = do - res <- getClientsQualified mem dom mem - val <- getJSON 200 res - cls <- asList val - objId `mapM` cls - getCls lmem <&> \case - [d] -> d - bad -> error $ show bad - - let assertResp :: HasCallStack => Response -> App () - assertResp resp = case testmode of - TCKConsentMissing -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "missing-legalhold-consent" - TCKOldClient -> do - resp.status `shouldMatchInt` 403 - resp.json %. "label" `shouldMatch` "missing-legalhold-consent-old-clients" - TCKConsentAndNewClients -> do - resp.status `shouldMatchInt` 200 - - bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp - bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp - - slmemdom <- asString $ lmem %. "qualified_id.domain" - slmemid <- asString $ lmem %. "qualified_id.id" - let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] - bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp - --- | FUTUREWORK: if you run this test, you will get "Out of prekeys" errors, so we split it up --- in 19 individual tests that each seem to reset the pool. -_testLegalhold :: App () -_testLegalhold = do - -- we spawn services ourselves here so galley can reach the LH service (which is also - -- spawned) under localhost. if you want to limit yourself to running only some of these - -- locally, write an ad-hoc test case that you don't commit. - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - sequence_ $ abstractTestLHMessageExchange dom lhPort <$> [minBound ..] <*> [minBound ..] <*> [minBound ..] <*> [minBound ..] - abstractTestLHClaimKeys dom lhPort `mapM_` [minBound ..] - -testLHMessageExchange01 :: App () -testLHMessageExchange01 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False False False False - -testLHMessageExchange02 :: App () -testLHMessageExchange02 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False False False True - -testLHMessageExchange03 :: App () -testLHMessageExchange03 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False False True False - -testLHMessageExchange04 :: App () -testLHMessageExchange04 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False False True True - -testLHMessageExchange05 :: App () -testLHMessageExchange05 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False True False False - -testLHMessageExchange06 :: App () -testLHMessageExchange06 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False True False True - -testLHMessageExchange07 :: App () -testLHMessageExchange07 = do +testLHClaimKeys :: TestClaimKeys -> App () +testLHClaimKeys testmode = do startDynamicBackends [mempty] $ \[dom] -> do withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False True True False - -testLHMessageExchange08 :: App () -testLHMessageExchange08 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort False True True True - -testLHMessageExchange09 :: App () -testLHMessageExchange09 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True False False False - -testLHMessageExchange10 :: App () -testLHMessageExchange10 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True False False True - -testLHMessageExchange11 :: App () -testLHMessageExchange11 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True False True False - -testLHMessageExchange12 :: App () -testLHMessageExchange12 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True False True True - -testLHMessageExchange13 :: App () -testLHMessageExchange13 = do + (lowner, ltid, [lmem]) <- createTeam dom 2 + (powner, ptid, [pmem]) <- createTeam dom 2 + + legalholdWhitelistTeam ltid lowner >>= assertSuccess + legalholdIsTeamInWhitelist ltid lowner >>= assertSuccess + postLegalHoldSettings ltid lowner (mkLegalHoldSettings lhPort) >>= assertStatus 201 + + requestLegalHoldDevice ltid lowner lmem >>= assertSuccess + approveLegalHoldDevice ltid (lmem %. "qualified_id") defPassword >>= assertSuccess + + let addc caps = addClient pmem (settings caps) >>= assertSuccess + settings caps = + def + { prekeys = Just $ take 10 somePrekeysRendered, + lastPrekey = Just $ head someLastPrekeysRendered, + acapabilities = caps + } + in case testmode of + TCKConsentMissing -> + addc $ Just ["legalhold-implicit-consent"] + TCKConsentAndNewClients -> do + addc $ Just ["legalhold-implicit-consent"] + legalholdWhitelistTeam ptid powner >>= assertSuccess + legalholdIsTeamInWhitelist ptid powner >>= assertSuccess + + llhdev :: String <- do + let getCls :: Value -> App [String] + getCls mem = do + res <- getClientsQualified mem dom mem + val <- getJSON 200 res + cls <- asList val + objId `mapM` cls + getCls lmem <&> \case + [d] -> d + bad -> error $ show bad + + let assertResp :: HasCallStack => Response -> App () + assertResp resp = case testmode of + TCKConsentMissing -> do + resp.status `shouldMatchInt` 403 + resp.json %. "label" `shouldMatch` "missing-legalhold-consent" + TCKConsentAndNewClients -> do + resp.status `shouldMatchInt` 200 + + bindResponse (getUsersPrekeysClient pmem (lmem %. "qualified_id") llhdev) $ assertResp + bindResponse (getUsersPrekeyBundle pmem (lmem %. "qualified_id")) $ assertResp + + slmemdom <- asString $ lmem %. "qualified_id.domain" + slmemid <- asString $ lmem %. "qualified_id.id" + let userClients = Map.fromList [(slmemdom, Map.fromList [(slmemid, Set.fromList [llhdev])])] + bindResponse (getMultiUserPrekeyBundle pmem userClients) $ assertResp + +testLHAddClientManually :: App () +testLHAddClientManually = do + (_owner, _tid, [mem1]) <- createTeam OwnDomain 2 + bindResponse (addClient mem1 def {ctype = "legalhold"}) $ \resp -> do + 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. + resp.json %. "message" `shouldMatch` "LegalHold clients cannot be added manually. LegalHold must be enabled on this user by an admin" + +testLHDeleteClientManually :: App () +testLHDeleteClientManually = do + (_owner, _tid, [mem1]) <- createTeam OwnDomain 2 + cid <- bindResponse (BrigI.addClient mem1 def {ctype = "legalhold"}) $ \resp -> do + resp.status `shouldMatchInt` 201 + asString =<< resp.json %. "id" + bindResponse (deleteClient mem1 cid) $ \resp -> do + resp.status `shouldMatchInt` 400 + resp.json %. "label" `shouldMatch` "client-error" + -- 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. + 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 - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True True False False + (alice, tid, [bob]) <- createTeam dom 2 + let reqNotEnabled requester requestee = + requestLegalHoldDevice tid requester requestee + >>= assertLabel 403 "legalhold-not-enabled" + + reqNotEnabled alice bob + + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer (lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks}) \lhPort _chan -> do + let statusShouldBe :: String -> App () + statusShouldBe status = + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` status + + -- the user has not agreed to be under legalhold + for_ [alice, bob] \requester -> do + reqNotEnabled requester bob + statusShouldBe "no_consent" + + legalholdWhitelistTeam tid alice >>= assertSuccess + postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) >>= assertSuccess + + statusShouldBe "disabled" + + requestLegalHoldDevice tid alice bob >>= assertStatus 201 + statusShouldBe "pending" + + -- requesting twice should be idempotent wrt the approval + -- mind that requesting twice means two "user.legalhold-request" notifications + -- for the clients of the user under legalhold (bob) + requestLegalHoldDevice tid alice bob >>= assertStatus 204 + statusShouldBe "pending" + + [bobc1, bobc2] <- replicateM 2 do + objId $ addClient bob def `bindResponse` getJSON 201 + for_ [bobc1, bobc2] \client -> + awaitNotification bob client noValue isUserLegalholdRequestNotif >>= \notif -> do + notif %. "payload.0.last_prekey" `shouldMatch` lpk + notif %. "payload.0.id" `shouldMatch` objId bob + +-- | 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 = 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 + +-- | 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 + -- 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 + 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 uidsAndTidMatch val = do + actualTid <- + lookupFieldM val "team_id" + >>= lift . asString + actualUid <- + lookupFieldM val "user_id" + >>= lift . asString + bobUid <- lift $ objId bob + + -- we pass the check on equality + unless ((actualTid, actualUid) == (tid, bobUid)) do + mzero + + checkChanVal chan uidsAndTidMatch + + -- the team owner cannot approve for bob + approveLegalHoldDevice' tid alice bob defPassword + >>= assertLabel 403 "access-denied" + -- bob needs to provide a password + approveLegalHoldDevice tid bob "wrong-password" + >>= assertLabel 403 "access-denied" + -- now bob finally found his password + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 + + let matchAuthToken val = + lookupFieldM val "refresh_token" + >>= lift . asString + + checkChanVal chan matchAuthToken + >>= renewToken bob + >>= assertStatus 200 + + lhdId <- lhDeviceIdOf bob + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "client.id" `shouldMatch` lhdId + resp.json %. "status" `shouldMatch` "enabled" + + replicateM 2 do + objId $ addClient bob def `bindResponse` getJSON 201 + >>= traverse_ \client -> + awaitNotification bob client noValue isUserClientAddNotif >>= \notif -> do + notif %. "payload.0.client.type" `shouldMatch` "legalhold" + notif %. "payload.0.client.class" `shouldMatch` "legalhold" + + -- the other team members receive a notification about the + -- legalhold device being approved in their team + for_ [alice, charlie] \user -> do + client <- objId $ addClient user def `bindResponse` getJSON 201 + awaitNotification user client noValue isUserLegalholdEnabledNotif >>= \notif -> do + notif %. "payload.0.id" `shouldMatch` objId bob + for_ [ollie, sandy] \outsider -> do + outsiderClient <- objId $ addClient outsider def `bindResponse` getJSON 201 + assertNoNotifications outsider outsiderClient Nothing isUserLegalholdEnabledNotif + +testLHGetDeviceStatus :: App () +testLHGetDeviceStatus = + startDynamicBackends [mempty] \[dom] -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam dom 2 + for_ [alice, bob] \user -> do + legalholdUserStatus tid alice user `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "no_consent" + + lpk <- getLastPrekey + pks <- replicateM 3 getPrekey + + withMockServer + do lhMockAppWithPrekeys MkCreateMock {nextLastPrey = pure lpk, somePrekeys = pure pks} + \lhPort _chan -> do + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "disabled" + lookupField resp.json "last_prekey" + >>= assertNothing + runMaybeT (lookupFieldM resp.json "client" >>= flip lookupFieldM "id") + >>= assertNothing -testLHMessageExchange14 :: App () -testLHMessageExchange14 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True True False True + -- the status messages for these have already been tested + postLegalHoldSettings tid alice (mkLegalHoldSettings lhPort) + >>= assertStatus 201 -testLHMessageExchange15 :: App () -testLHMessageExchange15 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True True True False + requestLegalHoldDevice tid alice bob + >>= assertStatus 201 -testLHMessageExchange16 :: App () -testLHMessageExchange16 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHMessageExchange dom lhPort True True True True + approveLegalHoldDevice tid bob defPassword + >>= assertStatus 200 -testLHClaimKeys01 :: App () -testLHClaimKeys01 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHClaimKeys dom lhPort TCKConsentMissing + 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 -testLHClaimKeys02 :: App () -testLHClaimKeys02 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHClaimKeys dom lhPort TCKOldClient + requestLegalHoldDevice tid alice bob + >>= assertLabel 409 "legalhold-already-enabled" -testLHClaimKeys03 :: App () -testLHClaimKeys03 = do - startDynamicBackends [mempty] $ \[dom] -> do - withMockServer lhMockApp $ \lhPort _chan -> do - abstractTestLHClaimKeys dom lhPort TCKConsentAndNewClients +-- | 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 + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam dom 2 + + withMockServer lhMockApp \lhPort chan -> do + setUpLHDevice tid alice bob lhPort + + 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 $ local (setTimeoutTo 90) do + awaitNotification bob bobc noValue isUserClientRemoveNotif + *> awaitNotification bob bobc noValue isUserLegalholdDisabledNotif + + bobId <- objId bob + lhClients <- + BrigI.getClientsFull bob [bobId] `bindResponse` \resp -> do + resp.json %. bobId + & asList + >>= filterM \val -> (== "legalhold") <$> (val %. "type" & asString) + + shouldBeEmpty lhClients + +testLHEnablePerTeam :: App () +testLHEnablePerTeam = do + startDynamicBackends [mempty] \[dom] -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, [bob]) <- createTeam dom 2 + legalholdIsEnabled tid alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "lockStatus" `shouldMatch` "unlocked" + resp.json %. "status" `shouldMatch` "disabled" + + withMockServer lhMockApp \lhPort _chan -> do + setUpLHDevice tid alice bob lhPort + + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + + putLegalholdStatus tid alice "disabled" + `bindResponse` assertLabel 403 "legalhold-whitelisted-only" + + -- the put doesn't have any influence on the status being "enabled" + legalholdUserStatus tid alice bob `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` "enabled" + +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" + +type TB s = TaggedBool s + +testLHNoConsentBlockOne2OneConv :: TB "connect first" -> TB "team peer" -> TB "approve LH" -> TB "test pending connection" -> App () +testLHNoConsentBlockOne2OneConv + (MkTagged connectFirst) + (MkTagged teampeer) + (MkTagged approveLH) + (MkTagged testPendingConnection) = + startDynamicBackends [mempty] \[dom1] -> do + -- team users + -- alice (team owner) and bob (member) + (alice, tid, []) <- createTeam dom1 1 + bob <- + if teampeer + then do + (walice, _tid, []) <- createTeam dom1 1 + -- FUTUREWORK(mangoiv): creating a team on a second backend + -- causes this bug: https://wearezeta.atlassian.net/browse/WPB-6640 + pure walice + else randomUser dom1 def + + legalholdWhitelistTeam tid alice + >>= assertStatus 200 + + let doEnableLH :: HasCallStack => App (Maybe String) + doEnableLH = do + -- alice requests a legalhold device for herself + requestLegalHoldDevice tid alice alice + >>= assertStatus 201 + + when approveLH do + approveLegalHoldDevice tid alice defPassword + >>= assertStatus 200 + legalholdUserStatus tid alice alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. "status" `shouldMatch` if approveLH then "enabled" else "pending" + if approveLH + then Just <$> lhDeviceIdOf alice + else pure Nothing + + doDisableLH :: HasCallStack => App () + doDisableLH = + disableLegalHold tid alice alice defPassword + >>= 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 do + alicec <- objId $ addClient alice def >>= getJSON 201 + bobc <- objId $ addClient bob def >>= getJSON 201 + + postConnection alice bob + >>= assertStatus 201 + mbConvId <- + if testPendingConnection + then pure Nothing + else + Just + <$> do + putConnection bob alice "accepted" + >>= getJSON 200 + %. "qualified_conversation" + + -- we need to take away the pending/ sent status for the connections + [lastNotifAlice, lastNotifBob] <- for [(alice, alicec), (bob, bobc)] \(user, client) -> do + -- we get two events if bob accepts alice's request + let numEvents = if testPendingConnection then 1 else 2 + last <$> awaitNotifications user client Nothing numEvents isUserConnectionNotif + + mbLHDevice <- doEnableLH + + let assertConnectionsMissingLHConsent = + for_ [(bob, alice), (alice, bob)] \(a, b) -> + getConnections a `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + conn <- assertOne =<< do resp.json %. "connections" & asList + conn %. "status" `shouldMatch` "missing-legalhold-consent" + conn %. "from" `shouldMatch` objId a + conn %. "to" `shouldMatch` objId b + + assertConnectionsMissingLHConsent + + [lastNotifAlice', lastNotifBob'] <- for [(alice, alicec, lastNotifAlice), (bob, bobc, lastNotifBob)] \(user, client, lastNotif) -> do + awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> + notif %. "payload.0.connection.status" `shouldMatch` "missing-legalhold-consent" + $> notif + + for_ [(bob, alice), (alice, bob)] \(a, b) -> + putConnection a b "accepted" + >>= assertLabel 403 "bad-conn-update" + + -- putting the connection to "accepted" with 403 doesn't change the + -- connection status + assertConnectionsMissingLHConsent + + bobc2 <- objId $ addClient bob def >>= getJSON 201 + + let -- \| we send a message from bob to alice, but only if + -- we have a conversation id and a legalhold device + -- we first create a message that goes to recipients + -- chosen by the first callback passed + -- then send the message using proteus + -- and in the end running the assertino callback to + -- verify the result + sendMessageFromBobToAlice :: + HasCallStack => + (String -> [String]) -> + -- \^ if we have the legalhold device registered, this + -- callback will be passed the lh device + (Response -> App ()) -> + -- \^ the callback to verify our response (an assertion) + App () + sendMessageFromBobToAlice recipients assertion = + for_ ((,) <$> mbConvId <*> mbLHDevice) \(convId, device) -> do + successfulMsgForOtherUsers <- + mkProteusRecipients + bob -- bob is the sender + [(alice, recipients device), (bob, [bobc])] + -- we send to clients of alice, maybe the legalhold device + -- we need to send to our other clients (bobc) + "hey alice (and eve)" -- the message + let bobaliceMessage = + Proto.defMessage @Proto.QualifiedNewOtrMessage + & #sender . Proto.client .~ (bobc2 ^?! hex) + & #recipients .~ [successfulMsgForOtherUsers] + & #reportAll .~ Proto.defMessage + -- make sure that `convId` is not just the `convId` but also + -- contains the domain because `postProteusMessage` will take the + -- comain from the `convId` json object + postProteusMessage bob convId bobaliceMessage + `bindResponse` assertion + + sendMessageFromBobToAlice (\device -> [alicec, device]) \resp -> do + resp.status `shouldMatchInt` 404 + + -- now we disable legalhold + doDisableLH + + for_ mbLHDevice \lhd -> + local (setTimeoutTo 90) $ + awaitNotification alice alicec noValue isUserClientRemoveNotif >>= \notif -> + notif %. "payload.0.client.id" `shouldMatch` lhd + + let assertStatusFor user status = + getConnections user `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + conn <- assertOne =<< do resp.json %. "connections" & asList + conn %. "status" `shouldMatch` status + + if testPendingConnection + then do + assertStatusFor alice "sent" + assertStatusFor bob "pending" + else do + assertStatusFor alice "accepted" + assertStatusFor bob "accepted" + + for_ [(alice, alicec, lastNotifAlice'), (bob, bobc, lastNotifBob')] \(user, client, lastNotif) -> do + awaitNotification user client (Just lastNotif) isUserConnectionNotif >>= \notif -> + notif %. "payload.0.connection.status" `shouldMatchOneOf` ["sent", "pending", "accepted"] + + sendMessageFromBobToAlice (const [alicec]) \resp -> do + resp.status `shouldMatchInt` 201 + + sendMessageFromBobToAlice (\device -> [device]) \resp -> do + resp.status `shouldMatchInt` 412 diff --git a/integration/test/Test/MLS.hs b/integration/test/Test/MLS.hs index d92da58169e..dcf18eb99dc 100644 --- a/integration/test/Test/MLS.hs +++ b/integration/test/Test/MLS.hs @@ -29,7 +29,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/Test/MLS/One2One.hs b/integration/test/Test/MLS/One2One.hs index 149903eefd6..9620c079399 100644 --- a/integration/test/Test/MLS/One2One.hs +++ b/integration/test/Test/MLS/One2One.hs @@ -216,11 +216,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 + ] one2OneScenarioUserDomain :: One2OneScenario -> Domain one2OneScenarioUserDomain One2OneScenarioLocal = OwnDomain diff --git a/integration/test/Test/MLS/SubConversation.hs b/integration/test/Test/MLS/SubConversation.hs index 857426aa12c..919faef4a93 100644 --- a/integration/test/Test/MLS/SubConversation.hs +++ b/integration/test/Test/MLS/SubConversation.hs @@ -124,15 +124,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] @@ -148,9 +144,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 73be6487764..fab4fd54daa 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 8644a27d0f1..507311b37c1 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 68d5c8d0258..6a85bc20355 100644 --- a/integration/test/Test/Version.hs +++ b/integration/test/Test/Version.hs @@ -8,21 +8,18 @@ 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)) + ] -- | Used to test endpoints that have changed after version 5 data Version5 = Version5 | NoVersion5 - -instance HasTests x => HasTests (Version5 -> x) where - mkTests m n s f x = - mkTests m (n <> "[version=versioned]") s f (x NoVersion5) - <> mkTests m (n <> "[version=v5]") s f (x Version5) + deriving (Generic) withVersion5 :: Version5 -> App a -> App a withVersion5 Version5 = withAPIVersion 5 diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs index 18c8f6633ff..b6ca5970f4f 100644 --- a/integration/test/Testlib/App.hs +++ b/integration/test/Testlib/App.hs @@ -10,6 +10,7 @@ import Data.Maybe 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 @@ -55,6 +56,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/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 6d67fc9c3b8..c3be8cee328 100644 --- a/integration/test/Testlib/Env.hs +++ b/integration/test/Testlib/Env.hs @@ -94,7 +94,7 @@ mkGlobalEnv cfgFile = do tempDir <- Codensity $ withSystemTempDirectory "test" timeOutSeconds <- liftIO $ - fromMaybe 10 . (readMaybe @Int =<<) <$> (lookupEnv "TEST_TIMEOUT_SECONDS") + fromMaybe 10 . (readMaybe @Int =<<) <$> lookupEnv "TEST_TIMEOUT_SECONDS" pure GlobalEnv { gServiceMap = sm, diff --git a/integration/test/Testlib/HTTP.hs b/integration/test/Testlib/HTTP.hs index c6af608566b..1a84ba4f48f 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) @@ -85,23 +86,32 @@ 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) -- | 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 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 -- | assert a response status code assertStatus :: HasCallStack => Int -> Response -> App () @@ -114,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/JSON.hs b/integration/test/Testlib/JSON.hs index 6da4ed3c354..871682fabb5 100644 --- a/integration/test/Testlib/JSON.hs +++ b/integration/test/Testlib/JSON.hs @@ -196,6 +196,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 @@ -299,6 +308,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/MockIntegrationService.hs b/integration/test/Testlib/MockIntegrationService.hs index 4d7c64a5150..c7c279211e4 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, lhMockAppWithPrekeys, lhMockApp, mkLegalHoldSettings, CreateMock (..)) 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,55 @@ 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 = 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 :: Chan (Wai.Request, LBS.ByteString) -> Wai.Application -lhMockApp ch req cont = 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) - 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) <- + (,) + <$> 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 + (["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/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 12e710f7fd2..4510894cd6b 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -128,7 +128,7 @@ startDynamicBackends beOverrides k = measureM "startDynamicBackends" do pure $ map (.berDomain) resources k -startDynamicBackend :: HasCallStack => BackendResource -> ServiceOverrides -> Codensity App () +startDynamicBackend :: BackendResource -> ServiceOverrides -> Codensity App () startDynamicBackend resource beOverrides = do let overrides = mconcat diff --git a/integration/test/Testlib/PTest.hs b/integration/test/Testlib/PTest.hs index d8e36fe4db3..037cb276260 100644 --- a/integration/test/Testlib/PTest.hs +++ b/integration/test/Testlib/PTest.hs @@ -1,6 +1,12 @@ module Testlib.PTest where -import Testlib.App +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.Env import Testlib.Types import Prelude @@ -13,19 +19,102 @@ 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) -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) +-- | 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] + +type Tagged :: Symbol -> Type -> Type +newtype Tagged s a = MkTagged {unTagged :: a} + deriving stock (Eq, Ord, Show, Generic) + +type TaggedBool s = Tagged s Bool + +pattern TaggedBool :: Bool -> Tagged s Bool +pattern TaggedBool a = MkTagged a + +{-# COMPLETE TaggedBool #-} + +-- | 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 + 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 + } + +instance TestCases CredentialType where + testCases = + [ MkTestCase "[ctype=basic]" BasicCredentialType, + MkTestCase "[ctype=x509]" X509CredentialType + ] + +-- | 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 61cdbd8dfc7..f3b7cf16063 100644 --- a/integration/test/Testlib/Types.hs +++ b/integration/test/Testlib/Types.hs @@ -233,7 +233,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" @@ -384,6 +384,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/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/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 85393d1660e..973d99cdef6 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -85,11 +85,7 @@ tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> DB.ClientState tests _cl _at opts p db n b c g = testGroup "client" - [ test p "delete /clients/:client 403 - can't delete legalhold clients" $ - testCan'tDeleteLegalHoldClient b, - test p "post /clients 400 - can't add legalhold clients manually" $ - testCan'tAddLegalHoldClient b, - test p "get /users/:uid/clients - 200" $ testGetUserClientsUnqualified opts b, + [ test p "get /users/:uid/clients - 200" $ testGetUserClientsUnqualified opts b, test p "get /users//:uid/clients - 200" $ testGetUserClientsQualified opts b, test p "get /users/:uid/prekeys - 200" $ testGetUserPrekeys b, test p "get /users//:uid/prekeys - 200" $ testGetUserPrekeysQualified b opts, @@ -1546,27 +1542,3 @@ testCreateAccessTokenNoNonce brig = do createClientForUser :: Brig -> UserId -> Http ClientId createClientForUser brig uid = clientId <$> (responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [head somePrekeys] (head someLastPrekeys))) - -testCan'tDeleteLegalHoldClient :: Brig -> Http () -testCan'tDeleteLegalHoldClient brig = do - let hasPassword = False - user <- randomUser' hasPassword brig - let uid = userId user - let pk = head somePrekeys - let lk = head someLastPrekeys - resp <- - addClientInternal brig uid (defNewClient LegalHoldClientType [pk] lk) - responseJsonError resp - deleteClient brig uid lhClientId Nothing !!! const 400 === statusCode - -testCan'tAddLegalHoldClient :: Brig -> Http () -testCan'tAddLegalHoldClient brig = do - let hasPassword = False - user <- randomUser' hasPassword brig - let uid = userId user - let pk = head somePrekeys - let lk = head someLastPrekeys - -- Regular users cannot add legalhold clients - addClient brig uid (defNewClient LegalHoldClientType [pk] lk) !!! const 400 === statusCode diff --git a/services/galley/src/Galley/API/LegalHold/Conflicts.hs b/services/galley/src/Galley/API/LegalHold/Conflicts.hs index 2c7ec7aa8b5..4f898bd4856 100644 --- a/services/galley/src/Galley/API/LegalHold/Conflicts.hs +++ b/services/galley/src/Galley/API/LegalHold/Conflicts.hs @@ -164,7 +164,7 @@ guardLegalholdPolicyConflictsUid self (Map.keys . userClients -> otherUids) = do -- when no other client is under LH, then we're good and can leave this function. but... when anyClientHasLH $ do P.debug $ Log.msg ("guardLegalholdPolicyConflicts[5]: anyClientHasLH" :: Text) - if anyClientIsOld + if anyClientIsOld && False -- https://wearezeta.atlassian.net/browse/WPB-6392 then do -- you can't effectively give consent as long as you have old clients: when using the -- old clients, you still would not be exposed to the popups and red dot where diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 373a99b6f3e..8336cb30367 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -987,8 +987,11 @@ allLegalholdConsentGiven uids = do -- a whitelisted team is equivalent to have given consent to be in a -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do - teamsPage <- nub . Map.elems <$> getUsersTeams uidsPage - allM isTeamLegalholdWhitelisted teamsPage + teamsPage <- getUsersTeams uidsPage + allM (eitherTeamMemberAndLHAllowedOrDefLHStatus teamsPage) uidsPage + where + eitherTeamMemberAndLHAllowedOrDefLHStatus teamsPage uid = do + fromMaybe (consentGiven defUserLegalHoldStatus == ConsentGiven) <$> (for (Map.lookup uid teamsPage) isTeamLegalholdWhitelisted) -- | Add to every uid the legalhold status getLHStatusForUsers :: diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index 91315aa036d..1cd1f785a01 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -20,39 +20,25 @@ -- 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 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 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 (..)) 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.Cassandra.LegalHold qualified as LegalHoldData 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) @@ -66,14 +52,11 @@ 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 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,20 +86,12 @@ 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 "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, - 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, - 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, 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: @@ -129,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), @@ -192,234 +160,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 - 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 - -- 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 - 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 - 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) @@ -534,34 +274,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 @@ -598,39 +310,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 @@ -692,140 +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 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