Small improvements to the new integration suite (#3293)

* Add convenience getJSON and getBody functions These can be used to extract the body from a response and check the status code at the same time. * baseRequest now adds Z headers automatically * Added liftIO versions of putStrLn etc * Add Show instances for MLSState --------- Co-authored-by: Stefan Matting <[email protected]>
wireapp · May 15, 2023 · b3224a8 · b3224a8
1 parent 0b1e04c
commit b3224a8
Show file tree

Hide file tree

Showing 19 changed files with 187 additions and 149 deletions.
diff --git a/changelog.d/5-internal/integration-qol b/changelog.d/5-internal/integration-qol
@@ -0,0 +1,4 @@
+- Add convenience getJSON and getBody functions
+- baseRequest now adds Z headers automatically
+- Add liftIO versions of putStrLn etc
+- Add Show instances for MLSState
diff --git a/integration/integration.cabal b/integration/integration.cabal
@@ -25,6 +25,7 @@ common common-all
     -optP-Wno-nonportable-include-path
 
   default-extensions:
+    NoImplicitPrelude
     AllowAmbiguousTypes
     BangPatterns
     ConstraintKinds

diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs
@@ -4,7 +4,6 @@ import API.Common
 import qualified Data.ByteString.Base64 as Base64
 import Data.Foldable
 import Data.Function
-import Data.Maybe
 import qualified Data.Text.Encoding as T
 import GHC.Stack
 import Testlib.Prelude
@@ -76,11 +75,9 @@ updateClient ::
   UpdateClient ->
   App Response
 updateClient cid args = do
-  uid <- objId cid
   req <- baseRequest cid Brig Versioned $ "/clients/" <> cid.client
   submit "PUT" $
     req
-      & zUser uid
       & addJSONObject
         ( ["prekeys" .= args.prekeys]
             <> ["lastkey" .= k | k <- toList args.lastPrekey]
@@ -92,18 +89,13 @@ updateClient cid args = do
 deleteClient ::
   (HasCallStack, MakesValue user, MakesValue client) =>
   user ->
-  Maybe String ->
   client ->
   App Response
-deleteClient user mconn client = do
-  let conn = fromMaybe "0" mconn
-  uid <- objId user
+deleteClient user client = do
   cid <- objId client
   req <- baseRequest user Brig Versioned $ "/clients/" <> cid
   submit "DELETE" $
     req
-      & zUser uid
-      & zConnection conn
       & addJSONObject
         [ "password" .= defPassword
         ]
@@ -118,13 +110,7 @@ searchContacts ::
 searchContacts searchingUserId searchTerm = do
   req <- baseRequest searchingUserId Brig Versioned "/search/contacts"
   q <- asString searchTerm
-  uid <- objId searchingUserId
-  submit
-    "GET"
-    ( req
-        & addQueryParams [("q", q)]
-        & zUser uid
-    )
+  submit "GET" (req & addQueryParams [("q", q)])
 
 getAPIVersion :: (HasCallStack, MakesValue domain) => domain -> App Response
 getAPIVersion domain = do
@@ -140,17 +126,11 @@ postConnection ::
   userTo ->
   App Response
 postConnection userFrom userTo = do
-  uidFrom <- objId userFrom
   (userToDomain, userToId) <- objQid userTo
   req <-
     baseRequest userFrom Brig Versioned $
       joinHttpPath ["/connections", userToDomain, userToId]
-  submit
-    "POST"
-    ( req
-        & zUser uidFrom
-        & zConnection "conn"
-    )
+  submit "POST" req
 
 putConnection ::
   ( HasCallStack,
@@ -163,31 +143,21 @@ putConnection ::
   status ->
   App Response
 putConnection userFrom userTo status = do
-  uidFrom <- objId userFrom
   (userToDomain, userToId) <- objQid userTo
   req <-
     baseRequest userFrom Brig Versioned $
       joinHttpPath ["/connections", userToDomain, userToId]
   statusS <- asString status
-  submit
-    "POST"
-    ( req
-        & zUser uidFrom
-        & zConnection "conn"
-        & contentTypeJSON
-        & addJSONObject ["status" .= statusS]
-    )
+  submit "POST" (req & addJSONObject ["status" .= statusS])
 
 uploadKeyPackage :: ClientIdentity -> ByteString -> App Response
 uploadKeyPackage cid kp = do
   req <-
     baseRequest cid Brig Versioned $
       "/mls/key-packages/self/" <> cid.client
-  uid <- objId cid
   submit
     "POST"
     ( req
-        & zUser uid
         & addJSONObject ["key_packages" .= [T.decodeUtf8 (Base64.encode kp)]]
     )
 
@@ -197,5 +167,4 @@ claimKeyPackages u v = do
   req <-
     baseRequest u Brig Versioned $
       "/mls/key-packages/claim/" <> targetDom <> "/" <> targetUid
-  uid <- objId u
-  submit "POST" (req & zUser uid)
+  submit "POST" req
diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs
@@ -53,25 +53,15 @@ instance MakesValue CreateConv where
 
 postConversation ::
   ( HasCallStack,
-    MakesValue user,
-    MakesValue client
+    MakesValue user
   ) =>
   user ->
-  Maybe client ->
   CreateConv ->
   App Response
-postConversation user mclient cc = do
-  uid <- objId user
-  domain <- objDomain user
-  mcid <- for mclient objId
-  req <- baseRequest domain Galley Versioned "/conversations"
+postConversation user cc = do
+  req <- baseRequest user Galley Versioned "/conversations"
   ccv <- make cc
-  submit "POST" $
-    req
-      & zUser uid
-      & maybe id zClient mcid
-      & zConnection "conn"
-      & addJSON ccv
+  submit "POST" $ req & addJSON ccv
 
 putConversationProtocol ::
   ( HasCallStack,
@@ -82,22 +72,13 @@ putConversationProtocol ::
   ) =>
   user ->
   qcnv ->
-  Maybe conn ->
   protocol ->
   App Response
-putConversationProtocol user qcnv mconn protocol = do
-  mconn' <- for mconn asString
+putConversationProtocol user qcnv protocol = do
   (domain, cnv) <- objQid qcnv
   p <- asString protocol
-  uid <- objId user
   req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", domain, cnv, "protocol"])
-  submit
-    "PUT"
-    ( req
-        & zUser uid
-        & zConnection (fromMaybe "conn" mconn')
-        & addJSONObject ["protocol" .= p]
-    )
+  submit "PUT" (req & addJSONObject ["protocol" .= p])
 
 getConversation ::
   ( HasCallStack,
@@ -109,13 +90,8 @@ getConversation ::
   App Response
 getConversation user qcnv = do
   (domain, cnv) <- objQid qcnv
-  uid <- objId user
   req <- baseRequest user Galley Versioned (joinHttpPath ["conversations", domain, cnv])
-  submit
-    "GET"
-    ( req
-        & zUser uid
-    )
+  submit "GET" req
 
 getSubConversation ::
   ( HasCallStack,
@@ -127,7 +103,6 @@ getSubConversation ::
   String ->
   App Response
 getSubConversation user conv sub = do
-  uid <- objId user
   (cnvDomain, cnvId) <- objQid conv
   req <-
     baseRequest user Galley Versioned $
@@ -138,13 +113,12 @@ getSubConversation user conv sub = do
           "subconversations",
           sub
         ]
-  submit "GET" $ req & zUser uid
+  submit "GET" req
 
 getSelfConversation :: (HasCallStack, MakesValue user) => user -> App Response
 getSelfConversation user = do
-  uid <- objId user
   req <- baseRequest user Galley Versioned "/conversations/mls-self"
-  submit "GET" $ req & zUser uid & zConnection "conn"
+  submit "GET" $ req
 
 data ListConversationIds = ListConversationIds {pagingState :: Maybe String, size :: Maybe Int}
 
@@ -154,10 +128,8 @@ instance Default ListConversationIds where
 listConversationIds :: MakesValue user => user -> ListConversationIds -> App Response
 listConversationIds user args = do
   req <- baseRequest user Galley Versioned "/conversations/list-ids"
-  uid <- objId user
   submit "POST" $
     req
-      & zUser uid
       & addJSONObject
         ( ["paging_state" .= s | s <- toList args.pagingState]
             <> ["size" .= s | s <- toList args.size]
@@ -166,25 +138,19 @@ listConversationIds user args = do
 listConversations :: MakesValue user => user -> [Value] -> App Response
 listConversations user cnvs = do
   req <- baseRequest user Galley Versioned "/conversations/list"
-  uid <- objId user
   submit "POST" $
     req
-      & zUser uid
       & addJSONObject ["qualified_ids" .= cnvs]
 
 postMLSMessage :: HasCallStack => ClientIdentity -> ByteString -> App Response
 postMLSMessage cid msg = do
   req <- baseRequest cid Galley Versioned "/mls/messages"
-  uid <- objId cid
-  c <- cid %. "client" & asString
-  submit "POST" (addMLS msg req & zUser uid & zClient c & zConnection "conn")
+  submit "POST" (addMLS msg req)
 
 postMLSCommitBundle :: HasCallStack => ClientIdentity -> ByteString -> App Response
 postMLSCommitBundle cid msg = do
   req <- baseRequest cid Galley Versioned "/mls/commit-bundles"
-  uid <- objId cid
-  c <- cid %. "client_id" & asString
-  submit "POST" (addMLS msg req & zUser uid & zClient c & zConnection "conn")
+  submit "POST" (addMLS msg req)
 
 getGroupInfo ::
   (HasCallStack, MakesValue user, MakesValue conv) =>
@@ -198,5 +164,4 @@ getGroupInfo user conv = do
         Nothing -> ["conversations", convDomain, convId, "groupinfo"]
         Just sub -> ["conversations", convDomain, convId, "subconversations", sub, "groupinfo"]
   req <- baseRequest user Galley Versioned path
-  uid <- objId user
-  submit "GET" (req & zUser uid & zConnection "conn")
+  submit "GET" req
diff --git a/integration/test/MLS/Util.hs b/integration/test/MLS/Util.hs
@@ -10,8 +10,6 @@ import Control.Monad.Catch
 import Control.Monad.Cont
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
-import Data.Aeson (Value (..), object)
-import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Char8 as B8
@@ -39,7 +37,7 @@ import Testlib.Assertions
 import Testlib.Env
 import Testlib.HTTP
 import Testlib.JSON
-import Testlib.Types
+import Testlib.Prelude
 
 mkClientIdentity :: (MakesValue u, MakesValue c) => u -> c -> App ClientIdentity
 mkClientIdentity u c = do
@@ -115,7 +113,7 @@ argSubst from to_ s =
 createWireClient :: (MakesValue u, HasCallStack) => u -> App ClientIdentity
 createWireClient u = do
   lpk <- getLastPrekey
-  c <- addClient u def {lastPrekey = Just lpk}
+  c <- addClient u def {lastPrekey = Just lpk} >>= getJSON 201
   mkClientIdentity u c
 
 initMLSClient :: HasCallStack => ClientIdentity -> App ()
@@ -165,9 +163,7 @@ generateKeyPackage cid = do
 -- | Create conversation and corresponding group.
 setupMLSGroup :: HasCallStack => ClientIdentity -> App (String, Value)
 setupMLSGroup cid = do
-  conv <- bindResponse (postConversation cid (Just cid.client) defMLS) $ \resp -> do
-    resp.status `shouldMatchInt` 201
-    pure resp.json
+  conv <- postConversation cid defMLS >>= getJSON 201
   groupId <- conv %. "group_id" & asString
   convId <- conv %. "qualified_id"
   createGroup cid conv
@@ -176,10 +172,8 @@ setupMLSGroup cid = do
 -- | Retrieve self conversation and create the corresponding group.
 setupMLSSelfGroup :: HasCallStack => ClientIdentity -> App (String, Value)
 setupMLSSelfGroup cid = do
-  conv <- bindResponse (getSelfConversation cid) $ \resp -> do
-    resp.status `shouldMatchInt` 200
-    resp.json %. "epoch" `shouldMatchInt` 0
-    resp.json
+  conv <- getSelfConversation cid >>= getJSON 200
+  conv %. "epoch" `shouldMatchInt` 0
   groupId <- conv %. "group_id" & asString
   convId <- conv %. "qualified_id"
   createGroup cid conv
@@ -249,9 +243,7 @@ unbundleKeyPackages bundle = do
 createAddCommit :: HasCallStack => ClientIdentity -> [Value] -> App MessagePackage
 createAddCommit cid users = do
   kps <- fmap concat . for users $ \user -> do
-    bundle <- bindResponse (claimKeyPackages cid user) $ \resp -> do
-      resp.status `shouldMatchInt` 200
-      resp.json
+    bundle <- claimKeyPackages cid user >>= getJSON 200
     unbundleKeyPackages bundle
   createAddCommitWithKeyPackages cid kps
 
@@ -310,9 +302,7 @@ createAddCommitWithKeyPackages cid clientsAndKeyPackages = do
 
 createAddProposals :: HasCallStack => ClientIdentity -> [Value] -> App [MessagePackage]
 createAddProposals cid users = do
-  bundles <- for users $ \u -> bindResponse (claimKeyPackages cid u) $ \resp -> do
-    resp.status `shouldMatchInt` 200
-    resp.json
+  bundles <- for users $ (claimKeyPackages cid >=> getJSON 200)
   kps <- concat <$> traverse unbundleKeyPackages bundles
   traverse (createAddProposalWithKeyPackage cid) kps
 
@@ -374,9 +364,7 @@ createExternalCommit cid mgi = do
   giFile <- liftIO $ emptyTempFile bd "gi"
   conv <- getConv
   gi <- case mgi of
-    Nothing -> bindResponse (getGroupInfo cid conv) $ \resp -> do
-      resp.status `shouldMatchInt` 200
-      pure resp.body
+    Nothing -> getGroupInfo cid conv >>= getBody 200
     Just v -> pure v
   commit <-
     mlscli
@@ -432,19 +420,15 @@ consumeMessage1 cid msg =
 -- commit, the 'sendAndConsumeCommit' function should be used instead.
 sendAndConsumeMessage :: HasCallStack => MessagePackage -> App Value
 sendAndConsumeMessage mp = do
-  r <- bindResponse (postMLSMessage mp.sender mp.message) $ \resp -> do
-    resp.status `shouldMatchInt` 201
-    resp.json
+  r <- postMLSMessage mp.sender mp.message >>= getJSON 201
   consumeMessage mp
   pure r
 
 -- | Send an MLS commit bundle, simulate clients receiving it, and update the
 -- test state accordingly.
 sendAndConsumeCommitBundle :: HasCallStack => MessagePackage -> App Value
 sendAndConsumeCommitBundle mp = do
-  resp <- bindResponse (postMLSCommitBundle mp.sender (mkBundle mp)) $ \resp -> do
-    resp.status `shouldMatchInt` 201
-    resp.json
+  resp <- postMLSCommitBundle mp.sender (mkBundle mp) >>= getJSON 201
   consumeMessage mp
   traverse_ consumeWelcome mp.welcome