From dc544f071cdd44d072318d03a5c6d4508b44947b Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 20 Dec 2024 13:00:59 +0100 Subject: [PATCH 1/7] Add line breaks in code. --- integration/test/API/Galley.hs | 17 +++++++++++++++-- integration/test/API/GalleyInternal.hs | 16 ++++++++++++++-- 2 files changed, 29 insertions(+), 4 deletions(-) diff --git a/integration/test/API/Galley.hs b/integration/test/API/Galley.hs index 6fadfa02f6e..2d9aa7cd9d4 100644 --- a/integration/test/API/Galley.hs +++ b/integration/test/API/Galley.hs @@ -717,10 +717,23 @@ getTeamFeature user tid featureName = do req <- baseRequest user Galley Versioned (joinHttpPath ["teams", tidStr, "features", featureName]) submit "GET" req -setTeamFeatureConfig :: (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => user -> team -> featureName -> payload -> App Response +setTeamFeatureConfig :: + (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => + user -> + team -> + featureName -> + payload -> + App Response setTeamFeatureConfig = setTeamFeatureConfigVersioned Versioned -setTeamFeatureConfigVersioned :: (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => Versioned -> user -> team -> featureName -> payload -> App Response +setTeamFeatureConfigVersioned :: + (HasCallStack, MakesValue user, MakesValue team, MakesValue featureName, MakesValue payload) => + Versioned -> + user -> + team -> + featureName -> + payload -> + App Response setTeamFeatureConfigVersioned versioned user team featureName payload = do tid <- asString team fn <- asString featureName diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 65592f37108..be0d09fbecf 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -98,7 +98,13 @@ generateVerificationCode' domain email = do emailStr <- asString email submit "POST" $ req & addJSONObject ["email" .= emailStr, "action" .= "login"] -setTeamFeatureConfig :: (HasCallStack, MakesValue domain, MakesValue team, MakesValue featureName, MakesValue payload) => domain -> team -> featureName -> payload -> App Response +setTeamFeatureConfig :: + (HasCallStack, MakesValue domain, MakesValue team, MakesValue featureName, MakesValue payload) => + domain -> + team -> + featureName -> + payload -> + App Response setTeamFeatureConfig domain team featureName payload = do tid <- asString team fn <- asString featureName @@ -106,7 +112,13 @@ setTeamFeatureConfig domain team featureName payload = do req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", fn] submit "PUT" $ req & addJSON p -patchTeamFeatureConfig :: (HasCallStack, MakesValue domain, MakesValue team, MakesValue featureName, MakesValue payload) => domain -> team -> featureName -> payload -> App Response +patchTeamFeatureConfig :: + (HasCallStack, MakesValue domain, MakesValue team, MakesValue featureName, MakesValue payload) => + domain -> + team -> + featureName -> + payload -> + App Response patchTeamFeatureConfig domain team featureName payload = do tid <- asString team fn <- asString featureName From 3462100079070035216b085c893eb797fe3b96ad Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 20 Dec 2024 14:10:46 +0100 Subject: [PATCH 2/7] Translate one more test (that was skipped from all runs before). --- integration/test/Test/LegalHold.hs | 40 ++++++++++++++--- .../API/Teams/LegalHold/DisabledByDefault.hs | 44 ------------------- 2 files changed, 34 insertions(+), 50 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index ee2a9e1f4cf..61c03575379 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -107,11 +107,11 @@ testLHPreventAddingNonConsentingUsers v = do m %. "qualified_id" mems `shouldMatchSet` forM us (\m -> m %. "qualified_id") -testLHGetAndUpdateSettings :: (HasCallStack) => LhApiVersion -> App () -testLHGetAndUpdateSettings v = do +testLHGetAndUpdateSettings :: (HasCallStack) => ImplicitConsent -> LhApiVersion -> App () +testLHGetAndUpdateSettings implicitConsent v = setLHFeatureConfigForServer implicitConsent $ \dom -> do withMockServer def (lhMockAppV v) $ \lhDomAndPort _chan -> do - (owner, tid, [alice]) <- createTeam OwnDomain 2 - stranger <- randomUser OwnDomain def + (owner, tid, [alice]) <- createTeam dom 2 + stranger <- randomUser dom def let getSettingsWorks :: (HasCallStack) => Value -> String -> App () getSettingsWorks target status = bindResponse (getLegalHoldSettings tid target) $ \resp -> do @@ -127,8 +127,13 @@ testLHGetAndUpdateSettings v = do getSettingsWorks owner "disabled" getSettingsWorks alice "disabled" - legalholdWhitelistTeam tid owner >>= assertSuccess - legalholdIsTeamInWhitelist tid owner >>= assertSuccess + case implicitConsent of + ImplicitConsent -> do + legalholdWhitelistTeam tid owner >>= assertSuccess + legalholdIsTeamInWhitelist tid owner >>= assertSuccess + ExplicitConsent -> do + let payload = object ["status" .= "enabled"] -- legalhold has implicit lock status "unlocked" + API.GalleyInternal.setTeamFeatureConfig dom tid "legalhold" payload >>= assertSuccess getSettingsFails stranger getSettingsWorks owner "not_configured" @@ -1102,3 +1107,26 @@ testNoCommonVersion = do bindResponse (requestLegalHoldDevice tid alice bob) $ \resp -> do resp.status `shouldMatchInt` 500 resp.json %. "label" `shouldMatch` "server-error" + +-- | LH can be configured i a way that does not require users to give preliminary consent to +-- LH when being added to a team. The user still has to approve the LH device before the +-- recording starts. This is called "implicit consent", was introduced to accomodate specific +-- work flows, and there is some hope that it'll be removed in the future. +-- +-- Explicit consent requires users to consent on entering the team, and then approve the +-- actual being put under recording again if it happens. +-- +-- This flag allows to make tests run through both configurations with minimal adjustment. +data ImplicitConsent = ImplicitConsent | ExplicitConsent + deriving (Eq, Show, Generic) + +setLHFeatureConfigForServer :: ImplicitConsent -> (String {- domain -} -> App ()) -> App () +setLHFeatureConfigForServer ImplicitConsent app = + -- we could do `setField "settings.featureFlags.legalhold" + -- "whitelist-teams-and-implicit-consent"`, but this is already the default. + -- TODO: make this an assertion, not a comment! + app =<< asString OwnDomain +setLHFeatureConfigForServer ExplicitConsent app = + withModifiedBackend (def {galleyCfg = upd}) app + where + upd = setField "settings.featureFlags.legalhold" "disabled-by-default" diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index c5d2cebc175..8f7194254a2 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -84,7 +84,6 @@ tests s = testOnlyIfLhEnabled s "DELETE /teams/{tid}/legalhold/{uid}" testDisableLegalHoldForUser, -- legal hold settings testOnlyIfLhEnabled s "POST /teams/{tid}/legalhold/settings" testCreateLegalHoldTeamSettings, - testOnlyIfLhEnabled s "GET /teams/{tid}/legalhold/settings" testGetLegalHoldTeamSettings, testOnlyIfLhEnabled s "DELETE /teams/{tid}/legalhold/settings" testRemoveLegalHoldFromTeam, testOnlyIfLhEnabled s "GET, PUT [/i]?/teams/{tid}/legalhold" testEnablePerTeam, testOnlyIfLhEnabled s "GET, PUT [/i]?/teams/{tid}/legalhold - too large" testEnablePerTeamTooLarge, @@ -400,49 +399,6 @@ testCreateLegalHoldTeamSettings = do -- synchronously and respond with 201 withTestService (lhapp Working) (lhtest Working) -testGetLegalHoldTeamSettings :: TestM () -testGetLegalHoldTeamSettings = do - (owner, tid) <- createBindingTeam - stranger <- randomUser - member <- randomUser - addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing - let lhapp :: Chan () -> Application - lhapp _ch _req res = res $ responseLBS status200 mempty mempty - withTestService lhapp $ \lhPort _ -> do - -- returns 403 if user is not in team. - newService <- newLegalHoldService lhPort - getSettings stranger tid !!! testResponse 403 (Just "no-team-member") - -- returns 200 with corresp. status if legalhold for team is disabled - do - let respOk :: ResponseLBS -> TestM () - respOk resp = liftIO $ do - assertEqual "bad status code" 200 (statusCode resp) - assertEqual "bad body" ViewLegalHoldServiceDisabled (responseJsonUnsafe resp) - getSettings owner tid >>= respOk - getSettings member tid >>= respOk - putEnabled tid Public.FeatureStatusEnabled -- enable it for this team - - -- returns 200 with corresp. status if legalhold for team is enabled, but not configured - do - let respOk :: ResponseLBS -> TestM () - respOk resp = liftIO $ do - assertEqual "bad status code" 200 (statusCode resp) - assertEqual "bad body" ViewLegalHoldServiceNotConfigured (responseJsonUnsafe resp) - getSettings owner tid >>= respOk - getSettings member tid >>= respOk - postSettings owner tid newService !!! testResponse 201 Nothing - -- returns legal hold service info if team is under legal hold and user is in team (even - -- no permissions). - ViewLegalHoldService service <- getSettingsTyped member tid - liftIO $ do - let sKey = newLegalHoldServiceKey newService - Just (_, fpr) <- validateServiceKey sKey - assertEqual "viewLegalHoldServiceTeam" tid (viewLegalHoldServiceTeam service) - assertEqual "viewLegalHoldServiceUrl" (newLegalHoldServiceUrl newService) (viewLegalHoldServiceUrl service) - assertEqual "viewLegalHoldServiceFingerprint" fpr (viewLegalHoldServiceFingerprint service) - assertEqual "viewLegalHoldServiceKey" sKey (viewLegalHoldServiceKey service) - assertEqual "viewLegalHoldServiceAuthToken" (newLegalHoldServiceToken newService) (viewLegalHoldServiceAuthToken service) - testRemoveLegalHoldFromTeam :: TestM () testRemoveLegalHoldFromTeam = do (owner, tid) <- createBindingTeam From 1c0268c4c208d0af64cfd41107ecf3a9736b6f8a Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 20 Dec 2024 14:43:50 +0100 Subject: [PATCH 3/7] Aesthetic surgery. --- integration/test/Testlib/ModService.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs index 59b81e68204..83b5cfcf900 100644 --- a/integration/test/Testlib/ModService.hs +++ b/integration/test/Testlib/ModService.hs @@ -56,7 +56,7 @@ import Prelude withModifiedBackend :: (HasCallStack) => ServiceOverrides -> ((HasCallStack) => String -> App a) -> App a withModifiedBackend overrides k = - startDynamicBackends [overrides] (\domains -> k (head domains)) + startDynamicBackends [overrides] (\[domains] -> k domains) copyDirectoryRecursively :: FilePath -> FilePath -> IO () copyDirectoryRecursively from to = do From aa7cfa23f97f1b20c25152a101a1d1ea7efae85f Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 20 Dec 2024 14:48:33 +0100 Subject: [PATCH 4/7] Changelog. --- changelog.d/5-internal/wpb-15151-revive-and-translate-tests | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/wpb-15151-revive-and-translate-tests diff --git a/changelog.d/5-internal/wpb-15151-revive-and-translate-tests b/changelog.d/5-internal/wpb-15151-revive-and-translate-tests new file mode 100644 index 00000000000..4e6263ee994 --- /dev/null +++ b/changelog.d/5-internal/wpb-15151-revive-and-translate-tests @@ -0,0 +1 @@ +Revive and translate old integration test. \ No newline at end of file From 17090e2a5660559eda8a2c04b5ffea4fb3fcd4b5 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 23 Dec 2024 09:19:14 +0100 Subject: [PATCH 5/7] hi ci From 64193e79b904121608437839b93aae37b70b0d47 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Mon, 23 Dec 2024 09:39:34 +0100 Subject: [PATCH 6/7] Update integration/test/Test/LegalHold.hs Co-authored-by: Sven Tennie --- integration/test/Test/LegalHold.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 61c03575379..88f5a44810d 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -1108,7 +1108,7 @@ testNoCommonVersion = do resp.status `shouldMatchInt` 500 resp.json %. "label" `shouldMatch` "server-error" --- | LH can be configured i a way that does not require users to give preliminary consent to +-- | LH can be configured in a way that does not require users to give preliminary consent to -- LH when being added to a team. The user still has to approve the LH device before the -- recording starts. This is called "implicit consent", was introduced to accomodate specific -- work flows, and there is some hope that it'll be removed in the future. From 542bcc6ba545214e2f1c71077d5147d31e8aa433 Mon Sep 17 00:00:00 2001 From: Sven Tennie Date: Mon, 23 Dec 2024 10:25:18 +0100 Subject: [PATCH 7/7] Assert expected server config ... to guard against accidental change. --- integration/test/Test/LegalHold.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/integration/test/Test/LegalHold.hs b/integration/test/Test/LegalHold.hs index 88f5a44810d..e8efce43287 100644 --- a/integration/test/Test/LegalHold.hs +++ b/integration/test/Test/LegalHold.hs @@ -108,7 +108,7 @@ testLHPreventAddingNonConsentingUsers v = do mems `shouldMatchSet` forM us (\m -> m %. "qualified_id") testLHGetAndUpdateSettings :: (HasCallStack) => ImplicitConsent -> LhApiVersion -> App () -testLHGetAndUpdateSettings implicitConsent v = setLHFeatureConfigForServer implicitConsent $ \dom -> do +testLHGetAndUpdateSettings implicitConsent v = ensureLHFeatureConfigForServer implicitConsent $ \dom -> do withMockServer def (lhMockAppV v) $ \lhDomAndPort _chan -> do (owner, tid, [alice]) <- createTeam dom 2 stranger <- randomUser dom def @@ -1120,13 +1120,16 @@ testNoCommonVersion = do data ImplicitConsent = ImplicitConsent | ExplicitConsent deriving (Eq, Show, Generic) -setLHFeatureConfigForServer :: ImplicitConsent -> (String {- domain -} -> App ()) -> App () -setLHFeatureConfigForServer ImplicitConsent app = - -- we could do `setField "settings.featureFlags.legalhold" - -- "whitelist-teams-and-implicit-consent"`, but this is already the default. - -- TODO: make this an assertion, not a comment! +-- | Ensure that the LH config is as expected: Either by expecting it from the +-- current server's config. Or, by creating a new one. +ensureLHFeatureConfigForServer :: ImplicitConsent -> (String {- domain -} -> App ()) -> App () +ensureLHFeatureConfigForServer ImplicitConsent app = do + -- This should be set in the server's config file. Thus, we only assert here + -- (to guard against accidential change.) + cfg <- readServiceConfig Galley + (cfg %. "settings.featureFlags.legalhold") `shouldMatch` "whitelist-teams-and-implicit-consent" app =<< asString OwnDomain -setLHFeatureConfigForServer ExplicitConsent app = +ensureLHFeatureConfigForServer ExplicitConsent app = withModifiedBackend (def {galleyCfg = upd}) app where upd = setField "settings.featureFlags.legalhold" "disabled-by-default"