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 <mf@zerobuzz.net>

* wip

* fix integration tests

---------

Co-authored-by: fisx <mf@zerobuzz.net>
Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com>

.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:

changelog.d/3-bug-fixes/WPB-5845

@@ -0,0 +1 @@
+Guests should not be added to conversations that are under legalhold

changelog.d/5-internal/WPB-5687

@@ -0,0 +1 @@
+port flaking LH tests to new integration and improve the ergonomics of our testing library

changelog.d/5-internal/WPB-6254-translate-LH-tests-part-1

@@ -0,0 +1 @@
+Translate integration tests: manually add / delete LH device

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

integration/integration.cabal

@@ -90,6 +90,7 @@ library
   -- cabal-fmt: expand test
   exposed-modules:
     API.Brig
+    API.BrigCommon
     API.BrigInternal
     API.Cargohold
     API.Common

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)

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
+    ]

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]

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,23 +520,47 @@ 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
   tidStr <- asString tid
   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"]

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"

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}