[WPB-5687] port flaking LH tests to new integration

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

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/test/API/Brig.hs

@@ -149,7 +149,6 @@ deleteUser user = do
   submit "DELETE" $
     req & addJSONObject ["password" .= defPassword]
 
--- | https://staging-nginz-https.zinfra.io/api-internal/swagger-ui/brig/#/brig/post_i_clients__uid_
 addClient ::
   (HasCallStack, MakesValue user) =>
   user ->
@@ -320,9 +319,9 @@ uploadKeyPackages cid kps = do
       "/mls/key-packages/self/" <> cid.client
   submit
     "POST"
-    ( req
+    do
+      req
         & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps]
-    )
 
 claimKeyPackagesWithParams :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> [(String, String)] -> App Response
 claimKeyPackagesWithParams suite u v params = do
@@ -334,7 +333,7 @@ claimKeyPackagesWithParams suite u v params = do
     req
       & addQueryParams ([("ciphersuite", suite.code)] <> params)
 
-claimKeyPackages :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response
+claimKeyPackages :: (HasCallStack, MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response
 claimKeyPackages suite u v = claimKeyPackagesWithParams suite u v []
 
 countKeyPackages :: Ciphersuite -> ClientIdentity -> App Response
@@ -630,3 +629,9 @@ getMultiUserPrekeyBundle :: (HasCallStack, MakesValue caller, ToJSON userClients
 getMultiUserPrekeyBundle caller userClients = do
   req <- baseRequest caller Brig Versioned $ joinHttpPath ["users", "list-prekeys"]
   submit "POST" (addJSON userClients req)
+
+-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_access
+renewToken :: (HasCallStack, MakesValue uid) => uid -> String -> App Response
+renewToken caller cookie = do
+  req <- baseRequest caller Brig Versioned "access"
+  submit "POST" (addHeader "Cookie" ("zuid=" <> cookie) req)

integration/test/API/BrigInternal.hs

@@ -236,3 +236,9 @@ addClient user args = do
   req <- baseRequest user Brig Unversioned $ "/i/clients/" <> uid
   val <- mkAddClientValue args
   submit "POST" $ req & addJSONObject val
+
+getClientsFull :: (HasCallStack, MakesValue users, MakesValue uid) => uid -> users -> App Response
+getClientsFull user users = do
+  val <- make users
+  baseRequest user Brig Unversioned do joinHttpPath ["i", "clients", "full"]
+    >>= submit "POST" . addJSONObject ["users" .= val]

integration/test/API/Galley.hs

@@ -238,7 +238,7 @@ postProteusMessage user conv msgs = do
   convDomain <- objDomain conv
   convId <- objId conv
   let bytes = Proto.encodeMessage msgs
-  req <- baseRequest user Galley Versioned ("/conversations/" <> convDomain <> "/" <> convId <> "/proteus/messages")
+  req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", convDomain, convId, "proteus", "messages"])
   submit "POST" (addProtobuf bytes req)
 
 mkProteusRecipient :: (HasCallStack, MakesValue user, MakesValue client) => user -> client -> String -> App Proto.QualifiedUserEntry
@@ -579,23 +579,46 @@ putTeamProperties tid caller properties = do
         req
     )
 
+legalholdUserStatus :: (HasCallStack, MakesValue tid, MakesValue user, MakesValue owner) => tid -> owner -> user -> App Response
+legalholdUserStatus tid ownerid user = do
+  tidS <- asString tid
+  uid <- objId user
+  req <- baseRequest ownerid Galley Versioned (joinHttpPath ["teams", tidS, "legalhold", uid])
+  submit "GET" req
+
 -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_teams__tid__legalhold_settings
 enableLegalHold :: (HasCallStack, MakesValue tid, MakesValue ownerid) => tid -> ownerid -> App Response
 enableLegalHold tid ownerid = do
   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
@@ -609,10 +632,16 @@ requestLegalHoldDevice tid ownerid uid = do
   submit "POST" req
 
 -- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve
+--
+--   like approveLegalHoldDevice' but approves for the requesting party
 approveLegalHoldDevice :: (HasCallStack, MakesValue tid, MakesValue uid) => tid -> uid -> String -> App Response
-approveLegalHoldDevice tid uid pwd = do
+approveLegalHoldDevice tid uid = approveLegalHoldDevice' tid uid uid
+
+-- | https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/put_teams__tid__legalhold__uid__approve
+approveLegalHoldDevice' :: (HasCallStack, MakesValue tid, MakesValue uid, MakesValue forUid) => tid -> uid -> forUid -> String -> App Response
+approveLegalHoldDevice' tid uid forUid pwd = do
   tidStr <- asString tid
-  uidStr <- asString $ uid %. "id"
+  uidStr <- asString $ forUid %. "id"
   req <- baseRequest uid Galley Versioned (joinHttpPath ["teams", tidStr, "legalhold", uidStr, "approve"])
   submit "PUT" (addJSONObject ["password" .= pwd] req)
 

integration/test/API/GalleyInternal.hs

@@ -59,14 +59,20 @@ getFederationStatus user domains =
           "GET"
           $ req & addJSONObject ["domains" .= domainList]
 
-legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response
-legalholdWhitelistTeam uid tid = do
+legalholdWhitelistTeam :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response
+legalholdWhitelistTeam tid uid = do
   tidStr <- asString tid
   req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr]
   submit "PUT" req
 
-legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => uid -> tid -> App Response
-legalholdIsTeamInWhitelist uid tid = do
+legalholdIsTeamInWhitelist :: (HasCallStack, MakesValue uid, MakesValue tid) => tid -> uid -> App Response
+legalholdIsTeamInWhitelist tid uid = do
   tidStr <- asString tid
   req <- baseRequest uid Galley Unversioned $ joinHttpPath ["i", "legalhold", "whitelisted-teams", tidStr]
   submit "GET" req
+
+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

@@ -3,7 +3,6 @@
 module MLS.Util where
 
 import API.Brig
-import qualified API.BrigCommon as BrigC
 import API.Galley
 import Control.Concurrent.Async hiding (link)
 import Control.Monad
@@ -37,7 +36,6 @@ import System.IO hiding (print, putStrLn)
 import System.IO.Temp
 import System.Posix.Files
 import System.Process
-import Testlib.App
 import Testlib.Assertions
 import Testlib.HTTP
 import Testlib.JSON
@@ -127,20 +125,21 @@ argSubst from to_ s =
 
 createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity
 createWireClient u = do
-  lpk <- getLastPrekey
-  c <- addClient u def {BrigC.lastPrekey = Just lpk} >>= getJSON 201
-  mkClientIdentity u c
+  addClient u def
+    >>= getJSON 201
+    >>= mkClientIdentity u
 
 data CredentialType = BasicCredentialType | X509CredentialType
 
 instance MakesValue CredentialType where
   make BasicCredentialType = make "basic"
   make X509CredentialType = make "x509"
 
-instance (HasTests x) => HasTests (CredentialType -> x) where
-  mkTests m n s f x =
-    mkTests m (n <> "[ctype=basic]") s f (x BasicCredentialType)
-      <> mkTests m (n <> "[ctype=x509]") s f (x X509CredentialType)
+instance TestCases CredentialType where
+  testCases =
+    [ MkTestCase "[ctype=basic]" BasicCredentialType,
+      MkTestCase "[ctype=x509]" X509CredentialType
+    ]
 
 data InitMLSClient = InitMLSClient
   {credType :: CredentialType}

integration/test/Notifications.hs

@@ -2,11 +2,49 @@
 module Notifications where
 
 import API.Gundeck
+import Control.Error (lastMay)
 import Control.Monad.Extra
 import Control.Monad.Reader (asks)
+import GHC.Generics ((:.:) (Comp1, unComp1))
 import Testlib.Prelude
+import UnliftIO (timeout)
 import UnliftIO.Concurrent
 
+-- | assert that no notifications with the predicate happen within the timeout
+assertNoNotifications ::
+  (HasCallStack, MakesValue user, MakesValue client) =>
+  -- | the user
+  user ->
+  -- | the client of that user
+  client ->
+  -- | the last notif
+  Maybe String ->
+  -- | the predicate
+  (Value -> App Bool) ->
+  App ()
+assertNoNotifications u uc since0 p = do
+  ucid <- objId uc
+  let go since = do
+        notifs <-
+          getNotifications u def {client = Just ucid, since = since}
+            `bindResponse` asList
+            . (%. "notifications")
+            . (.json)
+        partitionM p notifs >>= \case
+          ([], nonMatching) ->
+            threadDelay 1_000 *> case nonMatching of
+              (lastMay -> Just lst) -> objId lst >>= go . Just
+              _ -> go Nothing
+          (matching, _) -> do
+            pj <- prettyJSON matching
+            assertFailure $
+              unlines
+                [ "Expected no matching events  but got:",
+                  pj
+                ]
+  Nothing <- asks timeOutSeconds >>= flip timeout (go since0)
+  pure ()
+
 awaitNotifications ::
   (HasCallStack, MakesValue user, MakesValue client) =>
   user ->
@@ -18,34 +56,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 +149,49 @@ 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"
+
+-- | compose two predicates on notifications with a boolean relation
+notifBoolRel :: MakesValue a => (Bool -> Bool -> Bool) -> (a -> App Bool) -> (a -> App Bool) -> a -> App Bool
+notifBoolRel rel p1 p2 = unComp1 do
+  rel <$> Comp1 p1 <*> Comp1 p2
+
+-- | compose two predicates on notifications with a '(||)'
+notifOr :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool
+notifOr = notifBoolRel (||)
+
+infixr 2 `notifOr`
+
+-- | compose two predicates on notifications with a '(&&)'
+notifAnd :: MakesValue a => (a -> App Bool) -> (a -> App Bool) -> a -> App Bool
+notifAnd = notifBoolRel (&&)
+
+infixr 3 `notifAnd`
 
 assertLeaveNotification ::
   ( HasCallStack,