[WPB-15151] eliminate legahold test redundancy (#4386)

* Add line breaks in code.

* Translate one more test (that was skipped from all runs before).

* Aesthetic surgery.

---------

Co-authored-by: Sven Tennie <[email protected]>

changelog.d/5-internal/wpb-15151-revive-and-translate-tests

@@ -0,0 +1 @@
+Revive and translate old integration test.

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

integration/test/API/GalleyInternal.hs

@@ -98,15 +98,27 @@ 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
   p <- make payload
   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

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 = ensureLHFeatureConfigForServer 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,29 @@ testNoCommonVersion = do
     bindResponse (requestLegalHoldDevice tid alice bob) $ \resp -> do
       resp.status `shouldMatchInt` 500
       resp.json %. "label" `shouldMatch` "server-error"
+
+-- | 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.
+--
+-- 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)
+
+-- | 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
+ensureLHFeatureConfigForServer ExplicitConsent app =
+  withModifiedBackend (def {galleyCfg = upd}) app
+  where
+    upd = setField "settings.featureFlags.legalhold" "disabled-by-default"

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

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