From 109b5e48324292e861e4676ec9362186ff8c1d22 Mon Sep 17 00:00:00 2001 From: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> Date: Tue, 12 Dec 2023 13:11:12 +0100 Subject: [PATCH] [WPB 5356] fix brig flaking (#3769) * [feat] move testKeyPacakgeUploadNoKey to integration * [feat] move testKeyPackageClaim to new integration test suite * [feat] testKeyPackagesSelfClaim to new integration test suite * [feat] move testKeyPackageRemoteClaim to new integration test suite * [chore] remove replaced brig tests and clean up --- changelog.d/3-bug-fixes/brig-flake | 2 +- integration/test/API/Brig.hs | 9 +- integration/test/Test/MLS/KeyPackage.hs | 135 ++++++++++++ services/brig/brig.cabal | 1 - .../brig/test/integration/API/Internal.hs | 11 +- services/brig/test/integration/API/MLS.hs | 202 ------------------ services/brig/test/integration/Run.hs | 3 - 7 files changed, 152 insertions(+), 211 deletions(-) delete mode 100644 services/brig/test/integration/API/MLS.hs diff --git a/changelog.d/3-bug-fixes/brig-flake b/changelog.d/3-bug-fixes/brig-flake index af71cad5d8f..9c330a346e4 100644 --- a/changelog.d/3-bug-fixes/brig-flake +++ b/changelog.d/3-bug-fixes/brig-flake @@ -1 +1 @@ -don't use shell when communicating with mls-test-cli +don't use shell when communicating with mls-test-cli, move flaking brig tests over to new integration testsuite diff --git a/integration/test/API/Brig.hs b/integration/test/API/Brig.hs index 8e1c390862a..36d428db1fb 100644 --- a/integration/test/API/Brig.hs +++ b/integration/test/API/Brig.hs @@ -280,15 +280,18 @@ uploadKeyPackages cid kps = do & addJSONObject ["key_packages" .= map (T.decodeUtf8 . Base64.encode) kps] ) -claimKeyPackages :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response -claimKeyPackages suite u v = do +claimKeyPackagesWithParams :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> [(String, String)] -> App Response +claimKeyPackagesWithParams suite u v params = do (targetDom, targetUid) <- objQid v req <- baseRequest u Brig Versioned $ "/mls/key-packages/claim/" <> targetDom <> "/" <> targetUid submit "POST" $ req - & addQueryParams [("ciphersuite", suite.code)] + & addQueryParams ([("ciphersuite", suite.code)] <> params) + +claimKeyPackages :: (MakesValue u, MakesValue v) => Ciphersuite -> u -> v -> App Response +claimKeyPackages suite u v = claimKeyPackagesWithParams suite u v [] countKeyPackages :: Ciphersuite -> ClientIdentity -> App Response countKeyPackages suite cid = do diff --git a/integration/test/Test/MLS/KeyPackage.hs b/integration/test/Test/MLS/KeyPackage.hs index 78c7e87e0b5..69e8c84fbdf 100644 --- a/integration/test/Test/MLS/KeyPackage.hs +++ b/integration/test/Test/MLS/KeyPackage.hs @@ -1,3 +1,7 @@ +-- FUTUREWORK: +-- GET /mls/key-packages/self/:client/count should be +-- tested with expired package + module Test.MLS.KeyPackage where import API.Brig @@ -47,6 +51,137 @@ testKeyPackageMultipleCiphersuites = do resp.status `shouldMatchInt` 200 resp.json %. "count" `shouldMatchInt` 1 +testKeyPackageUploadNoKey :: App () +testKeyPackageUploadNoKey = do + alice <- randomUser OwnDomain def + alice1 <- do + cid <- createWireClient alice + initMLSClient def cid + pure cid + + (kp, _) <- generateKeyPackage alice1 def + + -- if we upload a keypackage without a key, + -- we get a bad request + uploadKeyPackages alice1 [kp] `bindResponse` \resp -> do + resp.status `shouldMatchInt` 400 + + -- there should be no keypackages after getting + -- a rejection by the backend + countKeyPackages def alice1 `bindResponse` \resp -> do + resp.json %. "count" `shouldMatchInt` 0 + resp.status `shouldMatchInt` 200 + +testKeyPackageClaim :: App () +testKeyPackageClaim = do + alice <- randomUser OwnDomain def + alices@[alice1, _alice2] <- replicateM 2 do + createMLSClient def alice + + for_ alices \alicei -> replicateM 3 do + uploadNewKeyPackage alicei + + bob <- randomUser OwnDomain def + bobs <- replicateM 3 do + createMLSClient def bob + + for_ bobs \bobi -> + claimKeyPackages def bobi alice `bindResponse` \resp -> do + ks <- resp.json %. "key_packages" & asList + + -- all of the keypackages should by issued by alice + for_ ks \k -> + (k %. "user") `shouldMatch` (alice %. "id") + + -- every claimed keypackage bundle should contain + -- exactly one of each of the keypackages issued by + -- alice + for ks (%. "client") + >>= (`shouldMatchSet` map (.client) alices) + + -- claiming keypckages should return 200 + resp.status `shouldMatchInt` 200 + + -- bob has claimed all keypackages by alice, so there should + -- be none left + countKeyPackages def alice1 `bindResponse` \resp -> do + resp.json %. "count" `shouldMatchInt` 0 + resp.status `shouldMatchInt` 200 + +testKeyPackageSelfClaim :: App () +testKeyPackageSelfClaim = do + alice <- randomUser OwnDomain def + alices@[alice1, alice2] <- replicateM 2 do + createMLSClient def alice + for_ alices \alicei -> replicateM 3 do + uploadNewKeyPackage alicei + + -- claim own keypackages + claimKeyPackages def alice1 alice `bindResponse` \resp -> do + resp.status `shouldMatchInt` 200 + + resp.json %. "key_packages" + & asList + -- the keypackage claimed by client 1 should be issued by + -- client 2 + >>= \[v] -> v %. "client" `shouldMatch` alice2.client + + -- - the keypackages of client 1 (claimer) should still be there + -- - two of the keypackages of client 2 (claimee) should be stil + -- there + for_ (zip alices [3, 2]) \(alicei, n) -> + countKeyPackages def alicei `bindResponse` \resp -> do + resp.json %. "count" `shouldMatchInt` n + resp.status `shouldMatchInt` 200 + + bob <- randomUser OwnDomain def + bobs <- replicateM 2 do + createMLSClient def bob + + -- skip own should only apply to own keypackages, hence + -- bob claiming alices keypackages should work as normal + a1s <- alice1 %. "client_id" & asString + for_ bobs \bobi -> + claimKeyPackagesWithParams def bobi alice [("skip_own", a1s)] `bindResponse` \resp -> do + (resp.json %. "key_packages" & asList <&> length) `shouldMatchInt` 2 + resp.status `shouldMatchInt` 200 + + -- alices keypackages should be gone after bob claimed them + for_ (zip alices [1, 0]) \(alicei, n) -> + countKeyPackages def alicei `bindResponse` \resp -> do + resp.json %. "count" `shouldMatchInt` n + resp.status `shouldMatchInt` 200 + +testKeyPackageRemoteClaim :: App () +testKeyPackageRemoteClaim = do + alice <- randomUser OwnDomain def + alice1 <- createMLSClient def alice + + charlie <- randomUser OtherDomain def + charlie1 <- createMLSClient def charlie + + refCharlie <- uploadNewKeyPackage charlie1 + refAlice <- uploadNewKeyPackage alice1 + + -- the user should be able to claim the keypackage of + -- a remote user and vice versa + for_ + [ (alice1, charlie, charlie1, refCharlie), + (charlie1, alice, alice1, refAlice) + ] + \(claimer, claimee, uploader, reference) -> do + claimKeyPackages def claimer claimee `bindResponse` \resp -> do + -- make sure that the reference match on the keypackages + [kp] <- resp.json %. "key_packages" & asList + kp %. "key_package_ref" `shouldMatch` reference + resp.status `shouldMatchInt` 200 + + -- the key package of the uploading client should be gone + -- after claiming + countKeyPackages def uploader `bindResponse` \resp -> do + resp.json %. "count" `shouldMatchInt` 0 + resp.status `shouldMatchInt` 200 + testKeyPackageCount :: HasCallStack => Ciphersuite -> App () testKeyPackageCount cs = do alice <- randomUser OwnDomain def diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 57b0e8b7d56..05a39d7d548 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -405,7 +405,6 @@ executable brig-integration API.Internal API.Internal.Util API.Metrics - API.MLS API.MLS.Util API.OAuth API.Provider diff --git a/services/brig/test/integration/API/Internal.hs b/services/brig/test/integration/API/Internal.hs index d69b7c55617..b0f7704123b 100644 --- a/services/brig/test/integration/API/Internal.hs +++ b/services/brig/test/integration/API/Internal.hs @@ -24,7 +24,6 @@ module API.Internal where import API.Internal.Util -import API.MLS hiding (tests) import API.MLS.Util import Bilge import Bilge.Assert @@ -241,6 +240,16 @@ testGetMlsClients brig = do cs1 <- getClients liftIO $ toList cs1 @?= [ClientInfo c True] +createClient :: Brig -> Qualified UserId -> Int -> Http ClientId +createClient brig u i = + fmap clientId $ + responseJsonError + =<< addClient + brig + (qUnqualified u) + (defNewClient PermanentClientType [somePrekeys !! i] (someLastPrekeys !! i)) + (Request -> Request) -> UserId -> m ResponseLBS getFeatureConfig galley uid = do get $ apiVersion "v1" . galley . paths ["feature-configs", featureNameBS @cfg] . zUser uid diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs deleted file mode 100644 index 72f451e3a0a..00000000000 --- a/services/brig/test/integration/API/MLS.hs +++ /dev/null @@ -1,202 +0,0 @@ --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module API.MLS where - -import API.MLS.Util -import Bilge -import Bilge.Assert (( Brig -> Opts -> TestTree -tests m b opts = - testGroup - "MLS" - [ test m "POST /mls/key-packages/self/:client (no public keys)" (testKeyPackageUploadNoKey b), - -- FUTUREWORK test m "GET /mls/key-packages/self/:client/count (expired package)" (testKeyPackageExpired b), - test m "GET /mls/key-packages/claim/local/:user" (testKeyPackageClaim b), - test m "GET /mls/key-packages/claim/local/:user - self claim" (testKeyPackageSelfClaim b), - test m "GET /mls/key-packages/claim/remote/:user" (testKeyPackageRemoteClaim opts b) - ] - -testKeyPackageUploadNoKey :: Brig -> Http () -testKeyPackageUploadNoKey brig = do - u <- userQualifiedId <$> randomUser brig - c <- createClient brig u 0 - withSystemTempDirectory "mls" $ \tmp -> - uploadKeyPackages brig tmp def {kiSetKey = DontSetKey} u c 5 - - count <- getKeyPackageCount brig u c - liftIO $ count @?= 0 - -testKeyPackageExpired :: Brig -> Http () -testKeyPackageExpired brig = do - u <- userQualifiedId <$> randomUser brig - let lifetime = 3 # Second - [c1, c2] <- for [(0, Just lifetime), (1, Nothing)] $ \(i, lt) -> do - c <- createClient brig u i - -- upload 1 key package for each client - withSystemTempDirectory "mls" $ \tmp -> - uploadKeyPackages brig tmp def {kiLifetime = lt} u c 1 - pure c - for_ [(c1, 1), (c2, 1)] $ \(cid, expectedCount) -> do - count <- getKeyPackageCount brig u cid - liftIO $ count @?= expectedCount - -- wait for c1's key package to expire - threadDelay (fromIntegral ((lifetime + 4 # Second) #> MicroSecond)) - - -- c1's key package has expired by now - for_ [(c1, 0), (c2, 1)] $ \(cid, expectedCount) -> do - count <- getKeyPackageCount brig u cid - liftIO $ count @?= expectedCount - -testKeyPackageClaim :: Brig -> Http () -testKeyPackageClaim brig = do - -- setup a user u with two clients c1 and c2 - u <- userQualifiedId <$> randomUser brig - [c1, c2] <- for [0, 1] $ \i -> do - c <- createClient brig u i - -- upload 3 key packages for each client - withSystemTempDirectory "mls" $ \tmp -> - uploadKeyPackages brig tmp def u c 3 - pure c - - -- claim packages for both clients of u - u' <- userQualifiedId <$> randomUser brig - bundle :: KeyPackageBundle <- - responseJsonError - =<< post - ( brig - . paths ["mls", "key-packages", "claim", toByteString' (qDomain u), toByteString' (qUnqualified u)] - . zUser (qUnqualified u') - ) - (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c1), (u, c2)] - - -- check that we have one fewer key package now - for_ [c1, c2] $ \c -> do - count <- getKeyPackageCount brig u c - liftIO $ count @?= 2 - -testKeyPackageSelfClaim :: Brig -> Http () -testKeyPackageSelfClaim brig = do - -- setup a user u with two clients c1 and c2 - u <- userQualifiedId <$> randomUser brig - [c1, c2] <- for [0, 1] $ \i -> do - c <- createClient brig u i - -- upload 3 key packages for each client - withSystemTempDirectory "mls" $ \tmp -> - uploadKeyPackages brig tmp def u c 3 - pure c - - -- claim own packages but skip the first - do - bundle :: KeyPackageBundle <- - responseJsonError - =<< post - ( brig - . paths ["mls", "key-packages", "claim", toByteString' (qDomain u), toByteString' (qUnqualified u)] - . zUser (qUnqualified u) - . zClient c1 - ) - (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c2)] - - -- check that we still have all keypackages for client c1 - count <- getKeyPackageCount brig u c1 - liftIO $ count @?= 3 - - -- if another user sets skip_own, nothing is skipped - do - u' <- userQualifiedId <$> randomUser brig - bundle :: KeyPackageBundle <- - responseJsonError - =<< post - ( brig - . paths ["mls", "key-packages", "claim", toByteString' (qDomain u), toByteString' (qUnqualified u)] - . queryItem "skip_own" (toByteString' c1) - . zUser (qUnqualified u') - ) - (e.user, e.client)) bundle.entries @?= Set.fromList [(u, c1), (u, c2)] - - -- check package counts again - for_ [(c1, 2), (c2, 1)] $ \(c, n) -> do - count <- getKeyPackageCount brig u c - liftIO $ count @?= n - -testKeyPackageRemoteClaim :: Opts -> Brig -> Http () -testKeyPackageRemoteClaim opts brig = do - u <- fakeRemoteUser - - u' <- userQualifiedId <$> randomUser brig - - qcid <- mkClientIdentity u <$> randomClient - entries <- withSystemTempDirectory "mls" $ \tmp -> do - initStore tmp qcid - replicateM 2 $ do - (r, kp) <- generateKeyPackage tmp qcid Nothing - pure $ - KeyPackageBundleEntry - { user = u, - client = ciClient qcid, - ref = kp, - keyPackage = KeyPackageData . raw $ r - } - let mockBundle = KeyPackageBundle (Set.fromList entries) - (bundle :: KeyPackageBundle, _reqs) <- - liftIO . withTempMockFederator opts (Aeson.encode mockBundle) $ - responseJsonError - =<< post - ( brig - . paths ["mls", "key-packages", "claim", toByteString' (qDomain u), toByteString' (qUnqualified u)] - . zUser (qUnqualified u') - ) - Qualified UserId -> Int -> Http ClientId -createClient brig u i = - fmap clientId $ - responseJsonError - =<< addClient - brig - (qUnqualified u) - (defNewClient PermanentClientType [somePrekeys !! i] (someLastPrekeys !! i)) -