diff --git a/changelog.d/3-bug-fixes/wpb8713-get-feature-configs-end-point-performance b/changelog.d/3-bug-fixes/wpb8713-get-feature-configs-end-point-performance new file mode 100644 index 00000000000..f38dbc8ccc2 --- /dev/null +++ b/changelog.d/3-bug-fixes/wpb8713-get-feature-configs-end-point-performance @@ -0,0 +1 @@ + Optimize getting all feature configs diff --git a/integration/test/API/GalleyInternal.hs b/integration/test/API/GalleyInternal.hs index 877c6db2df5..281c86e6a18 100644 --- a/integration/test/API/GalleyInternal.hs +++ b/integration/test/API/GalleyInternal.hs @@ -45,7 +45,7 @@ setTeamFeatureStatusExpectHttpStatus :: (HasCallStack, MakesValue domain, MakesV setTeamFeatureStatusExpectHttpStatus domain team featureName status httpStatus = do tid <- asString team req <- baseRequest domain Galley Unversioned $ joinHttpPath ["i", "teams", tid, "features", featureName] - bindResponse (submit "PATCH" $ req & addJSONObject ["status" .= status]) $ \res -> + bindResponse (submit "PATCH" $ req & addJSONObject ["status" .= status]) $ \res -> do res.status `shouldMatchInt` httpStatus setTeamFeatureLockStatus :: (HasCallStack, MakesValue domain, MakesValue team) => domain -> team -> String -> String -> App () diff --git a/integration/test/Test/FeatureFlags.hs b/integration/test/Test/FeatureFlags.hs index 7d522b61320..6d68d58845d 100644 --- a/integration/test/Test/FeatureFlags.hs +++ b/integration/test/Test/FeatureFlags.hs @@ -141,7 +141,6 @@ testExposeInvitationURLsToTeamAdminConfig = do runCodensity (acquireResources 1 resourcePool) $ \[testBackend] -> do let domain = testBackend.berDomain - -- Happy case: DB has no config for the team let testNoAllowlistEntry = runCodensity (startDynamicBackend testBackend $ cfgExposeInvitationURLsTeamAllowlist ([] :: [String])) $ \_ -> do (owner, tid, _) <- createTeam domain 1 checkFeature "exposeInvitationURLsToTeamAdmin" owner tid disabledLocked @@ -150,6 +149,7 @@ testExposeInvitationURLsToTeamAdminConfig = do Internal.setTeamFeatureStatusExpectHttpStatus domain tid "exposeInvitationURLsToTeamAdmin" "disabled" 200 pure (owner, tid) + -- Happy case: DB has no config for the team (owner, tid) <- testNoAllowlistEntry -- Interesting case: The team is in the allow list @@ -172,12 +172,12 @@ checkFeature feature user tid expected = do bindResponse (Internal.getTeamFeature domain tidStr feature) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json `shouldMatch` expected - bindResponse (Public.getFeatureConfigs user) $ \resp -> do - resp.status `shouldMatchInt` 200 - resp.json %. feature `shouldMatch` expected bindResponse (Public.getTeamFeatures user tid) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json %. feature `shouldMatch` expected bindResponse (Public.getTeamFeature user tid feature) $ \resp -> do resp.status `shouldMatchInt` 200 resp.json `shouldMatch` expected + bindResponse (Public.getFeatureConfigs user) $ \resp -> do + resp.status `shouldMatchInt` 200 + resp.json %. feature `shouldMatch` expected diff --git a/libs/wire-api/test/unit/Test/Wire/API/Run.hs b/libs/wire-api/test/unit/Test/Wire/API/Run.hs index 5301f44cdc9..417d543e0e4 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Run.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Run.hs @@ -37,6 +37,7 @@ import Test.Wire.API.Routes.Version qualified as Routes.Version import Test.Wire.API.Routes.Version.Wai qualified as Routes.Version.Wai import Test.Wire.API.Swagger qualified as Swagger import Test.Wire.API.Team.Export qualified as Team.Export +import Test.Wire.API.Team.Feature qualified as Team.Feature import Test.Wire.API.Team.Member qualified as Team.Member import Test.Wire.API.User qualified as User import Test.Wire.API.User.Auth qualified as User.Auth @@ -69,5 +70,6 @@ main = unsafePerformIO Routes.Version.Wai.tests, RawJson.tests, OAuth.tests, - Password.tests + Password.tests, + Team.Feature.tests ] diff --git a/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs b/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs new file mode 100644 index 00000000000..60b634c9d17 --- /dev/null +++ b/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2024 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 Test.Wire.API.Team.Feature (tests) where + +import Imports +import Test.Tasty +import Test.Tasty.HUnit +import Wire.API.Team.Feature + +tests :: TestTree +tests = + testGroup + "Wire.API.Team.Feature" + [ testCase "no lock status in DB" testComputeFeatureConfigForTeamUserLsIsNothing, + testCase "feature is locked in DB" testComputeFeatureConfigForTeamUserLocked, + testCase "feature is unlocked in DB but has no feature status" testComputeFeatureConfigForTeamUserUnlocked, + testCase "feature is unlocked in DB and has feature status" testComputeFeatureConfigForTeamWithDbStatus + ] + +testComputeFeatureConfigForTeamUserLsIsNothing :: Assertion +testComputeFeatureConfigForTeamUserLsIsNothing = do + let mStatusDb = undefined + let mLockStatusDb = Nothing + let defStatus = + withStatus + FeatureStatusEnabled + LockStatusLocked + ExposeInvitationURLsToTeamAdminConfig + FeatureTTLUnlimited + let expected = defStatus + let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus + actual @?= expected + +testComputeFeatureConfigForTeamUserLocked :: Assertion +testComputeFeatureConfigForTeamUserLocked = do + let mStatusDb = undefined + let mLockStatusDb = Just LockStatusLocked + let defStatus = + withStatus + FeatureStatusEnabled + LockStatusLocked + ExposeInvitationURLsToTeamAdminConfig + FeatureTTLUnlimited + let expected = defStatus + let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus + actual @?= expected + +testComputeFeatureConfigForTeamUserUnlocked :: Assertion +testComputeFeatureConfigForTeamUserUnlocked = do + let mStatusDb = Nothing + let mLockStatusDb = Just LockStatusUnlocked + let defStatus = + withStatus + FeatureStatusEnabled + LockStatusLocked + ExposeInvitationURLsToTeamAdminConfig + FeatureTTLUnlimited + let expected = defStatus & setLockStatus LockStatusUnlocked + let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus + actual @?= expected + +testComputeFeatureConfigForTeamWithDbStatus :: Assertion +testComputeFeatureConfigForTeamWithDbStatus = do + let mStatusDb = + Just . forgetLock $ + withStatus + FeatureStatusDisabled + LockStatusUnlocked + ExposeInvitationURLsToTeamAdminConfig + FeatureTTLUnlimited + let mLockStatusDb = Just LockStatusUnlocked + let defStatus = undefined + let (Just expected) = withUnlocked <$> mStatusDb + let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus + actual @?= expected diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index a5ad166cf26..0268b23329d 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -652,6 +652,7 @@ test-suite wire-api-tests Test.Wire.API.Run Test.Wire.API.Swagger Test.Wire.API.Team.Export + Test.Wire.API.Team.Feature Test.Wire.API.Team.Member Test.Wire.API.User Test.Wire.API.User.Auth diff --git a/services/galley/default.nix b/services/galley/default.nix index 279ee871813..c0d7e2ae29c 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -27,6 +27,7 @@ , conduit , containers , cookie +, cql , crypton , crypton-x509 , currency-codes @@ -151,6 +152,7 @@ mkDerivation { cereal comonad containers + cql crypton crypton-x509 currency-codes diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 91556478195..019d07a9cd5 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -138,6 +138,7 @@ library Galley.Cassandra.Conversation.MLS Galley.Cassandra.ConversationList Galley.Cassandra.CustomBackend + Galley.Cassandra.GetAllTeamFeatureConfigs Galley.Cassandra.Instances Galley.Cassandra.LegalHold Galley.Cassandra.Proposal @@ -302,6 +303,7 @@ library , cereal >=0.4 , comonad , containers >=0.5 + , cql , crypton , crypton-x509 , currency-codes >=2.0 diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 5e66acec806..68bee82e68b 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -51,6 +51,7 @@ import Galley.API.Teams.Features import Galley.API.Update qualified as Update import Galley.API.Util import Galley.App +import Galley.Cassandra.TeamFeatures (getAllFeatureConfigsForServer) import Galley.Data.Conversation qualified as Data import Galley.Effects import Galley.Effects.BackendNotificationQueueAccess diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index e9085fca925..650db1ab3cb 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -22,7 +22,6 @@ module Galley.API.Teams.Features setFeatureStatusInternal, patchFeatureStatusInternal, getFeatureStatusForUser, - getAllFeatureConfigsForServer, getAllFeatureConfigsForTeam, getAllFeatureConfigsForUser, updateLockStatus, diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index 727d6646ae2..79f1b4e0ba8 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -193,15 +193,13 @@ getAllFeatureConfigsForUser zusr = do maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership case mbTeam of Just tid -> - getAllFeatureConfigsTeam tid + TeamFeatures.getAllFeatureConfigs tid Nothing -> getAllFeatureConfigsUser zusr getAllFeatureConfigsForTeam :: forall r. ( Member (ErrorS 'NotATeamMember) r, - Member (Input Opts) r, - Member LegalHoldStore r, Member TeamFeatureStore r, Member TeamStore r ) => @@ -211,7 +209,7 @@ getAllFeatureConfigsForTeam :: getAllFeatureConfigsForTeam luid tid = do zusrMembership <- getTeamMember tid (tUnqualified luid) maybe (throwS @'NotATeamMember) (const $ pure ()) zusrMembership - getAllFeatureConfigsTeam tid + TeamFeatures.getAllFeatureConfigs tid getAllFeatureConfigsForServer :: forall r. @@ -276,38 +274,6 @@ getAllFeatureConfigsUser uid = <*> getConfigForUser @EnforceFileDownloadLocationConfig uid <*> getConfigForUser @LimitedEventFanoutConfig uid -getAllFeatureConfigsTeam :: - forall r. - ( Member (Input Opts) r, - Member LegalHoldStore r, - Member TeamFeatureStore r, - Member TeamStore r - ) => - TeamId -> - Sem r AllFeatureConfigs -getAllFeatureConfigsTeam tid = - AllFeatureConfigs - <$> getConfigForTeam @LegalholdConfig tid - <*> getConfigForTeam @SSOConfig tid - <*> getConfigForTeam @SearchVisibilityAvailableConfig tid - <*> getConfigForTeam @SearchVisibilityInboundConfig tid - <*> getConfigForTeam @ValidateSAMLEmailsConfig tid - <*> getConfigForTeam @DigitalSignaturesConfig tid - <*> getConfigForTeam @AppLockConfig tid - <*> getConfigForTeam @FileSharingConfig tid - <*> getConfigForTeam @ClassifiedDomainsConfig tid - <*> getConfigForTeam @ConferenceCallingConfig tid - <*> getConfigForTeam @SelfDeletingMessagesConfig tid - <*> getConfigForTeam @GuestLinksConfig tid - <*> getConfigForTeam @SndFactorPasswordChallengeConfig tid - <*> getConfigForTeam @MLSConfig tid - <*> getConfigForTeam @ExposeInvitationURLsToTeamAdminConfig tid - <*> getConfigForTeam @OutlookCalIntegrationConfig tid - <*> getConfigForTeam @MlsE2EIdConfig tid - <*> getConfigForTeam @MlsMigrationConfig tid - <*> getConfigForTeam @EnforceFileDownloadLocationConfig tid - <*> getConfigForTeam @LimitedEventFanoutConfig tid - -- | Note: this is an internal function which doesn't cover all features, e.g. LegalholdConfig genericGetConfigForTeam :: forall cfg r. diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 53413f9bf33..5d874e86915 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -49,6 +49,7 @@ import Cassandra hiding (Set) import Cassandra.Util (initCassandraForService) import Control.Error hiding (err) import Control.Lens hiding ((.=)) +import Data.Id import Data.Metrics.Middleware import Data.Misc import Data.Qualified @@ -83,6 +84,7 @@ import Galley.Options hiding (brig, endpoint, federator) import Galley.Options qualified as O import Galley.Queue import Galley.Queue qualified as Q +import Galley.Types.Teams (FeatureLegalHold) import Galley.Types.Teams qualified as Teams import HTTP2.Client.Manager (Http2Manager, http2ManagerWithSSLCtx) import Imports hiding (forkIO) @@ -259,6 +261,8 @@ evalGalley e = . interpretWaiRoutes . runInputConst (e ^. options) . runInputConst (toLocalUnsafe (e ^. options . settings . federationDomain) ()) + . interpretTeamFeatureSpecialContext e + . runInputSem getAllFeatureConfigsForServer . interpretInternalTeamListToCassandra . interpretTeamListToCassandra . interpretLegacyConversationListToCassandra @@ -268,11 +272,11 @@ evalGalley e = . interpretTeamMemberStoreToCassandra lh . interpretTeamStoreToCassandra lh . interpretTeamNotificationStoreToCassandra - . interpretTeamFeatureStoreToCassandra . interpretServiceStoreToCassandra . interpretSearchVisibilityStoreToCassandra . interpretMemberStoreToCassandra . interpretLegalHoldStoreToCassandra lh + . interpretTeamFeatureStoreToCassandra . interpretCustomBackendStoreToCassandra . randomToIO . interpretSubConversationStoreToCassandra @@ -292,3 +296,10 @@ evalGalley e = . interpretBrigAccess where lh = view (options . settings . featureFlags . Teams.flagLegalHold) e + +interpretTeamFeatureSpecialContext :: Env -> Sem (Input (Maybe [TeamId], FeatureLegalHold) ': r) a -> Sem r a +interpretTeamFeatureSpecialContext e = + runInputConst + ( e ^. options . settings . exposeInvitationURLsTeamAllowlist, + e ^. options . settings . featureFlags . Teams.flagLegalHold + ) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs new file mode 100644 index 00000000000..d6b070c7f91 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Galley.Cassandra.GetAllTeamFeatureConfigs where + +import Cassandra +import Cassandra qualified as C +import Data.Id +import Data.Misc (HttpsUrl) +import Data.Time +import Database.CQL.Protocol +import Galley.Cassandra.Instances () +import Galley.Types.Teams (FeatureLegalHold (..)) +import Imports +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.MLS.CipherSuite +import Wire.API.Team.Feature + +data AllTeamFeatureConfigsRow = AllTeamFeatureConfigsRow + { -- legalhold + legalhold :: Maybe FeatureStatus, + -- sso + sso :: Maybe FeatureStatus, + -- search visibility + searchVisibility :: Maybe FeatureStatus, + -- validate saml emails + validateSamlEmails :: Maybe FeatureStatus, + -- digital signatures + digitalSignatures :: Maybe FeatureStatus, + -- app lock + appLock :: Maybe FeatureStatus, + appLockEnforce :: Maybe EnforceAppLock, + appLockInactivityTimeoutSecs :: Maybe Int32, + -- file sharing + fileSharing :: Maybe FeatureStatus, + fileSharingLock :: Maybe LockStatus, + -- self deleting messages + selfDeletingMessages :: Maybe FeatureStatus, + selfDeletingMessagesTtl :: Maybe Int32, + selfDeletingMessagesLock :: Maybe LockStatus, + -- conference calling + conferenceCalling :: Maybe FeatureStatus, + conferenceCallingTtl :: Maybe FeatureTTL, + -- guest links + guestLinks :: Maybe FeatureStatus, + guestLinksLock :: Maybe LockStatus, + -- snd factor + sndFactor :: Maybe FeatureStatus, + sndFactorLock :: Maybe LockStatus, + -- mls + mls :: Maybe FeatureStatus, + mlsDefaultProtocol :: Maybe ProtocolTag, + mlsToggleUsers :: Maybe (C.Set UserId), + mlsAllowedCipherSuites :: Maybe (C.Set CipherSuiteTag), + mlsDefaultCipherSuite :: Maybe CipherSuiteTag, + mlsSupportedProtocols :: Maybe (C.Set ProtocolTag), + mlsLock :: Maybe LockStatus, + -- mls e2eid + mlsE2eid :: Maybe FeatureStatus, + mlsE2eidGracePeriod :: Maybe Int32, + mlsE2eidAcmeDiscoverUrl :: Maybe HttpsUrl, + mlsE2eidLock :: Maybe LockStatus, + -- mls migration + mlsMigration :: Maybe FeatureStatus, + mlsMigrationStartTime :: Maybe UTCTime, + mlsMigrationFinalizeRegardlessAfter :: Maybe UTCTime, + mlsMigrationLock :: Maybe LockStatus, + -- expose invitation urls + exposeInvitationUrls :: Maybe FeatureStatus, + -- outlook calendar integration + outlookCalIntegration :: Maybe FeatureStatus, + outlookCalIntegrationLock :: Maybe LockStatus, + -- enforce download location + enforceDownloadLocation :: Maybe FeatureStatus, + enforceDownloadLocation_Location :: Maybe Text, + enforceDownloadLocationLock :: Maybe LockStatus, + -- limit event fanout + limitEventFanout :: Maybe FeatureStatus + } + deriving (Generic, Show) + +recordInstance ''AllTeamFeatureConfigsRow + +emptyRow :: AllTeamFeatureConfigsRow +emptyRow = + AllTeamFeatureConfigsRow + { legalhold = Nothing, + sso = Nothing, + searchVisibility = Nothing, + validateSamlEmails = Nothing, + digitalSignatures = Nothing, + appLock = Nothing, + appLockEnforce = Nothing, + appLockInactivityTimeoutSecs = Nothing, + fileSharing = Nothing, + fileSharingLock = Nothing, + selfDeletingMessages = Nothing, + selfDeletingMessagesTtl = Nothing, + selfDeletingMessagesLock = Nothing, + conferenceCalling = Nothing, + conferenceCallingTtl = Nothing, + guestLinks = Nothing, + guestLinksLock = Nothing, + sndFactor = Nothing, + sndFactorLock = Nothing, + mls = Nothing, + mlsDefaultProtocol = Nothing, + mlsToggleUsers = Nothing, + mlsAllowedCipherSuites = Nothing, + mlsDefaultCipherSuite = Nothing, + mlsSupportedProtocols = Nothing, + mlsLock = Nothing, + mlsE2eid = Nothing, + mlsE2eidGracePeriod = Nothing, + mlsE2eidAcmeDiscoverUrl = Nothing, + mlsE2eidLock = Nothing, + mlsMigration = Nothing, + mlsMigrationStartTime = Nothing, + mlsMigrationFinalizeRegardlessAfter = Nothing, + mlsMigrationLock = Nothing, + exposeInvitationUrls = Nothing, + outlookCalIntegration = Nothing, + outlookCalIntegrationLock = Nothing, + enforceDownloadLocation = Nothing, + enforceDownloadLocation_Location = Nothing, + enforceDownloadLocationLock = Nothing, + limitEventFanout = Nothing + } + +allFeatureConfigsFromRow :: + -- id of team of which we want to see the feature + TeamId -> + -- team id list is from "settings.exposeInvitationURLsTeamAllowlist" + Maybe [TeamId] -> + FeatureLegalHold -> + Bool -> + AllFeatureConfigs -> + AllTeamFeatureConfigsRow -> + AllFeatureConfigs +allFeatureConfigsFromRow ourteam allowListForExposeInvitationURLs featureLH hasTeamImplicitLegalhold serverConfigs row = + AllFeatureConfigs + { afcLegalholdStatus = legalholdComputeFeatureStatus row.legalhold, + afcSSOStatus = + computeConfig + row.sso + Nothing + FeatureTTLUnlimited + (Just SSOConfig) + serverConfigs.afcSSOStatus, + afcTeamSearchVisibilityAvailable = + computeConfig + row.searchVisibility + Nothing + FeatureTTLUnlimited + (Just SearchVisibilityAvailableConfig) + serverConfigs.afcTeamSearchVisibilityAvailable, + afcSearchVisibilityInboundConfig = + computeConfig + row.searchVisibility + Nothing + FeatureTTLUnlimited + (Just SearchVisibilityInboundConfig) + serverConfigs.afcSearchVisibilityInboundConfig, + afcValidateSAMLEmails = + computeConfig + row.validateSamlEmails + Nothing + FeatureTTLUnlimited + (Just ValidateSAMLEmailsConfig) + serverConfigs.afcValidateSAMLEmails, + afcDigitalSignatures = + computeConfig + row.digitalSignatures + Nothing + FeatureTTLUnlimited + (Just DigitalSignaturesConfig) + serverConfigs.afcDigitalSignatures, + afcAppLock = + computeConfig + row.appLock + Nothing + FeatureTTLUnlimited + appLockConfig + serverConfigs.afcAppLock, + afcFileSharing = + computeConfig + row.fileSharing + row.fileSharingLock + FeatureTTLUnlimited + (Just FileSharingConfig) + serverConfigs.afcFileSharing, + afcClassifiedDomains = + computeConfig Nothing Nothing FeatureTTLUnlimited Nothing serverConfigs.afcClassifiedDomains, + afcConferenceCalling = + computeConfig + row.conferenceCalling + Nothing + (fromMaybe FeatureTTLUnlimited row.conferenceCallingTtl) + (Just ConferenceCallingConfig) + serverConfigs.afcConferenceCalling, + afcSelfDeletingMessages = + computeConfig + row.selfDeletingMessages + row.selfDeletingMessagesLock + FeatureTTLUnlimited + selfDeletingMessagesConfig + serverConfigs.afcSelfDeletingMessages, + afcGuestLink = + computeConfig + row.guestLinks + row.guestLinksLock + FeatureTTLUnlimited + (Just GuestLinksConfig) + serverConfigs.afcGuestLink, + afcSndFactorPasswordChallenge = + computeConfig + row.sndFactor + row.sndFactorLock + FeatureTTLUnlimited + (Just SndFactorPasswordChallengeConfig) + serverConfigs.afcSndFactorPasswordChallenge, + afcMLS = + computeConfig + row.mls + row.mlsLock + FeatureTTLUnlimited + mlsConfig + serverConfigs.afcMLS, + afcExposeInvitationURLsToTeamAdmin = exposeInvitationURLsComputeFeatureStatus row.exposeInvitationUrls, + afcOutlookCalIntegration = + computeConfig + row.outlookCalIntegration + row.outlookCalIntegrationLock + FeatureTTLUnlimited + (Just OutlookCalIntegrationConfig) + serverConfigs.afcOutlookCalIntegration, + afcMlsE2EId = + computeConfig + row.mlsE2eid + row.mlsE2eidLock + FeatureTTLUnlimited + mlsE2eidConfig + serverConfigs.afcMlsE2EId, + afcMlsMigration = + computeConfig + row.mlsMigration + row.mlsMigrationLock + FeatureTTLUnlimited + mlsMigrationConfig + serverConfigs.afcMlsMigration, + afcEnforceFileDownloadLocation = + computeConfig + row.enforceDownloadLocation + row.enforceDownloadLocationLock + FeatureTTLUnlimited + downloadLocationConfig + serverConfigs.afcEnforceFileDownloadLocation, + afcLimitedEventFanout = + computeConfig + row.limitEventFanout + Nothing + FeatureTTLUnlimited + (Just LimitedEventFanoutConfig) + serverConfigs.afcLimitedEventFanout + } + where + computeConfig :: Maybe FeatureStatus -> Maybe LockStatus -> FeatureTTL -> Maybe cfg -> WithStatus cfg -> WithStatus cfg + computeConfig mDbStatus mDbLock dbTtl mDbCfg serverCfg = + let withStatusNoLock = case (mDbStatus, mDbCfg) of + (Just dbStatus, Just dbCfg) -> + Just $ + WithStatusNoLock + { wssTTL = dbTtl, + wssStatus = dbStatus, + wssConfig = dbCfg + } + _ -> Nothing + in computeFeatureConfigForTeamUser withStatusNoLock mDbLock serverCfg + + -- FUTUREWORK: the following lines are duplicated in + -- "Galley.Cassandra.TeamFeatures"; make sure the pairs don't diverge! + appLockConfig = AppLockConfig <$> row.appLockEnforce <*> row.appLockInactivityTimeoutSecs + + selfDeletingMessagesConfig = SelfDeletingMessagesConfig <$> row.selfDeletingMessagesTtl + + mlsConfig = + MLSConfig + <$> maybe (Just []) (Just . C.fromSet) row.mlsToggleUsers + <*> row.mlsDefaultProtocol + <*> maybe (Just []) (Just . C.fromSet) row.mlsAllowedCipherSuites + <*> row.mlsDefaultCipherSuite + <*> maybe (Just []) (Just . C.fromSet) row.mlsSupportedProtocols + + mlsE2eidConfig = + Just $ + MlsE2EIdConfig + (toGracePeriodOrDefault row.mlsE2eidGracePeriod) + row.mlsE2eidAcmeDiscoverUrl + where + toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime + toGracePeriodOrDefault = maybe (verificationExpiration $ wsConfig defFeatureStatus) fromIntegral + + mlsMigrationConfig = + Just $ + MlsMigrationConfig + { startTime = row.mlsMigrationStartTime, + finaliseRegardlessAfter = row.mlsMigrationFinalizeRegardlessAfter + } + + downloadLocationConfig = Just $ EnforceFileDownloadLocationConfig row.enforceDownloadLocation_Location + + -- FUTUREWORK: this duplicates logic hidden elsewhere for the other getters and setters. do not change lightly! + exposeInvitationURLsComputeFeatureStatus :: + Maybe FeatureStatus -> + WithStatus ExposeInvitationURLsToTeamAdminConfig + exposeInvitationURLsComputeFeatureStatus mFeatureStatus = + if ourteam `elem` fromMaybe [] allowListForExposeInvitationURLs + then + serverConfigs.afcExposeInvitationURLsToTeamAdmin + & maybe id setStatus mFeatureStatus + & setLockStatus LockStatusUnlocked + else serverConfigs.afcExposeInvitationURLsToTeamAdmin + + -- FUTUREWORK: this duplicates logic hidden elsewhere for the other getters and setters. do not change lightly! + legalholdComputeFeatureStatus :: Maybe FeatureStatus -> WithStatus LegalholdConfig + legalholdComputeFeatureStatus mStatusValue = setStatus status defFeatureStatus + where + status = + if isLegalHoldEnabledForTeam + then FeatureStatusEnabled + else FeatureStatusDisabled + isLegalHoldEnabledForTeam = + case featureLH of + FeatureLegalHoldDisabledPermanently -> False + FeatureLegalHoldDisabledByDefault -> maybe False ((==) FeatureStatusEnabled) mStatusValue + FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> hasTeamImplicitLegalhold + +getAllFeatureConfigs :: MonadClient m => Maybe [TeamId] -> FeatureLegalHold -> Bool -> AllFeatureConfigs -> TeamId -> m AllFeatureConfigs +getAllFeatureConfigs allowListForExposeInvitationURLs featureLH hasTeamImplicitLegalhold serverConfigs tid = do + mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure + $ allFeatureConfigsFromRow + tid + allowListForExposeInvitationURLs + featureLH + hasTeamImplicitLegalhold + serverConfigs + $ maybe emptyRow asRecord mRow + where + select :: + PrepQuery + R + (Identity TeamId) + (TupleType AllTeamFeatureConfigsRow) + select = + "select \ + \legalhold_status, \ + \sso_status, \ + \search_visibility_status, \ + \validate_saml_emails, \ + \digital_signatures, \ + \app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs, \ + \file_sharing, file_sharing_lock_status, \ + \self_deleting_messages_status, self_deleting_messages_ttl, self_deleting_messages_lock_status, \ + \conference_calling, ttl(conference_calling), \ + \guest_links_status, guest_links_lock_status, \ + \snd_factor_password_challenge_status, snd_factor_password_challenge_lock_status, \ + \\ + \mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, \ + \mls_default_ciphersuite, mls_supported_protocols, mls_lock_status, \ + \\ + \mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_lock_status, \ + \\ + \mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after, \ + \mls_migration_lock_status, \ + \\ + \expose_invitation_urls_to_team_admin, \ + \outlook_cal_integration_status, outlook_cal_integration_lock_status, \ + \enforce_file_download_location_status, enforce_file_download_location, enforce_file_download_location_lock_status, \ + \limited_event_fanout_status \ + \from team_features where team_id = ?" diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 8d415a918c4..dc8e82fe6ce 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -18,6 +18,7 @@ module Galley.Cassandra.TeamFeatures ( interpretTeamFeatureStoreToCassandra, getFeatureConfigMulti, + getAllFeatureConfigsForServer, ) where @@ -27,10 +28,15 @@ import Control.Monad.Trans.Maybe import Data.Id import Data.Misc (HttpsUrl) import Data.Time +import Galley.API.Teams.Features.Get +import Galley.Cassandra.GetAllTeamFeatureConfigs import Galley.Cassandra.Instances () import Galley.Cassandra.Store import Galley.Cassandra.Util +import Galley.Effects (LegalHoldStore) +import Galley.Effects.LegalHoldStore qualified as LH import Galley.Effects.TeamFeatureStore qualified as TFS +import Galley.Types.Teams (FeatureLegalHold) import Imports import Polysemy import Polysemy.Input @@ -43,6 +49,9 @@ import Wire.API.Team.Feature interpretTeamFeatureStoreToCassandra :: ( Member (Embed IO) r, Member (Input ClientState) r, + Member (Input AllFeatureConfigs) r, + Member (Input (Maybe [TeamId], FeatureLegalHold)) r, + Member LegalHoldStore r, Member TinyLog r ) => Sem (TFS.TeamFeatureStore ': r) a -> @@ -63,6 +72,18 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case TFS.SetFeatureLockStatus sing tid ls -> do logEffect "TeamFeatureStore.SetFeatureLockStatus" embedClient $ setFeatureLockStatus sing tid ls + TFS.GetAllFeatureConfigs tid -> do + logEffect "TeamFeatureStore.GetAllFeatureConfigs" + serverConfigs <- input + (allowListForExposeInvitationURLs, featureLH) <- input + hasTeamImplicitLegalhold <- LH.isTeamLegalholdWhitelisted tid + embedClient $ + getAllFeatureConfigs + allowListForExposeInvitationURLs + featureLH + hasTeamImplicitLegalhold + serverConfigs + tid getFeatureConfig :: MonadClient m => FeatureSingleton cfg -> TeamId -> m (Maybe (WithStatusNoLock cfg)) getFeatureConfig FeatureSingletonLegalholdConfig tid = getTrivialConfigC "legalhold_status" tid @@ -79,6 +100,8 @@ getFeatureConfig FeatureSingletonAppLockConfig tid = runMaybeT $ do WithStatusNoLock <$> mStatus <*> (AppLockConfig <$> mEnforce <*> mTimeout) + -- FUTUREWORK: the above line is duplicated in + -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! <*> Just FeatureTTLUnlimited where select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) @@ -94,6 +117,8 @@ getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid = runMaybeT $ do WithStatusNoLock <$> mEnabled <*> fmap SelfDeletingMessagesConfig mTimeout + -- FUTUREWORK: the above line is duplicated in + -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! <*> Just FeatureTTLUnlimited where select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe Int32) @@ -105,7 +130,12 @@ getFeatureConfig FeatureSingletonConferenceCallingConfig tid = do retry x1 q <&> \case Nothing -> Nothing Just (Nothing, _) -> Nothing - Just (Just status, mTtl) -> Just . forgetLock . setStatus status . setWsTTL (fromMaybe FeatureTTLUnlimited mTtl) $ defFeatureStatus + Just (Just status, mTtl) -> + Just + . forgetLock + . setStatus status + . setWsTTL (fromMaybe FeatureTTLUnlimited mTtl) + $ defFeatureStatus where select :: PrepQuery R (Identity TeamId) (Maybe FeatureStatus, Maybe FeatureTTL) select = @@ -121,7 +151,9 @@ getFeatureConfig FeatureSingletonMLSConfig tid = do Just (status, defaultProtocol, protocolToggleUsers, allowedCipherSuites, defaultCipherSuite, supportedProtocols) -> WithStatusNoLock <$> status - <*> ( MLSConfig + <*> ( -- FUTUREWORK: this block is duplicated in + -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! + MLSConfig <$> maybe (Just []) (Just . C.fromSet) protocolToggleUsers <*> defaultProtocol <*> maybe (Just []) (Just . C.fromSet) allowedCipherSuites @@ -143,7 +175,10 @@ getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = do Just $ WithStatusNoLock fs - (MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl) + ( -- FUTUREWORK: this block is duplicated in + -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! + MlsE2EIdConfig (toGracePeriodOrDefault mGracePeriod) mUrl + ) FeatureTTLUnlimited where toGracePeriodOrDefault :: Maybe Int32 -> NominalDiffTime @@ -162,6 +197,8 @@ getFeatureConfig FeatureSingletonMlsMigration tid = do Just $ WithStatusNoLock fs + -- FUTUREWORK: the following expression is duplicated in + -- "Galley.Cassandra.GetAllTeamFeatureConfigs"; make sure the two don't diverge! MlsMigrationConfig { startTime = startTime, finaliseRegardlessAfter = finaliseRegardlessAfter diff --git a/services/galley/src/Galley/Effects.hs b/services/galley/src/Galley/Effects.hs index fbca2a7e3a3..7305b4e4c08 100644 --- a/services/galley/src/Galley/Effects.hs +++ b/services/galley/src/Galley/Effects.hs @@ -92,11 +92,14 @@ import Galley.Effects.TeamStore import Galley.Effects.WaiRoutes import Galley.Env import Galley.Options +import Galley.Types.Teams (FeatureLegalHold) +import Imports import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog import Wire.API.Error +import Wire.API.Team.Feature (AllFeatureConfigs) import Wire.GundeckAPIAccess import Wire.NotificationSubsystem import Wire.Rpc @@ -122,11 +125,11 @@ type GalleyEffects1 = SubConversationStore, Random, CustomBackendStore, + TeamFeatureStore, LegalHoldStore, MemberStore, SearchVisibilityStore, ServiceStore, - TeamFeatureStore, TeamNotificationStore, TeamStore, TeamMemberStore InternalPaging, @@ -136,6 +139,8 @@ type GalleyEffects1 = ListItems LegacyPaging ConvId, ListItems LegacyPaging TeamId, ListItems InternalPaging TeamId, + Input AllFeatureConfigs, + Input (Maybe [TeamId], FeatureLegalHold), Input (Local ()), Input Opts, WaiRoutes, diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index 13a43eea34b..5011d72a3ce 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -17,15 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Galley.Effects.TeamFeatureStore - ( TeamFeatureStore (..), - getFeatureConfig, - getFeatureConfigMulti, - setFeatureConfig, - getFeatureLockStatus, - setFeatureLockStatus, - ) -where +module Galley.Effects.TeamFeatureStore where import Data.Id import Imports @@ -55,5 +47,8 @@ data TeamFeatureStore m a where TeamId -> LockStatus -> TeamFeatureStore m () + GetAllFeatureConfigs :: + TeamId -> + TeamFeatureStore m AllFeatureConfigs makeSem ''TeamFeatureStore diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 62475a4684c..fbf625a5138 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1169,7 +1169,6 @@ testJoinCodeConv = do testGetCodeRejectedIfGuestLinksDisabled :: TestM () testGetCodeRejectedIfGuestLinksDisabled = do - galley <- viewGalley (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 Right accessRoles <- liftIO $ genAccessRolesV2 [TeamMemberAccessRole, GuestAccessRole] [] let createConvWithGuestLink = do @@ -1179,7 +1178,7 @@ testGetCodeRejectedIfGuestLinksDisabled = do convId <- createConvWithGuestLink let checkGetCode expectedStatus = getConvCode owner convId !!! const expectedStatus === statusCode let setStatus tfStatus = - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode checkGetCode 200 @@ -1190,13 +1189,12 @@ testGetCodeRejectedIfGuestLinksDisabled = do testPostCodeRejectedIfGuestLinksDisabled :: TestM () testPostCodeRejectedIfGuestLinksDisabled = do - galley <- viewGalley (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 Right noGuestsAccess <- liftIO $ genAccessRolesV2 [NonTeamMemberAccessRole] [GuestAccessRole] convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just noGuestsAccess) Nothing let checkPostCode expectedStatus = postConvCode owner convId !!! statusCode === const expectedStatus let setStatus tfStatus = - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode checkPostCode 201 @@ -1209,7 +1207,6 @@ testPostCodeRejectedIfGuestLinksDisabled = do -- Check if guests cannot join anymore if guest invite feature was disabled on team level testJoinTeamConvGuestLinksDisabled :: TestM () testJoinTeamConvGuestLinksDisabled = do - galley <- viewGalley let convName = "testConversation" (owner, teamId, [alice]) <- Util.createBindingTeamWithNMembers 1 eve <- ephemeralUser @@ -1219,7 +1216,7 @@ testJoinTeamConvGuestLinksDisabled = do cCode <- (.code) . decodeConvCodeEvent <$> postConvCode owner convId let checkFeatureStatus fstatus = - Util.getTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId !!! do + Util.getTeamFeature @Public.GuestLinksConfig owner teamId !!! do const 200 === statusCode const (Right (Public.withStatus fstatus Public.LockStatusUnlocked Public.GuestLinksConfig Public.FeatureTTLUnlimited)) === responseJsonEither @@ -1235,7 +1232,7 @@ testJoinTeamConvGuestLinksDisabled = do -- disabled guest links feature let disabled = Public.WithStatusNoLock Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId disabled !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId disabled !!! do const 200 === statusCode -- guest can't join if guest link feature is disabled @@ -1254,7 +1251,7 @@ testJoinTeamConvGuestLinksDisabled = do -- after re-enabling, the old link is still valid let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId enabled !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId enabled !!! do const 200 === statusCode getJoinCodeConv eve' (conversationKey cCode) (conversationCode cCode) !!! do const (Right (ConversationCoverView convId (Just convName) False)) === responseJsonEither @@ -1268,7 +1265,6 @@ testJoinTeamConvGuestLinksDisabled = do testJoinNonTeamConvGuestLinksDisabled :: TestM () testJoinNonTeamConvGuestLinksDisabled = do - galley <- viewGalley let convName = "testConversation" (owner, teamId, []) <- Util.createBindingTeamWithNMembers 0 userNotInTeam <- randomUser @@ -1283,7 +1279,7 @@ testJoinNonTeamConvGuestLinksDisabled = do -- for non-team conversations it still works if status is disabled for the team but not server wide let tfStatus = Public.WithStatusNoLock Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley owner teamId tfStatus !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId tfStatus !!! do const 200 === statusCode getJoinCodeConv userNotInTeam (conversationKey cCode) (conversationCode cCode) !!! do @@ -1522,7 +1518,7 @@ getGuestLinksStatusFromForeignTeamConv = do localDomain <- viewFederationDomain galley <- viewGalley let setTeamStatus u tid tfStatus = - TeamFeatures.putTeamFeatureFlagWithGalley @Public.GuestLinksConfig galley u tid (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig u tid (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode let checkGuestLinksStatus u c s = getGuestLinkStatus galley u c !!! do diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index a213949cb27..dc5fffe2731 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -427,8 +427,7 @@ testEnableTeamSearchVisibilityPerTeam = do (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: String -> Public.FeatureStatus -> TestM () check msg enabledness = do - g <- viewGalley - status :: Public.WithStatusNoLock Public.SearchVisibilityAvailableConfig <- responseJsonUnsafe <$> (Util.getTeamSearchVisibilityAvailableInternal g tid (Util.getTeamFeatureInternal @Public.SearchVisibilityAvailableConfig tid UserId -> TeamMember newTeamMember' perms uid = Member.mkTeamMember uid perms Nothing LH.defUserLegalHoldStatus -- NOTE: all client functions calling @{/i,}/teams/*/features/*@ can be replaced by --- hypothetical functions 'getTeamFeatureFlag', 'getTeamFeatureFlagInternal', --- 'putTeamFeatureFlagInternal'. Since these functions all work in slightly different monads +-- hypothetical functions 'getTeamFeature', 'getTeamFeatureInternal', +-- 'putTeamFeatureInternal'. Since these functions all work in slightly different monads -- and with different kinds of internal checks, it's quite tedious to do so. getSSOEnabledInternal :: HasCallStack => TeamId -> TestM ResponseLBS -getSSOEnabledInternal = Util.getTeamFeatureFlagInternal @Public.SSOConfig +getSSOEnabledInternal = Util.getTeamFeatureInternal @Public.SSOConfig putSSOEnabledInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () putSSOEnabledInternal tid statusValue = - void $ Util.putTeamFeatureFlagInternal @Public.SSOConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SSOConfig Public.FeatureTTLUnlimited) + void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SSOConfig Public.FeatureTTLUnlimited) getSearchVisibility :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> MonadHttp m => m ResponseLBS getSearchVisibility g uid tid = do diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index a3f07368c5a..4e0ccdb3cca 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -50,8 +50,8 @@ import Test.Hspec (expectationFailure) import Test.QuickCheck (Gen, generate, suchThat) import Test.Tasty import Test.Tasty.Cannon qualified as WS -import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) -import TestHelpers (eventually, test) +import Test.Tasty.HUnit (assertFailure, (@?=)) +import TestHelpers (test) import TestSetup import Wire.API.Conversation.Protocol import Wire.API.Event.FeatureConfig qualified as FeatureConfig @@ -267,10 +267,10 @@ testPatch' :: cfg -> TestM () testPatch' testLockStatusChange rndFeatureConfig defStatus defConfig = do - (_, tid) <- createBindingTeam - Just original <- responseJsonMaybe <$> getFeatureStatusInternal @cfg tid - patchFeatureStatusInternal tid rndFeatureConfig !!! statusCode === const 200 - Just actual <- responseJsonMaybe <$> getFeatureStatusInternal @cfg tid + (uid, tid) <- createBindingTeam + Just original <- responseJsonMaybe <$> getTeamFeatureInternal @cfg tid + patchTeamFeatureInternal tid rndFeatureConfig !!! statusCode === const 200 + Just actual <- responseJsonMaybe <$> getTeamFeatureInternal @cfg tid liftIO $ if wsLockStatus actual == LockStatusLocked then do @@ -281,83 +281,55 @@ testPatch' testLockStatusChange rndFeatureConfig defStatus defConfig = do when (testLockStatusChange == AssertLockStatusChange) $ wsLockStatus actual @?= fromMaybe (wsLockStatus original) (wspLockStatus rndFeatureConfig) wsConfig actual @?= fromMaybe (wsConfig original) (wspConfig rndFeatureConfig) + checkTeamFeatureAllEndpoints uid tid actual testSSO :: (TeamId -> FeatureStatus -> TestM ()) -> TestM () testSSO setSSOFeature = do (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 nonMember <- randomUser - let getSSO :: HasCallStack => FeatureStatus -> TestM () - getSSO = assertFlagNoConfig @SSOConfig $ getTeamFeatureFlag @SSOConfig member tid - getSSOFeatureConfig :: HasCallStack => FeatureStatus -> TestM () - getSSOFeatureConfig expectedStatus = do - actual <- Util.getFeatureConfig @SSOConfig member - liftIO $ wsStatus actual @?= expectedStatus - getSSOInternal :: HasCallStack => FeatureStatus -> TestM () - getSSOInternal = assertFlagNoConfig @SSOConfig $ getTeamFeatureFlagInternal @SSOConfig tid - - assertFlagForbidden $ getTeamFeatureFlag @SSOConfig nonMember tid + assertFlagForbidden $ getTeamFeature @SSOConfig nonMember tid featureSSO <- view (tsGConf . settings . featureFlags . flagSSO) case featureSSO of FeatureSSODisabledByDefault -> do -- Test default - getSSO FeatureStatusDisabled - getSSOInternal FeatureStatusDisabled - getSSOFeatureConfig FeatureStatusDisabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) -- Test override setSSOFeature tid FeatureStatusEnabled - getSSO FeatureStatusEnabled - getSSOInternal FeatureStatusEnabled - getSSOFeatureConfig FeatureStatusEnabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) FeatureSSOEnabledByDefault -> do -- since we don't allow to disable (see 'disableSsoNotImplemented'), we can't test -- much here. (disable failure is covered in "enable/disable SSO" above.) - getSSO FeatureStatusEnabled - getSSOInternal FeatureStatusEnabled - getSSOFeatureConfig FeatureStatusEnabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited) putSSOInternal :: HasCallStack => TeamId -> FeatureStatus -> TestM () putSSOInternal tid = void - . putTeamFeatureFlagInternal @SSOConfig expect2xx tid + . putTeamFeatureInternal @SSOConfig expect2xx tid . (\st -> WithStatusNoLock st SSOConfig FeatureTTLUnlimited) patchSSOInternal :: HasCallStack => TeamId -> FeatureStatus -> TestM () -patchSSOInternal tid status = void $ patchFeatureStatusInternalWithMod @SSOConfig expect2xx tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) +patchSSOInternal tid status = void $ patchTeamFeatureInternalWithMod @SSOConfig expect2xx tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) testLegalHold :: ((Request -> Request) -> TeamId -> FeatureStatus -> TestM ()) -> TestM () testLegalHold setLegalHoldInternal = do (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 nonMember <- randomUser - let getLegalHold :: HasCallStack => FeatureStatus -> TestM () - getLegalHold = assertFlagNoConfig @LegalholdConfig $ getTeamFeatureFlag @LegalholdConfig member tid - getLegalHoldInternal :: HasCallStack => FeatureStatus -> TestM () - getLegalHoldInternal = assertFlagNoConfig @LegalholdConfig $ getTeamFeatureFlagInternal @LegalholdConfig tid - getLegalHoldFeatureConfig expectedStatus = do - actual <- Util.getFeatureConfig @LegalholdConfig member - liftIO $ wsStatus actual @?= expectedStatus - - getLegalHold FeatureStatusDisabled - getLegalHoldInternal FeatureStatusDisabled - - assertFlagForbidden $ getTeamFeatureFlag @LegalholdConfig nonMember tid + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) + assertFlagForbidden $ getTeamFeature @LegalholdConfig nonMember tid -- FUTUREWORK: run two galleys, like below for custom search visibility. featureLegalHold <- view (tsGConf . settings . featureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do -- Test default - getLegalHold FeatureStatusDisabled - getLegalHoldInternal FeatureStatusDisabled - getLegalHoldFeatureConfig FeatureStatusDisabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) -- Test override setLegalHoldInternal expect2xx tid FeatureStatusEnabled - getLegalHold FeatureStatusEnabled - getLegalHoldInternal FeatureStatusEnabled - getLegalHoldFeatureConfig FeatureStatusEnabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited) -- turned off for instance FeatureLegalHoldDisabledPermanently -> do @@ -370,139 +342,65 @@ testLegalHold setLegalHoldInternal = do putLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> FeatureStatus -> TestM () putLegalHoldInternal expectation tid = void - . putTeamFeatureFlagInternal @LegalholdConfig expectation tid + . putTeamFeatureInternal @LegalholdConfig expectation tid . (\st -> WithStatusNoLock st LegalholdConfig FeatureTTLUnlimited) patchLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> FeatureStatus -> TestM () -patchLegalHoldInternal expectation tid status = void $ patchFeatureStatusInternalWithMod @LegalholdConfig expectation tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) +patchLegalHoldInternal expectation tid status = void $ patchTeamFeatureInternalWithMod @LegalholdConfig expectation tid (withStatus' (Just status) Nothing Nothing (Just FeatureTTLUnlimited)) testSearchVisibility :: TestM () testSearchVisibility = do - let getTeamSearchVisibility :: TeamId -> UserId -> FeatureStatus -> TestM () - getTeamSearchVisibility teamid uid expected = do - g <- viewGalley - getTeamSearchVisibilityAvailable g uid teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right (WithStatusNoLock expected SearchVisibilityAvailableConfig FeatureTTLUnlimited)) - - let getTeamSearchVisibilityInternal :: TeamId -> FeatureStatus -> TestM () - getTeamSearchVisibilityInternal teamid expected = do - g <- viewGalley - getTeamSearchVisibilityAvailableInternal g teamid !!! do - statusCode === const 200 - responseJsonEither === const (Right (WithStatusNoLock expected SearchVisibilityAvailableConfig FeatureTTLUnlimited)) - - let getTeamSearchVisibilityFeatureConfig :: UserId -> FeatureStatus -> TestM () - getTeamSearchVisibilityFeatureConfig uid expected = do - actual <- Util.getFeatureConfig @SearchVisibilityAvailableConfig uid - liftIO $ wsStatus actual @?= expected - let setTeamSearchVisibilityInternal :: TeamId -> FeatureStatus -> TestM () setTeamSearchVisibilityInternal teamid val = do - g <- viewGalley - putTeamSearchVisibilityAvailableInternal g teamid val + putTeamSearchVisibilityAvailableInternal teamid val - (owner, tid, [member]) <- createBindingTeamWithNMembers 1 + (_, tid, [member]) <- createBindingTeamWithNMembers 1 nonMember <- randomUser - assertFlagForbidden $ getTeamFeatureFlag @SearchVisibilityAvailableConfig nonMember tid + assertFlagForbidden $ getTeamFeature @SearchVisibilityAvailableConfig nonMember tid withCustomSearchFeature FeatureTeamSearchVisibilityUnavailableByDefault $ do - getTeamSearchVisibility tid owner FeatureStatusDisabled - getTeamSearchVisibilityInternal tid FeatureStatusDisabled - getTeamSearchVisibilityFeatureConfig member FeatureStatusDisabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) setTeamSearchVisibilityInternal tid FeatureStatusEnabled - getTeamSearchVisibility tid owner FeatureStatusEnabled - getTeamSearchVisibilityInternal tid FeatureStatusEnabled - getTeamSearchVisibilityFeatureConfig member FeatureStatusEnabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) setTeamSearchVisibilityInternal tid FeatureStatusDisabled - getTeamSearchVisibility tid owner FeatureStatusDisabled - getTeamSearchVisibilityInternal tid FeatureStatusDisabled - getTeamSearchVisibilityFeatureConfig member FeatureStatusDisabled + checkTeamFeatureAllEndpoints member tid (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) - (owner2, tid2, team2member : _) <- createBindingTeamWithNMembers 1 + (_, tid2, team2member : _) <- createBindingTeamWithNMembers 1 withCustomSearchFeature FeatureTeamSearchVisibilityAvailableByDefault $ do - getTeamSearchVisibility tid2 owner2 FeatureStatusEnabled - getTeamSearchVisibilityInternal tid2 FeatureStatusEnabled - getTeamSearchVisibilityFeatureConfig team2member FeatureStatusEnabled + checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) setTeamSearchVisibilityInternal tid2 FeatureStatusDisabled - getTeamSearchVisibility tid2 owner2 FeatureStatusDisabled - getTeamSearchVisibilityInternal tid2 FeatureStatusDisabled - getTeamSearchVisibilityFeatureConfig team2member FeatureStatusDisabled + checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) setTeamSearchVisibilityInternal tid2 FeatureStatusEnabled - getTeamSearchVisibility tid2 owner2 FeatureStatusEnabled - getTeamSearchVisibilityInternal tid2 FeatureStatusEnabled - getTeamSearchVisibilityFeatureConfig team2member FeatureStatusEnabled - -getClassifiedDomains :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => - UserId -> - TeamId -> - WithStatusNoLock ClassifiedDomainsConfig -> - m () -getClassifiedDomains member tid = - assertFlagWithConfig @ClassifiedDomainsConfig $ - getTeamFeatureFlag @ClassifiedDomainsConfig member tid - -getClassifiedDomainsInternal :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => - TeamId -> - WithStatusNoLock ClassifiedDomainsConfig -> - m () -getClassifiedDomainsInternal tid = - assertFlagWithConfig @ClassifiedDomainsConfig $ - getTeamFeatureFlagInternal @ClassifiedDomainsConfig tid + checkTeamFeatureAllEndpoints team2member tid2 (withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited) testClassifiedDomainsEnabled :: TestM () testClassifiedDomainsEnabled = do - (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 + (_, tid, member : _) <- createBindingTeamWithNMembers 1 let expected = - WithStatusNoLock FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "example.com"]) FeatureTTLUnlimited - - let getClassifiedDomainsFeatureConfig :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => - UserId -> - WithStatusNoLock ClassifiedDomainsConfig -> - m () - getClassifiedDomainsFeatureConfig uid expected' = do - result <- Util.getFeatureConfig @ClassifiedDomainsConfig uid - liftIO $ wsStatus result @?= wssStatus expected' - liftIO $ wsConfig result @?= wssConfig expected' - - getClassifiedDomains member tid expected - getClassifiedDomainsInternal tid expected - getClassifiedDomainsFeatureConfig member expected + withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "example.com"]) FeatureTTLUnlimited + + checkTeamFeatureAllEndpoints member tid expected testClassifiedDomainsDisabled :: TestM () testClassifiedDomainsDisabled = do (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 let expected = - WithStatusNoLock FeatureStatusDisabled (ClassifiedDomainsConfig []) FeatureTTLUnlimited - - let getClassifiedDomainsFeatureConfig :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m, MonadCatch m) => - UserId -> - WithStatusNoLock ClassifiedDomainsConfig -> - m () - getClassifiedDomainsFeatureConfig uid expected' = do - result <- Util.getFeatureConfig @ClassifiedDomainsConfig uid - liftIO $ wsStatus result @?= wssStatus expected' - liftIO $ wsConfig result @?= wssConfig expected' + withStatus FeatureStatusDisabled LockStatusUnlocked (ClassifiedDomainsConfig []) FeatureTTLUnlimited let classifiedDomainsDisabled opts = opts & over (settings . featureFlags . flagClassifiedDomains) (\(ImplicitLockStatus s) -> ImplicitLockStatus (s & setStatus FeatureStatusDisabled & setConfig (ClassifiedDomainsConfig []))) - withSettingsOverrides classifiedDomainsDisabled $ do - getClassifiedDomains member tid expected - getClassifiedDomainsInternal tid expected - getClassifiedDomainsFeatureConfig member expected + + withSettingsOverrides classifiedDomainsDisabled $ + checkTeamFeatureAllEndpoints member tid expected testSimpleFlag :: forall cfg. @@ -526,7 +424,8 @@ testSimpleFlagTTLOverride :: KnownSymbol (FeatureSymbol cfg), FeatureTrivialConfig cfg, ToSchema cfg, - FromJSON (WithStatusNoLock cfg) + Eq cfg, + Show cfg ) => FeatureStatus -> FeatureTTL -> @@ -536,23 +435,9 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do (_owner, tid, member : _) <- createBindingTeamWithNMembers 1 nonMember <- randomUser - let getFlag :: HasCallStack => FeatureStatus -> TestM () - getFlag expected = eventually $ do - flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlag @cfg member tid - - getFeatureConfig :: HasCallStack => FeatureStatus -> FeatureTTL -> TestM () - getFeatureConfig expectedStatus expectedTtl = eventually $ do - actual <- Util.getFeatureConfig @cfg member - liftIO $ wsStatus actual @?= expectedStatus - liftIO $ checkTtl (wsTTL actual) expectedTtl - - getFlagInternal :: HasCallStack => FeatureStatus -> TestM () - getFlagInternal expected = eventually $ do - flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlagInternal @cfg tid - - setFlagInternal :: FeatureStatus -> FeatureTTL -> TestM () + let setFlagInternal :: FeatureStatus -> FeatureTTL -> TestM () setFlagInternal statusValue ttl' = - void $ putTeamFeatureFlagInternalTTL @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') + void $ putTeamFeatureInternal @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) select = fromString "select ttl(conference_calling) from team_features where team_id = ?" @@ -577,37 +462,21 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do Just (FeatureTTLSeconds i) -> i <= upper unless check $ error ("expected ttl <= " <> show upper <> ", got " <> show storedTTL) - checkTtl :: FeatureTTL -> FeatureTTL -> IO () - checkTtl (FeatureTTLSeconds actualTtl) (FeatureTTLSeconds expectedTtl) = - assertBool - ("expected the actual TTL to be greater than 0 and equal to or no more than 2 seconds less than " <> show expectedTtl <> ", but it was " <> show actualTtl) - ( actualTtl > 0 - && actualTtl <= expectedTtl - && abs (fromIntegral @Word @Int actualTtl - fromIntegral @Word @Int expectedTtl) <= 2 - ) - checkTtl FeatureTTLUnlimited FeatureTTLUnlimited = pure () - checkTtl FeatureTTLUnlimited _ = assertFailure "expected the actual TTL to be unlimited, but it was limited" - checkTtl _ FeatureTTLUnlimited = assertFailure "expected the actual TTL to be limited, but it was unlimited" - toMicros :: Word -> Int toMicros secs = fromIntegral secs * 1000000 - assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeature @cfg nonMember tid let otherValue = case defaultValue of FeatureStatusDisabled -> FeatureStatusEnabled FeatureStatusEnabled -> FeatureStatusDisabled -- Initial value should be the default value - getFlag defaultValue - getFlagInternal defaultValue - getFeatureConfig defaultValue FeatureTTLUnlimited + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue) -- Setting should work setFlagInternal otherValue ttl - getFlag otherValue - getFeatureConfig otherValue ttl - getFlagInternal otherValue + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttl) case (ttl, ttlAfter) of (FeatureTTLSeconds d, FeatureTTLSeconds d') -> do @@ -616,47 +485,32 @@ testSimpleFlagTTLOverride defaultValue ttl ttlAfter = do liftIO $ threadDelay (toMicros d `div` 2) -- waiting half of TTL setFlagInternal otherValue ttlAfter -- value is still correct - getFlag otherValue + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) liftIO $ threadDelay (toMicros d') -- waiting for new TTL - getFlag defaultValue - assertUnlimited -- TTL should be NULL after expiration. + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue) (FeatureTTLSeconds d, FeatureTTLUnlimited) -> do assertLimited d -- TTL should be NULL after expiration. -- wait less than expiration, override and recheck. liftIO $ threadDelay (fromIntegral d `div` 2) -- waiting half of TTL setFlagInternal otherValue ttlAfter -- value is still correct - getFlag otherValue - assertUnlimited + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) (FeatureTTLUnlimited, FeatureTTLUnlimited) -> do assertUnlimited -- overriding in this case should have no effect. setFlagInternal otherValue ttl - getFlag otherValue - getFeatureConfig otherValue ttl - getFlagInternal otherValue - - assertUnlimited + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttl) (FeatureTTLUnlimited, FeatureTTLSeconds d) -> do assertUnlimited setFlagInternal otherValue ttlAfter - getFlag otherValue - getFeatureConfig otherValue ttlAfter - getFlagInternal otherValue + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus otherValue & setTTL ttlAfter) liftIO $ threadDelay (toMicros d) -- waiting it out -- value reverts back - getFlag defaultValue - -- TTL should be NULL inside cassandra - assertUnlimited - - -- Clean up - setFlagInternal defaultValue FeatureTTLUnlimited - assertUnlimited - getFlag defaultValue + checkTeamFeatureAllEndpoints member tid (defFeatureStatus @cfg & setStatus defaultValue & setTTL ttl) testSimpleFlagTTL :: forall cfg. @@ -677,7 +531,7 @@ testSimpleFlagTTL defaultValue ttl = do let getFlag :: HasCallStack => FeatureStatus -> TestM () getFlag expected = - flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlag @cfg member tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeature @cfg member tid getFeatureConfig :: HasCallStack => FeatureStatus -> TestM () getFeatureConfig expected = do @@ -686,11 +540,11 @@ testSimpleFlagTTL defaultValue ttl = do getFlagInternal :: HasCallStack => FeatureStatus -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureFlagInternal @cfg tid + flip (assertFlagNoConfig @cfg) expected $ getTeamFeatureInternal @cfg tid setFlagInternal :: FeatureStatus -> FeatureTTL -> TestM () setFlagInternal statusValue ttl' = - void $ putTeamFeatureFlagInternalTTL @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') + void $ putTeamFeatureInternal @cfg expect2xx tid (WithStatusNoLock statusValue (trivialConfig @cfg) ttl') select :: PrepQuery R (Identity TeamId) (Identity (Maybe FeatureTTL)) select = fromString "select ttl(conference_calling) from team_features where team_id = ?" @@ -715,7 +569,7 @@ testSimpleFlagTTL defaultValue ttl = do Just (FeatureTTLSeconds i) -> i <= upper unless check $ error ("expected ttl <= " <> show upper <> ", got " <> show storedTTL) - assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeature @cfg nonMember tid let otherValue = case defaultValue of FeatureStatusDisabled -> FeatureStatusEnabled @@ -775,7 +629,7 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do let getFlag :: HasCallStack => FeatureStatus -> LockStatus -> TestM () getFlag expectedStatus expectedLockStatus = do - let flag = getTeamFeatureFlag @cfg member tid + let flag = getTeamFeature @cfg member tid assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus getFeatureConfig :: HasCallStack => FeatureStatus -> LockStatus -> TestM () @@ -786,7 +640,7 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do getFlagInternal :: HasCallStack => FeatureStatus -> LockStatus -> TestM () getFlagInternal expectedStatus expectedLockStatus = do - let flag = getTeamFeatureFlagInternal @cfg tid + let flag = getTeamFeatureInternal @cfg tid assertFlagNoConfigWithLockStatus @cfg flag expectedStatus expectedLockStatus getFlags expectedStatus expectedLockStatus = do @@ -796,13 +650,13 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do setFlagWithGalley :: FeatureStatus -> TestM () setFlagWithGalley statusValue = - putTeamFeatureFlagWithGalley @cfg galley owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) + putTeamFeature @cfg owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) !!! statusCode === const 200 assertSetStatusForbidden :: FeatureStatus -> TestM () assertSetStatusForbidden statusValue = - putTeamFeatureFlagWithGalley @cfg galley owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) + putTeamFeature @cfg owner tid (WithStatusNoLock statusValue (trivialConfig @cfg) FeatureTTLUnlimited) !!! statusCode === const 409 @@ -812,7 +666,7 @@ testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do !!! statusCode === const 200 - assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeature @cfg nonMember tid let otherStatus = case defaultStatus of FeatureStatusDisabled -> FeatureStatusEnabled @@ -889,7 +743,7 @@ testSelfDeletingMessages = do let checkSet :: FeatureStatus -> Int32 -> Int -> TestM () checkSet stat tout expectedStatusCode = do - putTeamFeatureFlagInternal @SelfDeletingMessagesConfig + putTeamFeatureInternal @SelfDeletingMessagesConfig galley tid (settingWithoutLockStatus stat tout) @@ -901,8 +755,8 @@ testSelfDeletingMessages = do checkGet stat tout lockStatus = do let expected = settingWithLockStatus stat tout lockStatus forM_ - [ getTeamFeatureFlagInternal @SelfDeletingMessagesConfig tid, - getTeamFeatureFlagWithGalley @SelfDeletingMessagesConfig galley owner tid + [ getTeamFeatureInternal @SelfDeletingMessagesConfig tid, + getTeamFeature @SelfDeletingMessagesConfig owner tid ] (!!! responseJsonEither === const (Right expected)) result <- Util.getFeatureConfig @SelfDeletingMessagesConfig owner @@ -954,16 +808,16 @@ testGuestLinksInternal :: TestM () testGuestLinksInternal = do galley <- viewGalley testGuestLinks - (const $ getTeamFeatureFlagInternal @GuestLinksConfig) - (const $ putTeamFeatureFlagInternal @GuestLinksConfig galley) + (const $ getTeamFeatureInternal @GuestLinksConfig) + (const $ putTeamFeatureInternal @GuestLinksConfig galley) (Util.setLockStatusInternal @GuestLinksConfig galley) testGuestLinksPublic :: TestM () testGuestLinksPublic = do galley <- viewGalley testGuestLinks - (getTeamFeatureFlagWithGalley @GuestLinksConfig galley) - (putTeamFeatureFlagWithGalley @GuestLinksConfig galley) + (getTeamFeature @GuestLinksConfig) + (putTeamFeature @GuestLinksConfig) (Util.setLockStatusInternal @GuestLinksConfig galley) testGuestLinks :: @@ -1027,19 +881,19 @@ testAllFeatures = do -- 2. there is a row for team_id in galley.team_features but the feature has a no entry (null value) galley <- viewGalley -- this sets the guest links config to its default value thereby creating a row for the team in galley.team_features - putTeamFeatureFlagInternal @GuestLinksConfig galley tid (WithStatusNoLock FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited) + putTeamFeatureInternal @GuestLinksConfig galley tid (WithStatusNoLock FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited) !!! statusCode === const 200 getAllTeamFeatures member tid !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) - getAllTeamFeaturesPersonal member !!! do + getAllFeatureConfigs member !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by default in galley -})) randomPersonalUser <- randomUser - getAllTeamFeaturesPersonal randomPersonalUser !!! do + getAllFeatureConfigs randomPersonalUser !!! do statusCode === const 200 responseJsonMaybe === const (Just (expected FeatureStatusEnabled defLockStatus {- determined by 'getAfcConferenceCallingDefNew' in brig -})) where @@ -1096,11 +950,11 @@ testSearchVisibilityInbound = do let getFlagInternal :: HasCallStack => FeatureStatus -> TestM () getFlagInternal expected = - flip (assertFlagNoConfig @SearchVisibilityInboundConfig) expected $ getTeamFeatureFlagInternal @SearchVisibilityInboundConfig tid + flip (assertFlagNoConfig @SearchVisibilityInboundConfig) expected $ getTeamFeatureInternal @SearchVisibilityInboundConfig tid setFlagInternal :: FeatureStatus -> TestM () setFlagInternal statusValue = - void $ putTeamFeatureFlagInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) + void $ putTeamFeatureInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) let otherValue = case defaultValue of FeatureStatusDisabled -> FeatureStatusEnabled @@ -1118,7 +972,7 @@ testFeatureNoConfigMultiSearchVisibilityInbound = do let setFlagInternal :: TeamId -> FeatureStatus -> TestM () setFlagInternal tid statusValue = - void $ putTeamFeatureFlagInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) + void $ putTeamFeatureInternal @SearchVisibilityInboundConfig expect2xx tid (WithStatusNoLock statusValue SearchVisibilityInboundConfig FeatureTTLUnlimited) setFlagInternal team2 FeatureStatusEnabled @@ -1159,11 +1013,11 @@ testNonTrivialConfigNoTTL defaultCfg = do let getForTeam :: HasCallStack => WithStatusNoLock cfg -> TestM () getForTeam expected = - flip assertFlagWithConfig expected $ getTeamFeatureFlag @cfg member tid + flip assertFlagWithConfig expected $ getTeamFeature @cfg member tid getForTeamInternal :: HasCallStack => WithStatusNoLock cfg -> TestM () getForTeamInternal expected = - flip assertFlagWithConfig expected $ getTeamFeatureFlagInternal @cfg tid + flip assertFlagWithConfig expected $ getTeamFeatureInternal @cfg tid getForUser :: HasCallStack => WithStatusNoLock cfg -> TestM () getForUser expected = do @@ -1179,20 +1033,20 @@ testNonTrivialConfigNoTTL defaultCfg = do setForTeam :: HasCallStack => WithStatusNoLock cfg -> TestM () setForTeam wsnl = - putTeamFeatureFlagWithGalley @cfg galley owner tid wsnl + putTeamFeature @cfg owner tid wsnl !!! statusCode === const 200 setForTeamInternal :: HasCallStack => WithStatusNoLock cfg -> TestM () setForTeamInternal wsnl = - void $ putTeamFeatureFlagInternal @cfg expect2xx tid wsnl + void $ putTeamFeatureInternal @cfg expect2xx tid wsnl setLockStatus :: LockStatus -> TestM () setLockStatus lockStatus = Util.setLockStatusInternal @cfg galley tid lockStatus !!! statusCode === const 200 - assertFlagForbidden $ getTeamFeatureFlag @cfg nonMember tid + assertFlagForbidden $ getTeamFeature @cfg nonMember tid getViaEndpoints (forgetLock defaultCfg) @@ -1216,7 +1070,7 @@ testNonTrivialConfigNoTTL defaultCfg = do config2 <- liftIO $ generate arbitrary <&> (forgetLock . setTTL FeatureTTLUnlimited) config3 <- liftIO $ generate arbitrary <&> (forgetLock . setTTL FeatureTTLUnlimited) - putTeamFeatureFlagWithGalley @MLSConfig galley owner tid defaultMLSConfig + putTeamFeature @MLSConfig owner tid defaultMLSConfig !!! statusCode === const 200 @@ -1252,11 +1106,11 @@ testMLS = do let getForTeam :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () getForTeam expected = - flip assertFlagWithConfig expected $ getTeamFeatureFlag @MLSConfig member tid + flip assertFlagWithConfig expected $ getTeamFeature @MLSConfig member tid getForTeamInternal :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () getForTeamInternal expected = - flip assertFlagWithConfig expected $ getTeamFeatureFlagInternal @MLSConfig tid + flip assertFlagWithConfig expected $ getTeamFeatureInternal @MLSConfig tid getForUser :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () getForUser expected = do @@ -1272,7 +1126,7 @@ testMLS = do setForTeamWithStatusCode :: HasCallStack => Int -> WithStatusNoLock MLSConfig -> TestM () setForTeamWithStatusCode resStatusCode wsnl = - putTeamFeatureFlagWithGalley @MLSConfig galley owner tid wsnl + putTeamFeature @MLSConfig owner tid wsnl !!! statusCode === const resStatusCode @@ -1281,7 +1135,7 @@ testMLS = do setForTeamInternalWithStatusCode :: HasCallStack => (Request -> Request) -> WithStatusNoLock MLSConfig -> TestM () setForTeamInternalWithStatusCode expect wsnl = - void $ putTeamFeatureFlagInternal @MLSConfig expect tid wsnl + void $ putTeamFeatureInternal @MLSConfig expect tid wsnl setForTeamInternal :: HasCallStack => WithStatusNoLock MLSConfig -> TestM () setForTeamInternal = setForTeamInternalWithStatusCode expect2xx @@ -1357,11 +1211,10 @@ testExposeInvitationURLsToTeamAdminTeamIdInAllowList = do assertTeamActivate "create team" tid void $ withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusUnlocked let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited void $ - putTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid enabled !!! do + putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do const 200 === statusCode assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusEnabled LockStatusUnlocked @@ -1372,11 +1225,10 @@ testExposeInvitationURLsToTeamAdminEmptyAllowList = do assertTeamActivate "create team" tid void $ withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist .~ Nothing) $ do - g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited void $ - putTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid enabled !!! do + putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do const 409 === statusCode assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked @@ -1393,27 +1245,24 @@ testExposeInvitationURLsToTeamAdminServerConfigTakesPrecedence = do assertTeamActivate "create team" tid void $ withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist ?~ [tid]) $ do - g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusUnlocked let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited void $ - putTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid enabled !!! do + putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do const 200 === statusCode assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusEnabled LockStatusUnlocked void $ withSettingsOverrides (\opts -> opts & settings . exposeInvitationURLsTeamAllowlist .~ Nothing) $ do - g <- viewGalley assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked let enabled = WithStatusNoLock FeatureStatusEnabled ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited void $ - putTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid enabled !!! do + putTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid enabled !!! do const 409 === statusCode assertExposeInvitationURLsToTeamAdminConfigStatus owner tid FeatureStatusDisabled LockStatusLocked assertExposeInvitationURLsToTeamAdminConfigStatus :: UserId -> TeamId -> FeatureStatus -> LockStatus -> TestM () assertExposeInvitationURLsToTeamAdminConfigStatus owner tid fStatus lStatus = do - g <- viewGalley - Util.getTeamFeatureFlagWithGalley @ExposeInvitationURLsToTeamAdminConfig g owner tid !!! do + getTeamFeature @ExposeInvitationURLsToTeamAdminConfig owner tid !!! do const 200 === statusCode const (Right (withStatus fStatus lStatus ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited)) === responseJsonEither diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index cb98a9aa9c4..3191a4849ce 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -36,64 +36,51 @@ import GHC.TypeLits (KnownSymbol) import Galley.Options (featureFlags, settings) import Galley.Types.Teams import Imports +import Test.Tasty.HUnit (assertBool, assertFailure, (@?=)) import TestSetup +import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public withCustomSearchFeature :: FeatureTeamSearchVisibilityAvailability -> TestM () -> TestM () withCustomSearchFeature flag action = do Util.withSettingsOverrides (\opts -> opts & settings . featureFlags . flagTeamSearchVisibility .~ flag) action -getTeamSearchVisibilityAvailable :: HasCallStack => (Request -> Request) -> UserId -> TeamId -> MonadHttp m => m ResponseLBS -getTeamSearchVisibilityAvailable = getTeamFeatureFlagWithGalley @Public.SearchVisibilityAvailableConfig - -getTeamSearchVisibilityAvailableInternal :: HasCallStack => (Request -> Request) -> TeamId -> MonadHttp m => m ResponseLBS -getTeamSearchVisibilityAvailableInternal = - getTeamFeatureFlagInternalWithGalley @Public.SearchVisibilityAvailableConfig - putTeamSearchVisibilityAvailableInternal :: HasCallStack => - (Request -> Request) -> TeamId -> Public.FeatureStatus -> - (MonadIO m, MonadHttp m) => m () -putTeamSearchVisibilityAvailableInternal g tid statusValue = + (MonadIO m, MonadHttp m, HasGalley m) => m () +putTeamSearchVisibilityAvailableInternal tid statusValue = void $ - putTeamFeatureFlagInternalWithGalleyAndMod + putTeamFeatureInternal @Public.SearchVisibilityAvailableConfig - g expect2xx tid (Public.WithStatusNoLock statusValue Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) -getTeamFeatureFlagInternal :: +getTeamFeatureInternal :: forall cfg m. (HasGalley m, MonadIO m, MonadHttp m, KnownSymbol (Public.FeatureSymbol cfg)) => TeamId -> m ResponseLBS -getTeamFeatureFlagInternal tid = do +getTeamFeatureInternal tid = do g <- viewGalley - getTeamFeatureFlagInternalWithGalley @cfg g tid - -getTeamFeatureFlagInternalWithGalley :: - forall cfg m. - (MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg)) => - (Request -> Request) -> - TeamId -> - m ResponseLBS -getTeamFeatureFlagInternalWithGalley g tid = do get $ g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] -getTeamFeatureFlag :: +getTeamFeature :: forall cfg m. (HasGalley m, MonadIO m, MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg)) => UserId -> TeamId -> m ResponseLBS -getTeamFeatureFlag uid tid = do - g <- viewGalley - getTeamFeatureFlagWithGalley @cfg g uid tid +getTeamFeature uid tid = do + galley <- viewGalley + get $ + galley + . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] + . zUser uid getAllTeamFeatures :: (HasCallStack, HasGalley m, MonadIO m, MonadHttp m) => @@ -107,107 +94,92 @@ getAllTeamFeatures uid tid = do . paths ["teams", toByteString' tid, "features"] . zUser uid -getAllTeamFeaturesPersonal :: - (HasCallStack, HasGalley m, MonadIO m, MonadHttp m) => +getTeamFeatureFromAll :: + forall cfg m. + ( HasCallStack, + MonadThrow m, + HasGalley m, + MonadIO m, + MonadHttp m, + KnownSymbol (Public.FeatureSymbol cfg), + FromJSON (Public.WithStatus cfg) + ) => + UserId -> + TeamId -> + m (Public.WithStatus cfg) +getTeamFeatureFromAll uid tid = do + response :: Value <- responseJsonError =<< getAllTeamFeatures uid tid + let status = response ^? key (Key.fromText (Public.featureName @cfg)) + maybe (error "getting all features failed") pure (status >>= fromResult . fromJSON) + where + fromResult :: Result a -> Maybe a + fromResult (Success b) = Just b + fromResult _ = Nothing + +getAllFeatureConfigs :: + (HasCallStack, HasGalley m, Monad m, MonadHttp m) => UserId -> m ResponseLBS -getAllTeamFeaturesPersonal uid = do +getAllFeatureConfigs uid = do g <- viewGalley get $ g . paths ["feature-configs"] . zUser uid -getTeamFeatureFlagWithGalley :: forall cfg m. (MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg)) => (Request -> Request) -> UserId -> TeamId -> m ResponseLBS -getTeamFeatureFlagWithGalley galley uid tid = do - get $ - galley - . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] - . zUser uid - -getFeatureConfig :: forall cfg m. (HasCallStack, MonadThrow m, HasGalley m, MonadHttp m, KnownSymbol (Public.FeatureSymbol cfg), FromJSON (Public.WithStatus cfg)) => UserId -> m (Public.WithStatus cfg) +getFeatureConfig :: + forall cfg m. + ( HasCallStack, + MonadThrow m, + HasGalley m, + MonadHttp m, + KnownSymbol (Public.FeatureSymbol cfg), + FromJSON (Public.WithStatus cfg) + ) => + UserId -> + m (Public.WithStatus cfg) getFeatureConfig uid = do - galley <- viewGalley - response :: Value <- responseJsonError =<< getAllFeatureConfigsWithGalley galley uid + response :: Value <- responseJsonError =<< getAllFeatureConfigs uid let status = response ^? key (Key.fromText (Public.featureName @cfg)) - maybe (error "getting all features failed") pure (status >>= fromResult . fromJSON) + maybe (error "getting all feature configs failed") pure (status >>= fromResult . fromJSON) where fromResult :: Result a -> Maybe a fromResult (Success b) = Just b fromResult _ = Nothing -getAllFeatureConfigs :: HasCallStack => UserId -> TestM ResponseLBS -getAllFeatureConfigs uid = do - g <- viewGalley - getAllFeatureConfigsWithGalley g uid - -getAllFeatureConfigsWithGalley :: (MonadHttp m, HasCallStack) => (Request -> Request) -> UserId -> m ResponseLBS -getAllFeatureConfigsWithGalley galley uid = do - get $ - galley - . paths ["feature-configs"] - . zUser uid - -putTeamFeatureFlagWithGalley :: +putTeamFeature :: forall cfg. ( HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), ToJSON (Public.WithStatusNoLock cfg) ) => - (Request -> Request) -> UserId -> TeamId -> Public.WithStatusNoLock cfg -> TestM ResponseLBS -putTeamFeatureFlagWithGalley galley uid tid status = +putTeamFeature uid tid status = do + galley <- viewGalley put $ galley . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] . json status . zUser uid -putTeamFeatureFlagInternalTTL :: - forall cfg. - ( HasCallStack, - Public.IsFeatureConfig cfg, - KnownSymbol (Public.FeatureSymbol cfg), - ToSchema cfg - ) => - (Request -> Request) -> - TeamId -> - Public.WithStatusNoLock cfg -> - TestM ResponseLBS -putTeamFeatureFlagInternalTTL reqmod tid status = do - g <- viewGalley - putTeamFeatureFlagInternalWithGalleyAndMod @cfg g reqmod tid status - -putTeamFeatureFlagInternal :: - forall cfg. - ( HasCallStack, - KnownSymbol (Public.FeatureSymbol cfg), - ToJSON (Public.WithStatusNoLock cfg) - ) => - (Request -> Request) -> - TeamId -> - Public.WithStatusNoLock cfg -> - TestM ResponseLBS -putTeamFeatureFlagInternal reqmod tid status = do - g <- viewGalley - putTeamFeatureFlagInternalWithGalleyAndMod @cfg g reqmod tid status - -putTeamFeatureFlagInternalWithGalleyAndMod :: +putTeamFeatureInternal :: forall cfg m. - ( MonadHttp m, + ( Monad m, + HasGalley m, + MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), ToJSON (Public.WithStatusNoLock cfg) ) => (Request -> Request) -> - (Request -> Request) -> TeamId -> Public.WithStatusNoLock cfg -> m ResponseLBS -putTeamFeatureFlagInternalWithGalleyAndMod galley reqmod tid status = +putTeamFeatureInternal reqmod tid status = do + galley <- viewGalley put $ galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] @@ -230,20 +202,7 @@ setLockStatusInternal reqmod tid lockStatus = do . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg, toByteString' lockStatus] . reqmod -getFeatureStatusInternal :: - forall cfg. - ( HasCallStack, - KnownSymbol (Public.FeatureSymbol cfg) - ) => - TeamId -> - TestM ResponseLBS -getFeatureStatusInternal tid = do - galley <- viewGalley - get $ - galley - . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] - -patchFeatureStatusInternal :: +patchTeamFeatureInternal :: forall cfg. ( HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), @@ -252,14 +211,9 @@ patchFeatureStatusInternal :: TeamId -> Public.WithStatusPatch cfg -> TestM ResponseLBS -patchFeatureStatusInternal tid reqBody = do - galley <- viewGalley - patch $ - galley - . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] - . json reqBody +patchTeamFeatureInternal = patchTeamFeatureInternalWithMod id -patchFeatureStatusInternalWithMod :: +patchTeamFeatureInternalWithMod :: forall cfg. ( HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), @@ -269,7 +223,7 @@ patchFeatureStatusInternalWithMod :: TeamId -> Public.WithStatusPatch cfg -> TestM ResponseLBS -patchFeatureStatusInternalWithMod reqmod tid reqBody = do +patchTeamFeatureInternalWithMod reqmod tid reqBody = do galley <- viewGalley patch $ galley @@ -288,3 +242,44 @@ getGuestLinkStatus galley u cid = galley . paths ["conversations", toByteString' cid, "features", Public.featureNameBS @Public.GuestLinksConfig] . zUser u + +checkTeamFeatureAllEndpoints :: + forall cfg. + ( HasCallStack, + IsFeatureConfig cfg, + ToSchema cfg, + Typeable cfg, + Eq cfg, + Show cfg, + KnownSymbol (FeatureSymbol cfg) + ) => + UserId -> + TeamId -> + WithStatus cfg -> + TestM () +checkTeamFeatureAllEndpoints uid tid expected = do + compareLeniently $ responseJsonUnsafe <$> getTeamFeatureInternal @cfg tid + compareLeniently $ responseJsonUnsafe <$> getTeamFeature @cfg uid tid + compareLeniently $ getTeamFeatureFromAll @cfg uid tid + compareLeniently $ getFeatureConfig uid + where + compareLeniently :: TestM (WithStatus cfg) -> TestM () + compareLeniently receive = do + received <- receive + liftIO $ do + wsStatus received @?= wsStatus expected + wsLockStatus received @?= wsLockStatus expected + wsConfig received @?= wsConfig expected + checkTtl (wsTTL received) (wsTTL expected) + + checkTtl :: FeatureTTL -> FeatureTTL -> IO () + checkTtl (FeatureTTLSeconds actualTtl) (FeatureTTLSeconds expectedTtl) = + assertBool + ("expected the actual TTL to be greater than 0 and equal to or no more than 2 seconds less than " <> show expectedTtl <> ", but it was " <> show actualTtl) + ( actualTtl > 0 + && actualTtl <= expectedTtl + && abs (fromIntegral @Word @Int actualTtl - fromIntegral @Word @Int expectedTtl) <= 2 + ) + checkTtl FeatureTTLUnlimited FeatureTTLUnlimited = pure () + checkTtl FeatureTTLUnlimited _ = assertFailure "expected the actual TTL to be unlimited, but it was limited" + checkTtl _ FeatureTTLUnlimited = assertFailure "expected the actual TTL to be limited, but it was unlimited"