From b87ad058465071a0918d041f1062f1e8b6c33c9f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 1 Aug 2024 15:06:30 +0200 Subject: [PATCH 01/34] Rename feature types --- libs/galley-types/src/Galley/Types/Teams.hs | 20 +- .../src/Wire/API/Event/FeatureConfig.hs | 30 +-- .../src/Wire/API/Routes/Internal/Brig.hs | 6 +- .../src/Wire/API/Routes/Internal/Galley.hs | 10 +- .../src/Wire/API/Routes/Internal/LegalHold.hs | 6 +- .../src/Wire/API/Routes/Public/Galley.hs | 2 +- .../src/Wire/API/Routes/Public/Galley/Bot.hs | 2 +- .../API/Routes/Public/Galley/Conversation.hs | 4 +- .../API/Routes/Public/Galley/CustomBackend.hs | 2 +- .../Wire/API/Routes/Public/Galley/Feature.hs | 16 +- .../API/Routes/Public/Galley/LegalHold.hs | 2 +- .../src/Wire/API/Routes/Public/Galley/MLS.hs | 2 +- .../API/Routes/Public/Galley/Messaging.hs | 2 +- .../src/Wire/API/Routes/Public/Galley/Team.hs | 2 +- .../Routes/Public/Galley/TeamConversation.hs | 2 +- .../API/Routes/Public/Galley/TeamMember.hs | 2 +- libs/wire-api/src/Wire/API/Team/Feature.hs | 156 +++++++------- .../golden/Test/Wire/API/Golden/FromJSON.hs | 6 +- .../golden/Test/Wire/API/Golden/Generated.hs | 200 +++++++++--------- .../Wire/API/Golden/Generated/Feature_team.hs | 75 +++++++ .../Generated/LockableFeaturePatch_team.hs | 84 ++++++++ .../Golden/Generated/LockableFeature_team.hs | 108 ++++++++++ .../Golden/Generated/WithStatusNoLock_team.hs | 75 ------- .../Golden/Generated/WithStatusPatch_team.hs | 84 -------- .../API/Golden/Generated/WithStatus_team.hs | 108 ---------- ...> testObject_LockableFeature_team_14.json} | 0 ..._1.json => testObject_Feature_team_1.json} | 0 ...0.json => testObject_Feature_team_10.json} | 0 ...1.json => testObject_Feature_team_11.json} | 0 ...2.json => testObject_Feature_team_12.json} | 0 ...3.json => testObject_Feature_team_13.json} | 0 ...4.json => testObject_Feature_team_14.json} | 0 ...5.json => testObject_Feature_team_15.json} | 0 ...6.json => testObject_Feature_team_16.json} | 0 ...7.json => testObject_Feature_team_17.json} | 0 ..._2.json => testObject_Feature_team_2.json} | 0 ..._3.json => testObject_Feature_team_3.json} | 0 ..._4.json => testObject_Feature_team_4.json} | 0 ..._5.json => testObject_Feature_team_5.json} | 0 ..._6.json => testObject_Feature_team_6.json} | 0 ..._7.json => testObject_Feature_team_7.json} | 0 ..._8.json => testObject_Feature_team_8.json} | 0 ..._9.json => testObject_Feature_team_9.json} | 0 ...stObject_LockableFeaturePatch_team_1.json} | 0 ...tObject_LockableFeaturePatch_team_10.json} | 0 ...tObject_LockableFeaturePatch_team_11.json} | 0 ...tObject_LockableFeaturePatch_team_12.json} | 0 ...tObject_LockableFeaturePatch_team_13.json} | 0 ...tObject_LockableFeaturePatch_team_14.json} | 0 ...tObject_LockableFeaturePatch_team_15.json} | 0 ...tObject_LockableFeaturePatch_team_16.json} | 0 ...tObject_LockableFeaturePatch_team_17.json} | 0 ...tObject_LockableFeaturePatch_team_18.json} | 0 ...tObject_LockableFeaturePatch_team_19.json} | 0 ...stObject_LockableFeaturePatch_team_2.json} | 0 ...stObject_LockableFeaturePatch_team_3.json} | 0 ...stObject_LockableFeaturePatch_team_4.json} | 0 ...stObject_LockableFeaturePatch_team_5.json} | 0 ...stObject_LockableFeaturePatch_team_6.json} | 0 ...stObject_LockableFeaturePatch_team_7.json} | 0 ...stObject_LockableFeaturePatch_team_8.json} | 0 ...stObject_LockableFeaturePatch_team_9.json} | 0 ...=> testObject_LockableFeature_team_1.json} | 0 ...> testObject_LockableFeature_team_10.json} | 0 ...> testObject_LockableFeature_team_11.json} | 0 ...> testObject_LockableFeature_team_12.json} | 0 ...> testObject_LockableFeature_team_13.json} | 0 ...> testObject_LockableFeature_team_14.json} | 0 ...> testObject_LockableFeature_team_15.json} | 0 ...> testObject_LockableFeature_team_16.json} | 0 ...> testObject_LockableFeature_team_17.json} | 0 ...> testObject_LockableFeature_team_18.json} | 0 ...> testObject_LockableFeature_team_19.json} | 0 ...=> testObject_LockableFeature_team_2.json} | 0 ...=> testObject_LockableFeature_team_3.json} | 0 ...=> testObject_LockableFeature_team_4.json} | 0 ...=> testObject_LockableFeature_team_5.json} | 0 ...=> testObject_LockableFeature_team_6.json} | 0 ...=> testObject_LockableFeature_team_7.json} | 0 ...=> testObject_LockableFeature_team_8.json} | 0 ...=> testObject_LockableFeature_team_9.json} | 0 .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 8 +- libs/wire-api/wire-api.cabal | 6 +- .../src/Wire/GalleyAPIAccess.hs | 2 +- .../src/Wire/GalleyAPIAccess/Rpc.hs | 6 +- services/brig/src/Brig/API/Internal.hs | 4 +- services/brig/src/Brig/Data/User.hs | 4 +- services/brig/src/Brig/Options.hs | 4 +- .../brig/test/integration/API/Provider.hs | 2 +- .../brig/test/integration/API/Team/Util.hs | 6 +- .../brig/test/integration/API/User/Util.hs | 2 +- services/galley/src/Galley/API/Internal.hs | 2 +- .../galley/src/Galley/API/MLS/Migration.hs | 2 +- services/galley/src/Galley/API/Query.hs | 4 +- .../galley/src/Galley/API/Teams/Features.hs | 30 +-- .../src/Galley/API/Teams/Features/Get.hs | 32 +-- .../src/Galley/Cassandra/TeamFeatures.hs | 2 +- .../galley/src/Galley/Effects/BrigAccess.hs | 2 +- .../src/Galley/Effects/TeamFeatureStore.hs | 2 +- services/galley/src/Galley/Intra/User.hs | 2 +- services/galley/test/integration/API.hs | 14 +- services/galley/test/integration/API/Teams.hs | 10 +- .../API/Teams/LegalHold/DisabledByDefault.hs | 10 +- .../integration/API/Teams/LegalHold/Util.hs | 2 +- .../test/integration/API/Util/TeamFeature.hs | 10 +- services/spar/src/Spar/Intra/Galley.hs | 4 +- .../Test/Spar/Scim/AuthSpec.hs | 2 +- services/spar/test-integration/Util/Core.hs | 2 +- services/spar/test-integration/Util/Email.hs | 2 +- tools/stern/src/Stern/API.hs | 10 +- tools/stern/src/Stern/API/Routes.hs | 4 +- tools/stern/src/Stern/Intra.hs | 16 +- tools/stern/test/integration/API.hs | 12 +- 113 files changed, 613 insertions(+), 613 deletions(-) create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs create mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusNoLock_team.hs delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusPatch_team.hs delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs rename libs/wire-api/test/golden/fromJSON/{testObject_WithStatus_team_14.json => testObject_LockableFeature_team_14.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_1.json => testObject_Feature_team_1.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_10.json => testObject_Feature_team_10.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_11.json => testObject_Feature_team_11.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_12.json => testObject_Feature_team_12.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_13.json => testObject_Feature_team_13.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_14.json => testObject_Feature_team_14.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_15.json => testObject_Feature_team_15.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_16.json => testObject_Feature_team_16.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_17.json => testObject_Feature_team_17.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_2.json => testObject_Feature_team_2.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_3.json => testObject_Feature_team_3.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_4.json => testObject_Feature_team_4.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_5.json => testObject_Feature_team_5.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_6.json => testObject_Feature_team_6.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_7.json => testObject_Feature_team_7.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_8.json => testObject_Feature_team_8.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusNoLock_team_9.json => testObject_Feature_team_9.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_1.json => testObject_LockableFeaturePatch_team_1.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_10.json => testObject_LockableFeaturePatch_team_10.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_11.json => testObject_LockableFeaturePatch_team_11.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_12.json => testObject_LockableFeaturePatch_team_12.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_13.json => testObject_LockableFeaturePatch_team_13.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_14.json => testObject_LockableFeaturePatch_team_14.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_15.json => testObject_LockableFeaturePatch_team_15.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_16.json => testObject_LockableFeaturePatch_team_16.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_17.json => testObject_LockableFeaturePatch_team_17.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_18.json => testObject_LockableFeaturePatch_team_18.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_19.json => testObject_LockableFeaturePatch_team_19.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_2.json => testObject_LockableFeaturePatch_team_2.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_3.json => testObject_LockableFeaturePatch_team_3.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_4.json => testObject_LockableFeaturePatch_team_4.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_5.json => testObject_LockableFeaturePatch_team_5.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_6.json => testObject_LockableFeaturePatch_team_6.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_7.json => testObject_LockableFeaturePatch_team_7.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_8.json => testObject_LockableFeaturePatch_team_8.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatusPatch_team_9.json => testObject_LockableFeaturePatch_team_9.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_1.json => testObject_LockableFeature_team_1.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_10.json => testObject_LockableFeature_team_10.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_11.json => testObject_LockableFeature_team_11.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_12.json => testObject_LockableFeature_team_12.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_13.json => testObject_LockableFeature_team_13.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_14.json => testObject_LockableFeature_team_14.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_15.json => testObject_LockableFeature_team_15.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_16.json => testObject_LockableFeature_team_16.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_17.json => testObject_LockableFeature_team_17.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_18.json => testObject_LockableFeature_team_18.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_19.json => testObject_LockableFeature_team_19.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_2.json => testObject_LockableFeature_team_2.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_3.json => testObject_LockableFeature_team_3.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_4.json => testObject_LockableFeature_team_4.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_5.json => testObject_LockableFeature_team_5.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_6.json => testObject_LockableFeature_team_6.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_7.json => testObject_LockableFeature_team_7.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_8.json => testObject_LockableFeature_team_8.json} (100%) rename libs/wire-api/test/golden/{testObject_WithStatus_team_9.json => testObject_LockableFeature_team_9.json} (100%) diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 47ae6d8a516..d9acf7d6b11 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -84,18 +84,18 @@ data FeatureFlags = FeatureFlags _flagTeamSearchVisibility :: !FeatureTeamSearchVisibilityAvailability, _flagAppLockDefaults :: !(Defaults (ImplicitLockStatus AppLockConfig)), _flagClassifiedDomains :: !(ImplicitLockStatus ClassifiedDomainsConfig), - _flagFileSharing :: !(Defaults (WithStatus FileSharingConfig)), - _flagConferenceCalling :: !(Defaults (WithStatus ConferenceCallingConfig)), - _flagSelfDeletingMessages :: !(Defaults (WithStatus SelfDeletingMessagesConfig)), - _flagConversationGuestLinks :: !(Defaults (WithStatus GuestLinksConfig)), + _flagFileSharing :: !(Defaults (LockableFeature FileSharingConfig)), + _flagConferenceCalling :: !(Defaults (LockableFeature ConferenceCallingConfig)), + _flagSelfDeletingMessages :: !(Defaults (LockableFeature SelfDeletingMessagesConfig)), + _flagConversationGuestLinks :: !(Defaults (LockableFeature GuestLinksConfig)), _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (ImplicitLockStatus ValidateSAMLEmailsConfig)), - _flagTeamFeatureSndFactorPasswordChallengeStatus :: !(Defaults (WithStatus SndFactorPasswordChallengeConfig)), + _flagTeamFeatureSndFactorPasswordChallengeStatus :: !(Defaults (LockableFeature SndFactorPasswordChallengeConfig)), _flagTeamFeatureSearchVisibilityInbound :: !(Defaults (ImplicitLockStatus SearchVisibilityInboundConfig)), - _flagMLS :: !(Defaults (WithStatus MLSConfig)), - _flagOutlookCalIntegration :: !(Defaults (WithStatus OutlookCalIntegrationConfig)), - _flagMlsE2EId :: !(Defaults (WithStatus MlsE2EIdConfig)), - _flagMlsMigration :: !(Defaults (WithStatus MlsMigrationConfig)), - _flagEnforceFileDownloadLocation :: !(Defaults (WithStatus EnforceFileDownloadLocationConfig)), + _flagMLS :: !(Defaults (LockableFeature MLSConfig)), + _flagOutlookCalIntegration :: !(Defaults (LockableFeature OutlookCalIntegrationConfig)), + _flagMlsE2EId :: !(Defaults (LockableFeature MlsE2EIdConfig)), + _flagMlsMigration :: !(Defaults (LockableFeature MlsMigrationConfig)), + _flagEnforceFileDownloadLocation :: !(Defaults (LockableFeature EnforceFileDownloadLocationConfig)), _flagLimitedEventFanout :: !(Defaults (ImplicitLockStatus LimitedEventFanoutConfig)) } deriving (Eq, Show, Generic) diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index 32e67dcfaf6..e2c57e7b3b3 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -47,20 +47,20 @@ instance Arbitrary Event where do let arbConfig = oneof - [ arbitrary @(WithStatus SSOConfig) <&> toJSON, - arbitrary @(WithStatus SearchVisibilityAvailableConfig) <&> toJSON, - arbitrary @(WithStatus ValidateSAMLEmailsConfig) <&> toJSON, - arbitrary @(WithStatus DigitalSignaturesConfig) <&> toJSON, - arbitrary @(WithStatus AppLockConfig) <&> toJSON, - arbitrary @(WithStatus FileSharingConfig) <&> toJSON, - arbitrary @(WithStatus ClassifiedDomainsConfig) <&> toJSON, - arbitrary @(WithStatus ConferenceCallingConfig) <&> toJSON, - arbitrary @(WithStatus SelfDeletingMessagesConfig) <&> toJSON, - arbitrary @(WithStatus GuestLinksConfig) <&> toJSON, - arbitrary @(WithStatus SndFactorPasswordChallengeConfig) <&> toJSON, - arbitrary @(WithStatus SearchVisibilityInboundConfig) <&> toJSON, - arbitrary @(WithStatus MLSConfig) <&> toJSON, - arbitrary @(WithStatus ExposeInvitationURLsToTeamAdminConfig) <&> toJSON + [ arbitrary @(LockableFeature SSOConfig) <&> toJSON, + arbitrary @(LockableFeature SearchVisibilityAvailableConfig) <&> toJSON, + arbitrary @(LockableFeature ValidateSAMLEmailsConfig) <&> toJSON, + arbitrary @(LockableFeature DigitalSignaturesConfig) <&> toJSON, + arbitrary @(LockableFeature AppLockConfig) <&> toJSON, + arbitrary @(LockableFeature FileSharingConfig) <&> toJSON, + arbitrary @(LockableFeature ClassifiedDomainsConfig) <&> toJSON, + arbitrary @(LockableFeature ConferenceCallingConfig) <&> toJSON, + arbitrary @(LockableFeature SelfDeletingMessagesConfig) <&> toJSON, + arbitrary @(LockableFeature GuestLinksConfig) <&> toJSON, + arbitrary @(LockableFeature SndFactorPasswordChallengeConfig) <&> toJSON, + arbitrary @(LockableFeature SearchVisibilityInboundConfig) <&> toJSON, + arbitrary @(LockableFeature MLSConfig) <&> toJSON, + arbitrary @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) <&> toJSON ] Event <$> arbitrary @@ -98,5 +98,5 @@ instance ToJSONObject Event where instance S.ToSchema Event where declareNamedSchema = schemaToSwagger -mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => WithStatus cfg -> Event +mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => LockableFeature cfg -> Event mkUpdateEvent ws = Event Update (featureName @cfg) (toJSON ws) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index a143f9e3e33..6c14cbd6916 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -55,7 +55,7 @@ import Data.Text qualified as Text import GHC.TypeLits import Imports hiding (head) import Network.HTTP.Client qualified as HTTP -import Servant hiding (Handler, WithStatus, addHeader, respond) +import Servant hiding (Handler, addHeader, respond) import Servant.Client qualified as Servant import Servant.Client.Core qualified as Servant import Servant.OpenApi (HasOpenApi (toOpenApi)) @@ -114,7 +114,7 @@ type GetAccountConferenceCallingConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Get '[Servant.JSON] (WithStatusNoLock ConferenceCallingConfig) + :> Get '[Servant.JSON] (Feature ConferenceCallingConfig) type PutAccountConferenceCallingConfig = Summary @@ -123,7 +123,7 @@ type PutAccountConferenceCallingConfig = :> Capture "uid" UserId :> "features" :> "conferenceCalling" - :> Servant.ReqBody '[Servant.JSON] (WithStatusNoLock ConferenceCallingConfig) + :> Servant.ReqBody '[Servant.JSON] (Feature ConferenceCallingConfig) :> Put '[Servant.JSON] NoContent type DeleteAccountConferenceCallingConfig = diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index 44afc4e627a..b8f6b73b324 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -24,7 +24,7 @@ import Data.OpenApi (OpenApi, info, title) import Data.Range import GHC.TypeLits (AppendSymbol) import Imports hiding (head) -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi import Wire.API.ApplyMods import Wire.API.Bot @@ -410,8 +410,8 @@ type FeatureStatusBasePutInternal errs featureConfig = (AppendSymbol "Put config for " (FeatureSymbol featureConfig)) errs featureConfig - ( ReqBody '[JSON] (WithStatusNoLock featureConfig) - :> Put '[JSON] (WithStatus featureConfig) + ( ReqBody '[JSON] (Feature featureConfig) + :> Put '[JSON] (LockableFeature featureConfig) ) type FeatureStatusBasePatchInternal errs featureConfig = @@ -419,8 +419,8 @@ type FeatureStatusBasePatchInternal errs featureConfig = (AppendSymbol "Patch config for " (FeatureSymbol featureConfig)) errs featureConfig - ( ReqBody '[JSON] (WithStatusPatch featureConfig) - :> Patch '[JSON] (WithStatus featureConfig) + ( ReqBody '[JSON] (LockableFeaturePatch featureConfig) + :> Patch '[JSON] (LockableFeature featureConfig) ) type FeatureStatusBaseInternal desc errs featureConfig a = diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs index ffde2e561c3..bc963d2d962 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs @@ -23,7 +23,7 @@ import Data.OpenApi (OpenApi) import Data.OpenApi.Lens import Data.Proxy import Imports -import Servant.API hiding (Header, WithStatus) +import Servant.API hiding (Header) import Servant.OpenApi import Wire.API.Team.Feature @@ -32,10 +32,10 @@ type InternalLegalHoldAPI = :> "teams" :> ( Capture "tid" TeamId :> "legalhold" - :> Get '[JSON] (WithStatus LegalholdConfig) + :> Get '[JSON] (LockableFeature LegalholdConfig) :<|> Capture "tid" TeamId :> "legalhold" - :> ReqBody '[JSON] (WithStatusNoLock LegalholdConfig) + :> ReqBody '[JSON] (Feature LegalholdConfig) :> Put '[] NoContent ) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index 52ec0ee5022..e7610068772 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -20,7 +20,7 @@ module Wire.API.Routes.Public.Galley where -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.Bot diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs index 6d4359b545c..06b1df74de1 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Bot.hs @@ -17,7 +17,7 @@ module Wire.API.Routes.Public.Galley.Bot where -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Galley diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs index 064dd35f673..c228a3c2621 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Conversation.hs @@ -23,7 +23,7 @@ import Data.Id import Data.Range import Data.SOP (I (..), NS (..)) import Imports hiding (head) -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Conversation import Wire.API.Conversation.Code @@ -884,7 +884,7 @@ type ConversationAPI = :> Capture' '[Description "Conversation ID"] "cnv" ConvId :> "features" :> FeatureSymbol GuestLinksConfig - :> Get '[Servant.JSON] (WithStatus GuestLinksConfig) + :> Get '[Servant.JSON] (LockableFeature GuestLinksConfig) ) -- This endpoint can lead to the following events being sent: -- - ConvCodeDelete event to members diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/CustomBackend.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/CustomBackend.hs index 607a6e62573..c91dd758fdd 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/CustomBackend.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/CustomBackend.hs @@ -18,7 +18,7 @@ module Wire.API.Routes.Public.Galley.CustomBackend where import Data.Domain -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.CustomBackend import Wire.API.Error diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs index 4aba788fcf5..5e69d130941 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Feature.hs @@ -19,7 +19,7 @@ module Wire.API.Routes.Public.Galley.Feature where import Data.Id import GHC.TypeLits -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.ApplyMods import Wire.API.Conversation.Role @@ -157,7 +157,7 @@ type FeatureStatusBaseGet featureConfig = :> Capture "tid" TeamId :> "features" :> FeatureSymbol featureConfig - :> Get '[Servant.JSON] (WithStatus featureConfig) + :> Get '[Servant.JSON] (LockableFeature featureConfig) type FeatureStatusBasePutPublic errs featureConfig = Summary (AppendSymbol "Put config for " (FeatureSymbol featureConfig)) @@ -170,8 +170,8 @@ type FeatureStatusBasePutPublic errs featureConfig = :> Capture "tid" TeamId :> "features" :> FeatureSymbol featureConfig - :> ReqBody '[Servant.JSON] (WithStatusNoLock featureConfig) - :> Put '[Servant.JSON] (WithStatus featureConfig) + :> ReqBody '[Servant.JSON] (Feature featureConfig) + :> Put '[Servant.JSON] (LockableFeature featureConfig) -- | A type for a GET endpoint for a feature with a deprecated path type FeatureStatusBaseDeprecatedGet desc featureConfig = @@ -191,7 +191,7 @@ type FeatureStatusBaseDeprecatedGet desc featureConfig = :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureConfig - :> Get '[Servant.JSON] (WithStatus featureConfig) + :> Get '[Servant.JSON] (LockableFeature featureConfig) ) -- | A type for a PUT endpoint for a feature with a deprecated path @@ -213,8 +213,8 @@ type FeatureStatusBaseDeprecatedPut desc featureConfig = :> Capture "tid" TeamId :> "features" :> DeprecatedFeatureName featureConfig - :> ReqBody '[Servant.JSON] (WithStatusNoLock featureConfig) - :> Put '[Servant.JSON] (WithStatus featureConfig) + :> ReqBody '[Servant.JSON] (Feature featureConfig) + :> Put '[Servant.JSON] (LockableFeature featureConfig) type FeatureConfigDeprecatedGet desc featureConfig = Named @@ -228,7 +228,7 @@ type FeatureConfigDeprecatedGet desc featureConfig = :> CanThrow 'TeamNotFound :> "feature-configs" :> FeatureSymbol featureConfig - :> Get '[Servant.JSON] (WithStatus featureConfig) + :> Get '[Servant.JSON] (LockableFeature featureConfig) ) type AllFeatureConfigsUserGet = diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs index f04ad6c3e70..a9d7ebe219d 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/LegalHold.hs @@ -20,7 +20,7 @@ module Wire.API.Routes.Public.Galley.LegalHold where import Data.Id import GHC.Generics import Generics.SOP qualified as GSOP -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Conversation.Role import Wire.API.Error diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs index 6c53e5e3398..41d5dbf27a6 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/MLS.hs @@ -17,7 +17,7 @@ module Wire.API.Routes.Public.Galley.MLS where -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Galley diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs index d4b81661b79..c862d5863d0 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Messaging.hs @@ -23,7 +23,7 @@ import Data.OpenApi qualified as S import Data.SOP import Generics.SOP qualified as GSOP import Imports -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Brig qualified as BrigError diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs index fd3fd392a4a..4c0c61751d4 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/Team.hs @@ -19,7 +19,7 @@ module Wire.API.Routes.Public.Galley.Team where import Data.Id import Imports -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Galley diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs index 0f45c2ac92c..98573abb02e 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamConversation.hs @@ -18,7 +18,7 @@ module Wire.API.Routes.Public.Galley.TeamConversation where import Data.Id -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Conversation.Role import Wire.API.Error diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamMember.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamMember.hs index 4c71df03e49..ef66057baa3 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamMember.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley/TeamMember.hs @@ -22,7 +22,7 @@ import Data.Int import Data.Range import GHC.Generics import Generics.SOP qualified as GSOP -import Servant hiding (WithStatus) +import Servant import Servant.OpenApi.Internal.Orphans () import Wire.API.Error import Wire.API.Error.Galley diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f5083f5c87f..5ecdc89ae57 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -26,14 +26,14 @@ module Wire.API.Team.Feature featureName, featureNameBS, LockStatus (..), - WithStatusBase (..), + LockableFeatureBase (..), DbFeature (..), DbFeatureWithLock (..), dbFeatureStatus, dbFeatureTTL, dbFeatureConfig, dbFeatureModConfig, - WithStatus, + LockableFeature, withStatus, withStatus', wsStatus, @@ -46,13 +46,13 @@ module Wire.API.Team.Feature setConfig', setTTL, setWsTTL, - WithStatusPatch, + LockableFeaturePatch, wsPatch, wspStatus, wspLockStatus, wspConfig, wspTTL, - WithStatusNoLock (..), + Feature (..), forgetLock, withLockStatus, withUnlocked, @@ -191,7 +191,7 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- 'docs/src/understand/team-feature-settings.md') class IsFeatureConfig cfg where type FeatureSymbol cfg :: Symbol - defFeatureStatus :: WithStatus cfg + defFeatureStatus :: LockableFeature cfg featureSingleton :: FeatureSingleton cfg objectSchema :: @@ -235,9 +235,9 @@ featureNameBS :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => ByteString featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg)) ---------------------------------------------------------------------- --- WithStatusBase +-- LockableFeatureBase -data WithStatusBase (m :: Type -> Type) (cfg :: Type) = WithStatusBase +data LockableFeatureBase (m :: Type -> Type) (cfg :: Type) = LockableFeatureBase { wsbStatus :: m FeatureStatus, wsbLockStatus :: m LockStatus, wsbConfig :: m cfg, @@ -250,7 +250,7 @@ data WithStatusBase (m :: Type -> Type) (cfg :: Type) = WithStatusBase -- | Feature data stored in the database, as a function of its default values. newtype DbFeature cfg = DbFeature - {unDbFeature :: WithStatusNoLock cfg -> WithStatusNoLock cfg} + {unDbFeature :: Feature cfg -> Feature cfg} instance Semigroup (DbFeature cfg) where DbFeature f <> DbFeature g = DbFeature (f . g) @@ -276,7 +276,7 @@ data DbFeatureWithLock cfg = DbFeatureWithLock } ---------------------------------------------------------------------- --- WithStatus +-- LockableFeature -- [Note: unsettable features] -- @@ -297,152 +297,152 @@ data DbFeatureWithLock cfg = DbFeatureWithLock -- an example of this mechanism in practice. -- FUTUREWORK: use lenses, maybe? -wsStatus :: WithStatus cfg -> FeatureStatus +wsStatus :: LockableFeature cfg -> FeatureStatus wsStatus = runIdentity . wsbStatus -wsLockStatus :: WithStatus cfg -> LockStatus +wsLockStatus :: LockableFeature cfg -> LockStatus wsLockStatus = runIdentity . wsbLockStatus -wsConfig :: WithStatus cfg -> cfg +wsConfig :: LockableFeature cfg -> cfg wsConfig = runIdentity . wsbConfig -wsTTL :: WithStatus cfg -> FeatureTTL +wsTTL :: LockableFeature cfg -> FeatureTTL wsTTL = runIdentity . wsbTTL -withStatus :: FeatureStatus -> LockStatus -> cfg -> FeatureTTL -> WithStatus cfg -withStatus s ls c ttl = WithStatusBase (Identity s) (Identity ls) (Identity c) (Identity ttl) +withStatus :: FeatureStatus -> LockStatus -> cfg -> FeatureTTL -> LockableFeature cfg +withStatus s ls c ttl = LockableFeatureBase (Identity s) (Identity ls) (Identity c) (Identity ttl) -setStatus :: FeatureStatus -> WithStatus cfg -> WithStatus cfg -setStatus s (WithStatusBase _ ls c ttl) = WithStatusBase (Identity s) ls c ttl +setStatus :: FeatureStatus -> LockableFeature cfg -> LockableFeature cfg +setStatus s (LockableFeatureBase _ ls c ttl) = LockableFeatureBase (Identity s) ls c ttl -setLockStatus :: LockStatus -> WithStatus cfg -> WithStatus cfg -setLockStatus ls (WithStatusBase s _ c ttl) = WithStatusBase s (Identity ls) c ttl +setLockStatus :: LockStatus -> LockableFeature cfg -> LockableFeature cfg +setLockStatus ls (LockableFeatureBase s _ c ttl) = LockableFeatureBase s (Identity ls) c ttl -setConfig :: cfg -> WithStatus cfg -> WithStatus cfg +setConfig :: cfg -> LockableFeature cfg -> LockableFeature cfg setConfig = setConfig' -setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> WithStatusBase m cfg -> WithStatusBase m cfg -setConfig' c (WithStatusBase s ls _ ttl) = WithStatusBase s ls (pure c) ttl +setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg +setConfig' c (LockableFeatureBase s ls _ ttl) = LockableFeatureBase s ls (pure c) ttl -setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> WithStatusBase m cfg -> WithStatusBase m cfg -setTTL ttl (WithStatusBase s ls c _) = WithStatusBase s ls c (pure ttl) +setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg +setTTL ttl (LockableFeatureBase s ls c _) = LockableFeatureBase s ls c (pure ttl) -setWsTTL :: FeatureTTL -> WithStatus cfg -> WithStatus cfg +setWsTTL :: FeatureTTL -> LockableFeature cfg -> LockableFeature cfg setWsTTL = setTTL -type WithStatus = WithStatusBase Identity +type LockableFeature = LockableFeatureBase Identity -deriving instance (Eq cfg) => Eq (WithStatus cfg) +deriving instance (Eq cfg) => Eq (LockableFeature cfg) -deriving instance (Show cfg) => Show (WithStatus cfg) +deriving instance (Show cfg) => Show (LockableFeature cfg) -deriving via (Schema (WithStatus cfg)) instance (ToSchema (WithStatus cfg)) => ToJSON (WithStatus cfg) +deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg)) => ToJSON (LockableFeature cfg) -deriving via (Schema (WithStatus cfg)) instance (ToSchema (WithStatus cfg)) => FromJSON (WithStatus cfg) +deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg)) => FromJSON (LockableFeature cfg) -deriving via (Schema (WithStatus cfg)) instance (ToSchema (WithStatus cfg), Typeable cfg) => S.ToSchema (WithStatus cfg) +deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg), Typeable cfg) => S.ToSchema (LockableFeature cfg) -instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (WithStatus cfg) where +instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where schema = object name $ - WithStatusBase + LockableFeatureBase <$> (runIdentity . wsbStatus) .= (Identity <$> field "status" schema) <*> (runIdentity . wsbLockStatus) .= (Identity <$> field "lockStatus" schema) <*> (runIdentity . wsbConfig) .= (Identity <$> objectSchema @cfg) <*> (runIdentity . wsbTTL) .= (Identity . fromMaybe FeatureTTLUnlimited <$> optField "ttl" schema) where inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".WithStatus" + name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeature" -instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (WithStatus cfg) where - arbitrary = WithStatusBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeature cfg) where + arbitrary = LockableFeatureBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary ---------------------------------------------------------------------- --- WithStatusPatch +-- LockableFeaturePatch -type WithStatusPatch (cfg :: Type) = WithStatusBase Maybe cfg +type LockableFeaturePatch (cfg :: Type) = LockableFeatureBase Maybe cfg -deriving instance (Eq cfg) => Eq (WithStatusPatch cfg) +deriving instance (Eq cfg) => Eq (LockableFeaturePatch cfg) -deriving instance (Show cfg) => Show (WithStatusPatch cfg) +deriving instance (Show cfg) => Show (LockableFeaturePatch cfg) -deriving via (Schema (WithStatusPatch cfg)) instance (ToSchema (WithStatusPatch cfg)) => ToJSON (WithStatusPatch cfg) +deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg)) => ToJSON (LockableFeaturePatch cfg) -deriving via (Schema (WithStatusPatch cfg)) instance (ToSchema (WithStatusPatch cfg)) => FromJSON (WithStatusPatch cfg) +deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg)) => FromJSON (LockableFeaturePatch cfg) -deriving via (Schema (WithStatusPatch cfg)) instance (ToSchema (WithStatusPatch cfg), Typeable cfg) => S.ToSchema (WithStatusPatch cfg) +deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg), Typeable cfg) => S.ToSchema (LockableFeaturePatch cfg) -wsPatch :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> WithStatusPatch cfg -wsPatch = WithStatusBase +wsPatch :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> LockableFeaturePatch cfg +wsPatch = LockableFeatureBase -wspStatus :: WithStatusPatch cfg -> Maybe FeatureStatus +wspStatus :: LockableFeaturePatch cfg -> Maybe FeatureStatus wspStatus = wsbStatus -wspLockStatus :: WithStatusPatch cfg -> Maybe LockStatus +wspLockStatus :: LockableFeaturePatch cfg -> Maybe LockStatus wspLockStatus = wsbLockStatus -wspConfig :: WithStatusPatch cfg -> Maybe cfg +wspConfig :: LockableFeaturePatch cfg -> Maybe cfg wspConfig = wsbConfig -wspTTL :: WithStatusPatch cfg -> Maybe FeatureTTL +wspTTL :: LockableFeaturePatch cfg -> Maybe FeatureTTL wspTTL = wsbTTL -withStatus' :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> WithStatusPatch cfg -withStatus' = WithStatusBase +withStatus' :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> LockableFeaturePatch cfg +withStatus' = LockableFeatureBase --- | The ToJSON implementation of `WithStatusPatch` will encode the trivial config as `"config": {}` +-- | The ToJSON implementation of `LockableFeaturePatch` will encode the trivial config as `"config": {}` -- when the value is a `Just`, if it's `Nothing` it will be omitted, which is the important part. -instance (ToSchema cfg) => ToSchema (WithStatusPatch cfg) where +instance (ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where schema = object name $ - WithStatusBase + LockableFeatureBase <$> wsbStatus .= maybe_ (optField "status" schema) <*> wsbLockStatus .= maybe_ (optField "lockStatus" schema) <*> wsbConfig .= maybe_ (optField "config" schema) <*> wsbTTL .= maybe_ (optField "ttl" schema) where inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".WithStatusPatch" + name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeaturePatch" -instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (WithStatusPatch cfg) where - arbitrary = WithStatusBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeaturePatch cfg) where + arbitrary = LockableFeatureBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary ---------------------------------------------------------------------- --- WithStatusNoLock +-- Feature -data WithStatusNoLock (cfg :: Type) = WithStatusNoLock +data Feature (cfg :: Type) = Feature { wssStatus :: FeatureStatus, wssConfig :: cfg, wssTTL :: FeatureTTL } deriving stock (Eq, Show, Generic, Typeable, Functor) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (WithStatusNoLock cfg)) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (Feature cfg)) -instance (Arbitrary cfg) => Arbitrary (WithStatusNoLock cfg) where - arbitrary = WithStatusNoLock <$> arbitrary <*> arbitrary <*> arbitrary +instance (Arbitrary cfg) => Arbitrary (Feature cfg) where + arbitrary = Feature <$> arbitrary <*> arbitrary <*> arbitrary -forgetLock :: WithStatus a -> WithStatusNoLock a -forgetLock ws = WithStatusNoLock (wsStatus ws) (wsConfig ws) (wsTTL ws) +forgetLock :: LockableFeature a -> Feature a +forgetLock ws = Feature (wsStatus ws) (wsConfig ws) (wsTTL ws) -withLockStatus :: LockStatus -> WithStatusNoLock a -> WithStatus a -withLockStatus ls (WithStatusNoLock s c ttl) = withStatus s ls c ttl +withLockStatus :: LockStatus -> Feature a -> LockableFeature a +withLockStatus ls (Feature s c ttl) = withStatus s ls c ttl -withUnlocked :: WithStatusNoLock a -> WithStatus a +withUnlocked :: Feature a -> LockableFeature a withUnlocked = withLockStatus LockStatusUnlocked -withLocked :: WithStatusNoLock a -> WithStatus a +withLocked :: Feature a -> LockableFeature a withLocked = withLockStatus LockStatusLocked -instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (WithStatusNoLock cfg) where +instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (Feature cfg) where schema = object name $ - WithStatusNoLock + Feature <$> wssStatus .= field "status" schema <*> wssConfig .= objectSchema @cfg <*> wssTTL .= (fromMaybe FeatureTTLUnlimited <$> optField "ttl" schema) where inner = schema @cfg - name = fromMaybe "" (getName (schemaDoc inner)) <> ".WithStatusNoLock" + name = fromMaybe "" (getName (schemaDoc inner)) <> ".Feature" ---------------------------------------------------------------------- -- FeatureTTL @@ -602,7 +602,7 @@ instance ToSchema LockStatusResponse where LockStatusResponse <$> _unlockStatus .= field "lockStatus" schema -newtype ImplicitLockStatus (cfg :: Type) = ImplicitLockStatus {_unImplicitLockStatus :: WithStatus cfg} +newtype ImplicitLockStatus (cfg :: Type) = ImplicitLockStatus {_unImplicitLockStatus :: LockableFeature cfg} deriving newtype (Eq, Show, Arbitrary) instance (IsFeatureConfig a, ToSchema a) => ToJSON (ImplicitLockStatus a) where @@ -615,17 +615,17 @@ instance (IsFeatureConfig a, ToSchema a) => FromJSON (ImplicitLockStatus a) wher -- overridden on a feature basis by implementing the `computeFeature` method of -- the `GetFeatureConfig` class. genericComputeFeature :: - WithStatus cfg -> + LockableFeature cfg -> Maybe LockStatus -> DbFeature cfg -> - WithStatus cfg + LockableFeature cfg genericComputeFeature defFeature lockStatus dbFeature = case fromMaybe (wsLockStatus defFeature) lockStatus of LockStatusLocked -> setLockStatus LockStatusLocked defFeature LockStatusUnlocked -> withUnlocked $ unDbFeature dbFeature (forgetLock defFeature) -- | This contains the pure business logic for users from teams -computeFeatureConfigForTeamUser :: Maybe (WithStatusNoLock cfg) -> Maybe LockStatus -> WithStatus cfg -> WithStatus cfg +computeFeatureConfigForTeamUser :: Maybe (Feature cfg) -> Maybe LockStatus -> LockableFeature cfg -> LockableFeature cfg computeFeatureConfigForTeamUser mStatusDb mLockStatusDb defStatus = case lockStatus of LockStatusLocked -> @@ -1271,7 +1271,7 @@ instance Cass.Cql FeatureStatus where toCql FeatureStatusDisabled = Cass.CqlInt 0 toCql FeatureStatusEnabled = Cass.CqlInt 1 -defFeatureStatusNoLock :: (IsFeatureConfig cfg) => WithStatusNoLock cfg +defFeatureStatusNoLock :: (IsFeatureConfig cfg) => Feature cfg defFeatureStatusNoLock = forgetLock defFeatureStatus -- FUTUREWORK: rewrite using SOP @@ -1298,7 +1298,7 @@ data AllFeatures f = AllFeatures afcLimitedEventFanout :: f LimitedEventFanoutConfig } -type AllFeatureConfigs = AllFeatures WithStatus +type AllFeatureConfigs = AllFeatures LockableFeature instance Default AllFeatureConfigs where def = @@ -1353,7 +1353,7 @@ instance ToSchema AllFeatureConfigs where featureField :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => - ObjectSchema SwaggerDoc (WithStatus cfg) + ObjectSchema SwaggerDoc (LockableFeature cfg) featureField = field (T.pack (symbolVal (Proxy @(FeatureSymbol cfg)))) schema instance Arbitrary AllFeatureConfigs where diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs index e999ab389a2..d97e39d2bbf 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs @@ -25,7 +25,7 @@ import Test.Wire.API.Golden.Generated.MemberUpdateData_user import Test.Wire.API.Golden.Generated.NewOtrMessage_user import Test.Wire.API.Golden.Generated.RmClient_user import Test.Wire.API.Golden.Generated.SimpleMember_user -import Test.Wire.API.Golden.Generated.WithStatus_team +import Test.Wire.API.Golden.Generated.LockableFeature_team import Test.Wire.API.Golden.Runner import Wire.API.Conversation (Conversation, MemberUpdate, OtherMemberUpdate) import Wire.API.User (NewUser, NewUserPublic) @@ -90,6 +90,6 @@ tests = (Just "only managed-by-Wire users can be created here.") "testObject_NewUserPublic_user_1-3.json" ], - testCase "WithStatus_ConferenceCallingConfig" $ - testFromJSONObject testObject_WithStatus_team_14 "testObject_WithStatus_team_14.json" + testCase "LockableFeature_ConferenceCallingConfig" $ + testFromJSONObject testObject_LockableFeature_team_14 "testObject_LockableFeature_team_14.json" ] diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index cf0a3e20eaf..ff52988b3b1 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -227,9 +227,9 @@ import Test.Wire.API.Golden.Generated.VerificationAction_user qualified import Test.Wire.API.Golden.Generated.VerifyDeleteUser_user qualified import Test.Wire.API.Golden.Generated.ViewLegalHoldServiceInfo_team qualified import Test.Wire.API.Golden.Generated.ViewLegalHoldService_team qualified -import Test.Wire.API.Golden.Generated.WithStatusNoLock_team qualified -import Test.Wire.API.Golden.Generated.WithStatusPatch_team qualified -import Test.Wire.API.Golden.Generated.WithStatus_team qualified +import Test.Wire.API.Golden.Generated.Feature_team qualified +import Test.Wire.API.Golden.Generated.LockableFeaturePatch_team qualified +import Test.Wire.API.Golden.Generated.LockableFeature_team qualified import Test.Wire.API.Golden.Generated.Wrapped_20_22some_5fint_22_20Int_user qualified import Test.Wire.API.Golden.Runner import Wire.API.Routes.Version @@ -1181,110 +1181,110 @@ tests = "testObject_TeamConversationList_team_2.json" ) ], - testGroup "Golden: WithStatusNoLock_team 1" $ + testGroup "Golden: Feature_team 1" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_1, "testObject_WithStatusNoLock_team_1.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_2, "testObject_WithStatusNoLock_team_2.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_3, "testObject_WithStatusNoLock_team_3.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_1, "testObject_Feature_team_1.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_2, "testObject_Feature_team_2.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_3, "testObject_Feature_team_3.json") ], - testGroup "Golden: WithStatusNoLock_team 2" $ + testGroup "Golden: Feature_team 2" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_4, "testObject_WithStatusNoLock_team_4.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_5, "testObject_WithStatusNoLock_team_5.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_6, "testObject_WithStatusNoLock_team_6.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_4, "testObject_Feature_team_4.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_5, "testObject_Feature_team_5.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_6, "testObject_Feature_team_6.json") ], - testGroup "Golden: WithStatusNoLock_team 3" $ + testGroup "Golden: Feature_team 3" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_7, "testObject_WithStatusNoLock_team_7.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_8, "testObject_WithStatusNoLock_team_8.json"), - (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_9, "testObject_WithStatusNoLock_team_9.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_7, "testObject_Feature_team_7.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_8, "testObject_Feature_team_8.json"), + (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_9, "testObject_Feature_team_9.json") ], - testGroup "Golden: WithStatusNoLock_team 4" $ + testGroup "Golden: Feature_team 4" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_10, "testObject_WithStatusNoLock_team_10.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_10, "testObject_Feature_team_10.json") ], - testGroup "Golden: WithStatusNoLock_team 5" $ + testGroup "Golden: Feature_team 5" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_11, "testObject_WithStatusNoLock_team_11.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_11, "testObject_Feature_team_11.json") ], - testGroup "Golden: WithStatusNoLock_team 6" $ + testGroup "Golden: Feature_team 6" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_12, "testObject_WithStatusNoLock_team_12.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_12, "testObject_Feature_team_12.json") ], - testGroup "Golden: WithStatusNoLock_team 7" $ + testGroup "Golden: Feature_team 7" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_13, "testObject_WithStatusNoLock_team_13.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_13, "testObject_Feature_team_13.json") ], - testGroup "Golden: WithStatusNoLock_team 8" $ + testGroup "Golden: Feature_team 8" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_14, "testObject_WithStatusNoLock_team_14.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_14, "testObject_Feature_team_14.json") ], - testGroup "Golden: WithStatusNoLock_team 9" $ + testGroup "Golden: Feature_team 9" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_15, "testObject_WithStatusNoLock_team_15.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_15, "testObject_Feature_team_15.json") ], - testGroup "Golden: WithStatusNoLock_team 10" $ + testGroup "Golden: Feature_team 10" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_16, "testObject_WithStatusNoLock_team_16.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_16, "testObject_Feature_team_16.json") ], - testGroup "Golden: WithStatusNoLock_team 11" $ + testGroup "Golden: Feature_team 11" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatusNoLock_team.testObject_WithStatusNoLock_team_17, "testObject_WithStatusNoLock_team_17.json") + [ (Test.Wire.API.Golden.Generated.Feature_team.testObject_Feature_team_17, "testObject_Feature_team_17.json") ], - testGroup "Golden: WithStatus_team 1" $ + testGroup "Golden: LockableFeature_team 1" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_1, "testObject_WithStatus_team_1.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_2, "testObject_WithStatus_team_2.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_3, "testObject_WithStatus_team_3.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_1, "testObject_LockableFeature_team_1.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_2, "testObject_LockableFeature_team_2.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_3, "testObject_LockableFeature_team_3.json") ], - testGroup "Golden: WithStatus_team 2" $ + testGroup "Golden: LockableFeature_team 2" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_4, "testObject_WithStatus_team_4.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_5, "testObject_WithStatus_team_5.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_6, "testObject_WithStatus_team_6.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_4, "testObject_LockableFeature_team_4.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_5, "testObject_LockableFeature_team_5.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_6, "testObject_LockableFeature_team_6.json") ], - testGroup "Golden: WithStatus_team 3" $ + testGroup "Golden: LockableFeature_team 3" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_7, "testObject_WithStatus_team_7.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_8, "testObject_WithStatus_team_8.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_9, "testObject_WithStatus_team_9.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_7, "testObject_LockableFeature_team_7.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_8, "testObject_LockableFeature_team_8.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_9, "testObject_LockableFeature_team_9.json") ], - testGroup "Golden: WithStatus_team 4" $ + testGroup "Golden: LockableFeature_team 4" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_10, "testObject_WithStatus_team_10.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_10, "testObject_LockableFeature_team_10.json") ], - testGroup "Golden: WithStatus_team 5" $ + testGroup "Golden: LockableFeature_team 5" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_11, "testObject_WithStatus_team_11.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_11, "testObject_LockableFeature_team_11.json") ], - testGroup "Golden: WithStatus_team 6" $ + testGroup "Golden: LockableFeature_team 6" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_12, "testObject_WithStatus_team_12.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_12, "testObject_LockableFeature_team_12.json") ], - testGroup "Golden: WithStatus_team 7" $ + testGroup "Golden: LockableFeature_team 7" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_13, "testObject_WithStatus_team_13.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_13, "testObject_LockableFeature_team_13.json") ], - testGroup "Golden: WithStatus_team 8" $ + testGroup "Golden: LockableFeature_team 8" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_14, "testObject_WithStatus_team_14.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_14, "testObject_LockableFeature_team_14.json") ], - testGroup "Golden: WithStatus_team 9" $ + testGroup "Golden: LockableFeature_team 9" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_15, "testObject_WithStatus_team_15.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_15, "testObject_LockableFeature_team_15.json") ], - testGroup "Golden: WithStatus_team 10" $ + testGroup "Golden: LockableFeature_team 10" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_16, "testObject_WithStatus_team_16.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_16, "testObject_LockableFeature_team_16.json") ], - testGroup "Golden: WithStatus_team 11" $ + testGroup "Golden: LockableFeature_team 11" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_17, "testObject_WithStatus_team_17.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_17, "testObject_LockableFeature_team_17.json") ], - testGroup "Golden: WithStatus_team 12" $ + testGroup "Golden: LockableFeature_team 12" $ testObjects - [ (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_18, "testObject_WithStatus_team_18.json"), - (Test.Wire.API.Golden.Generated.WithStatus_team.testObject_WithStatus_team_19, "testObject_WithStatus_team_19.json") + [ (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_18, "testObject_LockableFeature_team_18.json"), + (Test.Wire.API.Golden.Generated.LockableFeature_team.testObject_LockableFeature_team_19, "testObject_LockableFeature_team_19.json") ], testGroup "Golden: InvitationRequest_team" $ testObjects [(Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_1, "testObject_InvitationRequest_team_1.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_2, "testObject_InvitationRequest_team_2.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_3, "testObject_InvitationRequest_team_3.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_4, "testObject_InvitationRequest_team_4.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_5, "testObject_InvitationRequest_team_5.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_6, "testObject_InvitationRequest_team_6.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_7, "testObject_InvitationRequest_team_7.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_8, "testObject_InvitationRequest_team_8.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_9, "testObject_InvitationRequest_team_9.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_10, "testObject_InvitationRequest_team_10.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_11, "testObject_InvitationRequest_team_11.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_12, "testObject_InvitationRequest_team_12.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_13, "testObject_InvitationRequest_team_13.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_14, "testObject_InvitationRequest_team_14.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_15, "testObject_InvitationRequest_team_15.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_16, "testObject_InvitationRequest_team_16.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_17, "testObject_InvitationRequest_team_17.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_18, "testObject_InvitationRequest_team_18.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_19, "testObject_InvitationRequest_team_19.json"), (Test.Wire.API.Golden.Generated.InvitationRequest_team.testObject_InvitationRequest_team_20, "testObject_InvitationRequest_team_20.json")], @@ -1339,81 +1339,81 @@ tests = (Test.Wire.API.Golden.Generated.VerificationAction_user.testObject_VerificationAction_user_3, "testObject_VerificationAction_user_3") ], testGroup - "Golden: WithStatusPatch_team 1" + "Golden: LockableFeaturePatch_team 1" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_1, "testObject_WithStatusPatch_team_1.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_1, "testObject_LockableFeaturePatch_team_1.json")], testGroup - "Golden: WithStatusPatch_team 2" + "Golden: LockableFeaturePatch_team 2" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_2, "testObject_WithStatusPatch_team_2.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_2, "testObject_LockableFeaturePatch_team_2.json")], testGroup - "Golden: WithStatusPatch_team 3" + "Golden: LockableFeaturePatch_team 3" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_3, "testObject_WithStatusPatch_team_3.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_3, "testObject_LockableFeaturePatch_team_3.json")], testGroup - "Golden: WithStatusPatch_team 4" + "Golden: LockableFeaturePatch_team 4" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_4, "testObject_WithStatusPatch_team_4.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_4, "testObject_LockableFeaturePatch_team_4.json")], testGroup - "Golden: WithStatusPatch_team 5" + "Golden: LockableFeaturePatch_team 5" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_5, "testObject_WithStatusPatch_team_5.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_5, "testObject_LockableFeaturePatch_team_5.json")], testGroup - "Golden: WithStatusPatch_team 6" + "Golden: LockableFeaturePatch_team 6" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_6, "testObject_WithStatusPatch_team_6.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_6, "testObject_LockableFeaturePatch_team_6.json")], testGroup - "Golden: WithStatusPatch_team 7" + "Golden: LockableFeaturePatch_team 7" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_7, "testObject_WithStatusPatch_team_7.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_7, "testObject_LockableFeaturePatch_team_7.json")], testGroup - "Golden: WithStatusPatch_team 8" + "Golden: LockableFeaturePatch_team 8" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_8, "testObject_WithStatusPatch_team_8.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_8, "testObject_LockableFeaturePatch_team_8.json")], testGroup - "Golden: WithStatusPatch_team 9" + "Golden: LockableFeaturePatch_team 9" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_9, "testObject_WithStatusPatch_team_9.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_9, "testObject_LockableFeaturePatch_team_9.json")], testGroup - "Golden: WithStatusPatch_team 10" + "Golden: LockableFeaturePatch_team 10" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_10, "testObject_WithStatusPatch_team_10.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_10, "testObject_LockableFeaturePatch_team_10.json")], testGroup - "Golden: WithStatusPatch_team 11" + "Golden: LockableFeaturePatch_team 11" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_11, "testObject_WithStatusPatch_team_11.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_11, "testObject_LockableFeaturePatch_team_11.json")], testGroup - "Golden: WithStatusPatch_team 12" + "Golden: LockableFeaturePatch_team 12" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_12, "testObject_WithStatusPatch_team_12.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_12, "testObject_LockableFeaturePatch_team_12.json")], testGroup - "Golden: WithStatusPatch_team 13" + "Golden: LockableFeaturePatch_team 13" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_13, "testObject_WithStatusPatch_team_13.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_13, "testObject_LockableFeaturePatch_team_13.json")], testGroup - "Golden: WithStatusPatch_team 14" + "Golden: LockableFeaturePatch_team 14" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_14, "testObject_WithStatusPatch_team_14.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_14, "testObject_LockableFeaturePatch_team_14.json")], testGroup - "Golden: WithStatusPatch_team 15" + "Golden: LockableFeaturePatch_team 15" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_15, "testObject_WithStatusPatch_team_15.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_15, "testObject_LockableFeaturePatch_team_15.json")], testGroup - "Golden: WithStatusPatch_team 16" + "Golden: LockableFeaturePatch_team 16" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_16, "testObject_WithStatusPatch_team_16.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_16, "testObject_LockableFeaturePatch_team_16.json")], testGroup - "Golden: WithStatusPatch_team 17" + "Golden: LockableFeaturePatch_team 17" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_17, "testObject_WithStatusPatch_team_17.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_17, "testObject_LockableFeaturePatch_team_17.json")], testGroup - "Golden: WithStatusPatch_team 18" + "Golden: LockableFeaturePatch_team 18" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_18, "testObject_WithStatusPatch_team_18.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_18, "testObject_LockableFeaturePatch_team_18.json")], testGroup - "Golden: WithStatusPatch_team 19" + "Golden: LockableFeaturePatch_team 19" $ testObjects - [(Test.Wire.API.Golden.Generated.WithStatusPatch_team.testObject_WithStatusPatch_team_19, "testObject_WithStatusPatch_team_19.json")], + [(Test.Wire.API.Golden.Generated.LockableFeaturePatch_team.testObject_LockableFeaturePatch_team_19, "testObject_LockableFeaturePatch_team_19.json")], testGroup "Golden: Event_FeatureConfig" $ testObjects diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs new file mode 100644 index 00000000000..fe0e1ad6d33 --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedLists #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Generated.Feature_team where + +import Data.Domain +import Imports +import Wire.API.Team.Feature + +testObject_Feature_team_1 :: Feature AppLockConfig +testObject_Feature_team_1 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock False) (-98)) FeatureTTLUnlimited + +testObject_Feature_team_2 :: Feature AppLockConfig +testObject_Feature_team_2 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 0) FeatureTTLUnlimited + +testObject_Feature_team_3 :: Feature AppLockConfig +testObject_Feature_team_3 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 111) FeatureTTLUnlimited + +testObject_Feature_team_4 :: Feature SelfDeletingMessagesConfig +testObject_Feature_team_4 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig (-97)) FeatureTTLUnlimited + +testObject_Feature_team_5 :: Feature SelfDeletingMessagesConfig +testObject_Feature_team_5 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 0) FeatureTTLUnlimited + +testObject_Feature_team_6 :: Feature SelfDeletingMessagesConfig +testObject_Feature_team_6 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 77) FeatureTTLUnlimited + +testObject_Feature_team_7 :: Feature ClassifiedDomainsConfig +testObject_Feature_team_7 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig []) FeatureTTLUnlimited + +testObject_Feature_team_8 :: Feature ClassifiedDomainsConfig +testObject_Feature_team_8 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) FeatureTTLUnlimited + +testObject_Feature_team_9 :: Feature ClassifiedDomainsConfig +testObject_Feature_team_9 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "test.foobar"]) FeatureTTLUnlimited + +testObject_Feature_team_10 :: Feature SSOConfig +testObject_Feature_team_10 = Feature FeatureStatusDisabled SSOConfig FeatureTTLUnlimited + +testObject_Feature_team_11 :: Feature SearchVisibilityAvailableConfig +testObject_Feature_team_11 = Feature FeatureStatusEnabled SearchVisibilityAvailableConfig FeatureTTLUnlimited + +testObject_Feature_team_12 :: Feature ValidateSAMLEmailsConfig +testObject_Feature_team_12 = Feature FeatureStatusDisabled ValidateSAMLEmailsConfig FeatureTTLUnlimited + +testObject_Feature_team_13 :: Feature DigitalSignaturesConfig +testObject_Feature_team_13 = Feature FeatureStatusEnabled DigitalSignaturesConfig FeatureTTLUnlimited + +testObject_Feature_team_14 :: Feature ConferenceCallingConfig +testObject_Feature_team_14 = Feature FeatureStatusDisabled (ConferenceCallingConfig One2OneCallsSft) FeatureTTLUnlimited + +testObject_Feature_team_15 :: Feature GuestLinksConfig +testObject_Feature_team_15 = Feature FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited + +testObject_Feature_team_16 :: Feature SndFactorPasswordChallengeConfig +testObject_Feature_team_16 = Feature FeatureStatusDisabled SndFactorPasswordChallengeConfig FeatureTTLUnlimited + +testObject_Feature_team_17 :: Feature SearchVisibilityInboundConfig +testObject_Feature_team_17 = Feature FeatureStatusEnabled SearchVisibilityInboundConfig FeatureTTLUnlimited diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs new file mode 100644 index 00000000000..adef236459c --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedLists #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Generated.LockableFeaturePatch_team where + +import Data.Domain +import Imports +import Wire.API.Team.Feature hiding (withStatus) + +testObject_LockableFeaturePatch_team_1 :: LockableFeaturePatch AppLockConfig +testObject_LockableFeaturePatch_team_1 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (AppLockConfig (EnforceAppLock False) (-98))) + +testObject_LockableFeaturePatch_team_2 :: LockableFeaturePatch AppLockConfig +testObject_LockableFeaturePatch_team_2 = withStatus Nothing Nothing (Just (AppLockConfig (EnforceAppLock True) 0)) + +testObject_LockableFeaturePatch_team_3 :: LockableFeaturePatch AppLockConfig +testObject_LockableFeaturePatch_team_3 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (AppLockConfig (EnforceAppLock True) 111)) + +testObject_LockableFeaturePatch_team_4 :: LockableFeaturePatch SelfDeletingMessagesConfig +testObject_LockableFeaturePatch_team_4 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig (-97))) + +testObject_LockableFeaturePatch_team_5 :: LockableFeaturePatch SelfDeletingMessagesConfig +testObject_LockableFeaturePatch_team_5 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (SelfDeletingMessagesConfig 0)) + +testObject_LockableFeaturePatch_team_6 :: LockableFeaturePatch SelfDeletingMessagesConfig +testObject_LockableFeaturePatch_team_6 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig 77)) + +testObject_LockableFeaturePatch_team_7 :: LockableFeaturePatch ClassifiedDomainsConfig +testObject_LockableFeaturePatch_team_7 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [])) + +testObject_LockableFeaturePatch_team_8 :: LockableFeaturePatch ClassifiedDomainsConfig +testObject_LockableFeaturePatch_team_8 = withStatus Nothing (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"])) + +testObject_LockableFeaturePatch_team_9 :: LockableFeaturePatch ClassifiedDomainsConfig +testObject_LockableFeaturePatch_team_9 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (ClassifiedDomainsConfig [Domain "test.foobar"])) + +testObject_LockableFeaturePatch_team_10 :: LockableFeaturePatch SSOConfig +testObject_LockableFeaturePatch_team_10 = withStatus (Just FeatureStatusDisabled) (Just LockStatusLocked) (Just SSOConfig) + +testObject_LockableFeaturePatch_team_11 :: LockableFeaturePatch SearchVisibilityAvailableConfig +testObject_LockableFeaturePatch_team_11 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just SearchVisibilityAvailableConfig) + +testObject_LockableFeaturePatch_team_12 :: LockableFeaturePatch ValidateSAMLEmailsConfig +testObject_LockableFeaturePatch_team_12 = withStatus (Just FeatureStatusDisabled) Nothing (Just ValidateSAMLEmailsConfig) + +testObject_LockableFeaturePatch_team_13 :: LockableFeaturePatch DigitalSignaturesConfig +testObject_LockableFeaturePatch_team_13 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just DigitalSignaturesConfig) + +testObject_LockableFeaturePatch_team_14 :: LockableFeaturePatch ConferenceCallingConfig +testObject_LockableFeaturePatch_team_14 = withStatus Nothing (Just LockStatusUnlocked) (Just (ConferenceCallingConfig One2OneCallsSft)) + +testObject_LockableFeaturePatch_team_15 :: LockableFeaturePatch GuestLinksConfig +testObject_LockableFeaturePatch_team_15 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just GuestLinksConfig) + +testObject_LockableFeaturePatch_team_16 :: LockableFeaturePatch SndFactorPasswordChallengeConfig +testObject_LockableFeaturePatch_team_16 = withStatus (Just FeatureStatusDisabled) (Just LockStatusUnlocked) (Just SndFactorPasswordChallengeConfig) + +testObject_LockableFeaturePatch_team_17 :: LockableFeaturePatch SearchVisibilityInboundConfig +testObject_LockableFeaturePatch_team_17 = withStatus (Just FeatureStatusEnabled) Nothing (Just SearchVisibilityInboundConfig) + +testObject_LockableFeaturePatch_team_18 :: LockableFeaturePatch GuestLinksConfig +testObject_LockableFeaturePatch_team_18 = withStatus (Just FeatureStatusEnabled) Nothing Nothing + +testObject_LockableFeaturePatch_team_19 :: LockableFeaturePatch SelfDeletingMessagesConfig +testObject_LockableFeaturePatch_team_19 = withStatus Nothing (Just LockStatusUnlocked) Nothing + +withStatus :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> LockableFeaturePatch cfg +withStatus fs ls cfg = withStatus' fs ls cfg (Just FeatureTTLUnlimited) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs new file mode 100644 index 00000000000..0a85c632e03 --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedLists #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Generated.LockableFeature_team where + +import Data.ByteString.Conversion (parser, runParser) +import Data.Domain +import Data.Misc +import Imports +import Wire.API.Team.Feature hiding (withStatus) +import Wire.API.Team.Feature qualified as F + +testObject_LockableFeature_team_1 :: LockableFeature AppLockConfig +testObject_LockableFeature_team_1 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock False) (-98)) + +testObject_LockableFeature_team_2 :: LockableFeature AppLockConfig +testObject_LockableFeature_team_2 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock True) 0) + +testObject_LockableFeature_team_3 :: LockableFeature AppLockConfig +testObject_LockableFeature_team_3 = withStatus FeatureStatusEnabled LockStatusLocked (AppLockConfig (EnforceAppLock True) 111) + +testObject_LockableFeature_team_4 :: LockableFeature SelfDeletingMessagesConfig +testObject_LockableFeature_team_4 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig (-97)) + +testObject_LockableFeature_team_5 :: LockableFeature SelfDeletingMessagesConfig +testObject_LockableFeature_team_5 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig 0) + +testObject_LockableFeature_team_6 :: LockableFeature SelfDeletingMessagesConfig +testObject_LockableFeature_team_6 = withStatus FeatureStatusEnabled LockStatusLocked (SelfDeletingMessagesConfig 77) + +testObject_LockableFeature_team_7 :: LockableFeature ClassifiedDomainsConfig +testObject_LockableFeature_team_7 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig []) + +testObject_LockableFeature_team_8 :: LockableFeature ClassifiedDomainsConfig +testObject_LockableFeature_team_8 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) + +testObject_LockableFeature_team_9 :: LockableFeature ClassifiedDomainsConfig +testObject_LockableFeature_team_9 = withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "test.foobar"]) + +testObject_LockableFeature_team_10 :: LockableFeature SSOConfig +testObject_LockableFeature_team_10 = withStatus FeatureStatusDisabled LockStatusLocked SSOConfig + +testObject_LockableFeature_team_11 :: LockableFeature SearchVisibilityAvailableConfig +testObject_LockableFeature_team_11 = withStatus FeatureStatusEnabled LockStatusLocked SearchVisibilityAvailableConfig + +testObject_LockableFeature_team_12 :: LockableFeature ValidateSAMLEmailsConfig +testObject_LockableFeature_team_12 = withStatus FeatureStatusDisabled LockStatusLocked ValidateSAMLEmailsConfig + +testObject_LockableFeature_team_13 :: LockableFeature DigitalSignaturesConfig +testObject_LockableFeature_team_13 = withStatus FeatureStatusEnabled LockStatusLocked DigitalSignaturesConfig + +testObject_LockableFeature_team_14 :: LockableFeature ConferenceCallingConfig +testObject_LockableFeature_team_14 = withStatus FeatureStatusDisabled LockStatusUnlocked (ConferenceCallingConfig One2OneCallsTurn) + +testObject_LockableFeature_team_15 :: LockableFeature GuestLinksConfig +testObject_LockableFeature_team_15 = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig + +testObject_LockableFeature_team_16 :: LockableFeature SndFactorPasswordChallengeConfig +testObject_LockableFeature_team_16 = withStatus FeatureStatusDisabled LockStatusUnlocked SndFactorPasswordChallengeConfig + +testObject_LockableFeature_team_17 :: LockableFeature SearchVisibilityInboundConfig +testObject_LockableFeature_team_17 = withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityInboundConfig + +testObject_LockableFeature_team_18 :: LockableFeature MlsE2EIdConfig +testObject_LockableFeature_team_18 = + withStatus + FeatureStatusEnabled + LockStatusLocked + ( MlsE2EIdConfig + (fromIntegral @Int (60 * 60 * 24)) + Nothing + (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") + False + ) + +parseHttpsUrl :: ByteString -> Either String HttpsUrl +parseHttpsUrl url = runParser parser url + +testObject_LockableFeature_team_19 :: LockableFeature MlsE2EIdConfig +testObject_LockableFeature_team_19 = + withStatus + FeatureStatusEnabled + LockStatusLocked + ( MlsE2EIdConfig + (fromIntegral @Int (60 * 60 * 24)) + (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") + Nothing + True + ) + +withStatus :: FeatureStatus -> LockStatus -> cfg -> LockableFeature cfg +withStatus fs ls cfg = F.withStatus fs ls cfg FeatureTTLUnlimited diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusNoLock_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusNoLock_team.hs deleted file mode 100644 index efc0c52b7d5..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusNoLock_team.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Wire.API.Golden.Generated.WithStatusNoLock_team where - -import Data.Domain -import Imports -import Wire.API.Team.Feature - -testObject_WithStatusNoLock_team_1 :: WithStatusNoLock AppLockConfig -testObject_WithStatusNoLock_team_1 = WithStatusNoLock FeatureStatusEnabled (AppLockConfig (EnforceAppLock False) (-98)) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_2 :: WithStatusNoLock AppLockConfig -testObject_WithStatusNoLock_team_2 = WithStatusNoLock FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 0) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_3 :: WithStatusNoLock AppLockConfig -testObject_WithStatusNoLock_team_3 = WithStatusNoLock FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 111) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_4 :: WithStatusNoLock SelfDeletingMessagesConfig -testObject_WithStatusNoLock_team_4 = WithStatusNoLock FeatureStatusEnabled (SelfDeletingMessagesConfig (-97)) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_5 :: WithStatusNoLock SelfDeletingMessagesConfig -testObject_WithStatusNoLock_team_5 = WithStatusNoLock FeatureStatusEnabled (SelfDeletingMessagesConfig 0) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_6 :: WithStatusNoLock SelfDeletingMessagesConfig -testObject_WithStatusNoLock_team_6 = WithStatusNoLock FeatureStatusEnabled (SelfDeletingMessagesConfig 77) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_7 :: WithStatusNoLock ClassifiedDomainsConfig -testObject_WithStatusNoLock_team_7 = WithStatusNoLock FeatureStatusEnabled (ClassifiedDomainsConfig []) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_8 :: WithStatusNoLock ClassifiedDomainsConfig -testObject_WithStatusNoLock_team_8 = WithStatusNoLock FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_9 :: WithStatusNoLock ClassifiedDomainsConfig -testObject_WithStatusNoLock_team_9 = WithStatusNoLock FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "test.foobar"]) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_10 :: WithStatusNoLock SSOConfig -testObject_WithStatusNoLock_team_10 = WithStatusNoLock FeatureStatusDisabled SSOConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_11 :: WithStatusNoLock SearchVisibilityAvailableConfig -testObject_WithStatusNoLock_team_11 = WithStatusNoLock FeatureStatusEnabled SearchVisibilityAvailableConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_12 :: WithStatusNoLock ValidateSAMLEmailsConfig -testObject_WithStatusNoLock_team_12 = WithStatusNoLock FeatureStatusDisabled ValidateSAMLEmailsConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_13 :: WithStatusNoLock DigitalSignaturesConfig -testObject_WithStatusNoLock_team_13 = WithStatusNoLock FeatureStatusEnabled DigitalSignaturesConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_14 :: WithStatusNoLock ConferenceCallingConfig -testObject_WithStatusNoLock_team_14 = WithStatusNoLock FeatureStatusDisabled (ConferenceCallingConfig One2OneCallsSft) FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_15 :: WithStatusNoLock GuestLinksConfig -testObject_WithStatusNoLock_team_15 = WithStatusNoLock FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_16 :: WithStatusNoLock SndFactorPasswordChallengeConfig -testObject_WithStatusNoLock_team_16 = WithStatusNoLock FeatureStatusDisabled SndFactorPasswordChallengeConfig FeatureTTLUnlimited - -testObject_WithStatusNoLock_team_17 :: WithStatusNoLock SearchVisibilityInboundConfig -testObject_WithStatusNoLock_team_17 = WithStatusNoLock FeatureStatusEnabled SearchVisibilityInboundConfig FeatureTTLUnlimited diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusPatch_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusPatch_team.hs deleted file mode 100644 index a5dd2c94955..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatusPatch_team.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Wire.API.Golden.Generated.WithStatusPatch_team where - -import Data.Domain -import Imports -import Wire.API.Team.Feature hiding (withStatus) - -testObject_WithStatusPatch_team_1 :: WithStatusPatch AppLockConfig -testObject_WithStatusPatch_team_1 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (AppLockConfig (EnforceAppLock False) (-98))) - -testObject_WithStatusPatch_team_2 :: WithStatusPatch AppLockConfig -testObject_WithStatusPatch_team_2 = withStatus Nothing Nothing (Just (AppLockConfig (EnforceAppLock True) 0)) - -testObject_WithStatusPatch_team_3 :: WithStatusPatch AppLockConfig -testObject_WithStatusPatch_team_3 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (AppLockConfig (EnforceAppLock True) 111)) - -testObject_WithStatusPatch_team_4 :: WithStatusPatch SelfDeletingMessagesConfig -testObject_WithStatusPatch_team_4 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig (-97))) - -testObject_WithStatusPatch_team_5 :: WithStatusPatch SelfDeletingMessagesConfig -testObject_WithStatusPatch_team_5 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (SelfDeletingMessagesConfig 0)) - -testObject_WithStatusPatch_team_6 :: WithStatusPatch SelfDeletingMessagesConfig -testObject_WithStatusPatch_team_6 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig 77)) - -testObject_WithStatusPatch_team_7 :: WithStatusPatch ClassifiedDomainsConfig -testObject_WithStatusPatch_team_7 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [])) - -testObject_WithStatusPatch_team_8 :: WithStatusPatch ClassifiedDomainsConfig -testObject_WithStatusPatch_team_8 = withStatus Nothing (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"])) - -testObject_WithStatusPatch_team_9 :: WithStatusPatch ClassifiedDomainsConfig -testObject_WithStatusPatch_team_9 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (ClassifiedDomainsConfig [Domain "test.foobar"])) - -testObject_WithStatusPatch_team_10 :: WithStatusPatch SSOConfig -testObject_WithStatusPatch_team_10 = withStatus (Just FeatureStatusDisabled) (Just LockStatusLocked) (Just SSOConfig) - -testObject_WithStatusPatch_team_11 :: WithStatusPatch SearchVisibilityAvailableConfig -testObject_WithStatusPatch_team_11 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just SearchVisibilityAvailableConfig) - -testObject_WithStatusPatch_team_12 :: WithStatusPatch ValidateSAMLEmailsConfig -testObject_WithStatusPatch_team_12 = withStatus (Just FeatureStatusDisabled) Nothing (Just ValidateSAMLEmailsConfig) - -testObject_WithStatusPatch_team_13 :: WithStatusPatch DigitalSignaturesConfig -testObject_WithStatusPatch_team_13 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just DigitalSignaturesConfig) - -testObject_WithStatusPatch_team_14 :: WithStatusPatch ConferenceCallingConfig -testObject_WithStatusPatch_team_14 = withStatus Nothing (Just LockStatusUnlocked) (Just (ConferenceCallingConfig One2OneCallsSft)) - -testObject_WithStatusPatch_team_15 :: WithStatusPatch GuestLinksConfig -testObject_WithStatusPatch_team_15 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just GuestLinksConfig) - -testObject_WithStatusPatch_team_16 :: WithStatusPatch SndFactorPasswordChallengeConfig -testObject_WithStatusPatch_team_16 = withStatus (Just FeatureStatusDisabled) (Just LockStatusUnlocked) (Just SndFactorPasswordChallengeConfig) - -testObject_WithStatusPatch_team_17 :: WithStatusPatch SearchVisibilityInboundConfig -testObject_WithStatusPatch_team_17 = withStatus (Just FeatureStatusEnabled) Nothing (Just SearchVisibilityInboundConfig) - -testObject_WithStatusPatch_team_18 :: WithStatusPatch GuestLinksConfig -testObject_WithStatusPatch_team_18 = withStatus (Just FeatureStatusEnabled) Nothing Nothing - -testObject_WithStatusPatch_team_19 :: WithStatusPatch SelfDeletingMessagesConfig -testObject_WithStatusPatch_team_19 = withStatus Nothing (Just LockStatusUnlocked) Nothing - -withStatus :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> WithStatusPatch cfg -withStatus fs ls cfg = withStatus' fs ls cfg (Just FeatureTTLUnlimited) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs deleted file mode 100644 index 6acd1c8f634..00000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/WithStatus_team.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Wire.API.Golden.Generated.WithStatus_team where - -import Data.ByteString.Conversion (parser, runParser) -import Data.Domain -import Data.Misc -import Imports -import Wire.API.Team.Feature hiding (withStatus) -import Wire.API.Team.Feature qualified as F - -testObject_WithStatus_team_1 :: WithStatus AppLockConfig -testObject_WithStatus_team_1 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock False) (-98)) - -testObject_WithStatus_team_2 :: WithStatus AppLockConfig -testObject_WithStatus_team_2 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock True) 0) - -testObject_WithStatus_team_3 :: WithStatus AppLockConfig -testObject_WithStatus_team_3 = withStatus FeatureStatusEnabled LockStatusLocked (AppLockConfig (EnforceAppLock True) 111) - -testObject_WithStatus_team_4 :: WithStatus SelfDeletingMessagesConfig -testObject_WithStatus_team_4 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig (-97)) - -testObject_WithStatus_team_5 :: WithStatus SelfDeletingMessagesConfig -testObject_WithStatus_team_5 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig 0) - -testObject_WithStatus_team_6 :: WithStatus SelfDeletingMessagesConfig -testObject_WithStatus_team_6 = withStatus FeatureStatusEnabled LockStatusLocked (SelfDeletingMessagesConfig 77) - -testObject_WithStatus_team_7 :: WithStatus ClassifiedDomainsConfig -testObject_WithStatus_team_7 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig []) - -testObject_WithStatus_team_8 :: WithStatus ClassifiedDomainsConfig -testObject_WithStatus_team_8 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) - -testObject_WithStatus_team_9 :: WithStatus ClassifiedDomainsConfig -testObject_WithStatus_team_9 = withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "test.foobar"]) - -testObject_WithStatus_team_10 :: WithStatus SSOConfig -testObject_WithStatus_team_10 = withStatus FeatureStatusDisabled LockStatusLocked SSOConfig - -testObject_WithStatus_team_11 :: WithStatus SearchVisibilityAvailableConfig -testObject_WithStatus_team_11 = withStatus FeatureStatusEnabled LockStatusLocked SearchVisibilityAvailableConfig - -testObject_WithStatus_team_12 :: WithStatus ValidateSAMLEmailsConfig -testObject_WithStatus_team_12 = withStatus FeatureStatusDisabled LockStatusLocked ValidateSAMLEmailsConfig - -testObject_WithStatus_team_13 :: WithStatus DigitalSignaturesConfig -testObject_WithStatus_team_13 = withStatus FeatureStatusEnabled LockStatusLocked DigitalSignaturesConfig - -testObject_WithStatus_team_14 :: WithStatus ConferenceCallingConfig -testObject_WithStatus_team_14 = withStatus FeatureStatusDisabled LockStatusUnlocked (ConferenceCallingConfig One2OneCallsTurn) - -testObject_WithStatus_team_15 :: WithStatus GuestLinksConfig -testObject_WithStatus_team_15 = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig - -testObject_WithStatus_team_16 :: WithStatus SndFactorPasswordChallengeConfig -testObject_WithStatus_team_16 = withStatus FeatureStatusDisabled LockStatusUnlocked SndFactorPasswordChallengeConfig - -testObject_WithStatus_team_17 :: WithStatus SearchVisibilityInboundConfig -testObject_WithStatus_team_17 = withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityInboundConfig - -testObject_WithStatus_team_18 :: WithStatus MlsE2EIdConfig -testObject_WithStatus_team_18 = - withStatus - FeatureStatusEnabled - LockStatusLocked - ( MlsE2EIdConfig - (fromIntegral @Int (60 * 60 * 24)) - Nothing - (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") - False - ) - -parseHttpsUrl :: ByteString -> Either String HttpsUrl -parseHttpsUrl url = runParser parser url - -testObject_WithStatus_team_19 :: WithStatus MlsE2EIdConfig -testObject_WithStatus_team_19 = - withStatus - FeatureStatusEnabled - LockStatusLocked - ( MlsE2EIdConfig - (fromIntegral @Int (60 * 60 * 24)) - (either (\e -> error (show e)) Just $ parseHttpsUrl "https://example.com") - Nothing - True - ) - -withStatus :: FeatureStatus -> LockStatus -> cfg -> WithStatus cfg -withStatus fs ls cfg = F.withStatus fs ls cfg FeatureTTLUnlimited diff --git a/libs/wire-api/test/golden/fromJSON/testObject_WithStatus_team_14.json b/libs/wire-api/test/golden/fromJSON/testObject_LockableFeature_team_14.json similarity index 100% rename from libs/wire-api/test/golden/fromJSON/testObject_WithStatus_team_14.json rename to libs/wire-api/test/golden/fromJSON/testObject_LockableFeature_team_14.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_1.json b/libs/wire-api/test/golden/testObject_Feature_team_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_1.json rename to libs/wire-api/test/golden/testObject_Feature_team_1.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_10.json b/libs/wire-api/test/golden/testObject_Feature_team_10.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_10.json rename to libs/wire-api/test/golden/testObject_Feature_team_10.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_11.json b/libs/wire-api/test/golden/testObject_Feature_team_11.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_11.json rename to libs/wire-api/test/golden/testObject_Feature_team_11.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_12.json b/libs/wire-api/test/golden/testObject_Feature_team_12.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_12.json rename to libs/wire-api/test/golden/testObject_Feature_team_12.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_13.json b/libs/wire-api/test/golden/testObject_Feature_team_13.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_13.json rename to libs/wire-api/test/golden/testObject_Feature_team_13.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_14.json b/libs/wire-api/test/golden/testObject_Feature_team_14.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_14.json rename to libs/wire-api/test/golden/testObject_Feature_team_14.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_15.json b/libs/wire-api/test/golden/testObject_Feature_team_15.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_15.json rename to libs/wire-api/test/golden/testObject_Feature_team_15.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_16.json b/libs/wire-api/test/golden/testObject_Feature_team_16.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_16.json rename to libs/wire-api/test/golden/testObject_Feature_team_16.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_17.json b/libs/wire-api/test/golden/testObject_Feature_team_17.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_17.json rename to libs/wire-api/test/golden/testObject_Feature_team_17.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_2.json b/libs/wire-api/test/golden/testObject_Feature_team_2.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_2.json rename to libs/wire-api/test/golden/testObject_Feature_team_2.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_3.json b/libs/wire-api/test/golden/testObject_Feature_team_3.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_3.json rename to libs/wire-api/test/golden/testObject_Feature_team_3.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_4.json b/libs/wire-api/test/golden/testObject_Feature_team_4.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_4.json rename to libs/wire-api/test/golden/testObject_Feature_team_4.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_5.json b/libs/wire-api/test/golden/testObject_Feature_team_5.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_5.json rename to libs/wire-api/test/golden/testObject_Feature_team_5.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_6.json b/libs/wire-api/test/golden/testObject_Feature_team_6.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_6.json rename to libs/wire-api/test/golden/testObject_Feature_team_6.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_7.json b/libs/wire-api/test/golden/testObject_Feature_team_7.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_7.json rename to libs/wire-api/test/golden/testObject_Feature_team_7.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_8.json b/libs/wire-api/test/golden/testObject_Feature_team_8.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_8.json rename to libs/wire-api/test/golden/testObject_Feature_team_8.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusNoLock_team_9.json b/libs/wire-api/test/golden/testObject_Feature_team_9.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusNoLock_team_9.json rename to libs/wire-api/test/golden/testObject_Feature_team_9.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_1.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_1.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_1.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_10.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_10.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_10.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_10.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_11.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_11.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_11.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_11.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_12.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_12.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_12.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_12.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_13.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_13.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_13.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_13.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_14.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_14.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_14.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_14.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_15.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_15.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_15.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_15.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_16.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_16.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_16.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_16.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_17.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_17.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_17.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_17.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_18.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_18.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_18.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_18.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_19.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_19.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_19.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_19.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_2.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_2.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_2.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_2.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_3.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_3.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_3.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_3.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_4.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_4.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_4.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_4.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_5.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_5.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_5.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_5.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_6.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_6.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_6.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_6.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_7.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_7.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_7.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_7.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_8.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_8.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_8.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_8.json diff --git a/libs/wire-api/test/golden/testObject_WithStatusPatch_team_9.json b/libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_9.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatusPatch_team_9.json rename to libs/wire-api/test/golden/testObject_LockableFeaturePatch_team_9.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_1.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_1.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_1.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_1.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_10.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_10.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_10.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_10.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_11.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_11.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_11.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_11.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_12.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_12.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_12.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_12.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_13.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_13.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_13.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_13.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_14.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_14.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_14.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_14.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_15.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_15.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_15.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_15.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_16.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_16.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_16.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_16.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_17.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_17.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_17.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_17.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_18.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_18.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_18.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_18.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_19.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_19.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_19.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_19.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_2.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_2.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_2.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_2.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_3.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_3.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_3.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_3.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_4.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_4.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_4.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_4.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_5.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_5.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_5.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_5.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_6.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_6.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_6.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_6.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_7.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_7.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_7.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_7.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_8.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_8.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_8.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_8.json diff --git a/libs/wire-api/test/golden/testObject_WithStatus_team_9.json b/libs/wire-api/test/golden/testObject_LockableFeature_team_9.json similarity index 100% rename from libs/wire-api/test/golden/testObject_WithStatus_team_9.json rename to libs/wire-api/test/golden/testObject_LockableFeature_team_9.json diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index bec9d3c96f1..a4d3b841fa5 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -214,10 +214,10 @@ tests = testRoundTrip @Team.TeamDeleteData, testRoundTrip @Team.Conversation.TeamConversation, testRoundTrip @Team.Conversation.TeamConversationList, - testRoundTrip @(Team.Feature.WithStatus Team.Feature.LegalholdConfig), - testRoundTrip @(Team.Feature.WithStatusPatch Team.Feature.LegalholdConfig), - testRoundTrip @(Team.Feature.WithStatusPatch Team.Feature.SelfDeletingMessagesConfig), - testRoundTrip @(Team.Feature.WithStatusNoLock Team.Feature.LegalholdConfig), + testRoundTrip @(Team.Feature.LockableFeature Team.Feature.LegalholdConfig), + testRoundTrip @(Team.Feature.LockableFeaturePatch Team.Feature.LegalholdConfig), + testRoundTrip @(Team.Feature.LockableFeaturePatch Team.Feature.SelfDeletingMessagesConfig), + testRoundTrip @(Team.Feature.Feature Team.Feature.LegalholdConfig), testRoundTrip @Team.Feature.AllFeatureConfigs, testRoundTrip @Team.Feature.FeatureStatus, testRoundTrip @Team.Feature.LockStatus, diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 5f1a6b8bdc0..6ca7fec5377 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -420,6 +420,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.Event_user Test.Wire.API.Golden.Generated.EventType_team Test.Wire.API.Golden.Generated.EventType_user + Test.Wire.API.Golden.Generated.Feature_team Test.Wire.API.Golden.Generated.HandleUpdate_user Test.Wire.API.Golden.Generated.Invitation_team Test.Wire.API.Golden.Generated.InvitationCode_user @@ -433,6 +434,8 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.ListType_team Test.Wire.API.Golden.Generated.Locale_user Test.Wire.API.Golden.Generated.LocaleUpdate_user + Test.Wire.API.Golden.Generated.LockableFeature_team + Test.Wire.API.Golden.Generated.LockableFeaturePatch_team Test.Wire.API.Golden.Generated.LoginCode_user Test.Wire.API.Golden.Generated.LoginCodeTimeout_user Test.Wire.API.Golden.Generated.ManagedBy_user @@ -562,9 +565,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.VerifyDeleteUser_user Test.Wire.API.Golden.Generated.ViewLegalHoldService_team Test.Wire.API.Golden.Generated.ViewLegalHoldServiceInfo_team - Test.Wire.API.Golden.Generated.WithStatus_team - Test.Wire.API.Golden.Generated.WithStatusNoLock_team - Test.Wire.API.Golden.Generated.WithStatusPatch_team Test.Wire.API.Golden.Generated.Wrapped_20_22some_5fint_22_20Int_user Test.Wire.API.Golden.Manual Test.Wire.API.Golden.Manual.Activate_user diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index b039bff1303..3ef3d01a3bb 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -92,7 +92,7 @@ data GalleyAPIAccess m a where GalleyAPIAccess m Team.TeamName GetTeamLegalHoldStatus :: TeamId -> - GalleyAPIAccess m (WithStatus LegalholdConfig) + GalleyAPIAccess m (LockableFeature LegalholdConfig) GetTeamSearchVisibility :: TeamId -> GalleyAPIAccess m TeamSearchVisibility diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index e05584e9a36..eed8eb169c1 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -403,7 +403,7 @@ getTeamLegalHoldStatus :: Member TinyLog r ) => TeamId -> - Sem r (WithStatus LegalholdConfig) + Sem r (LockableFeature LegalholdConfig) getTeamLegalHoldStatus tid = do debug $ remote "galley" . msg (val "Get legalhold settings") galleyRequest req >>= decodeBodyOrThrow "galley" @@ -443,7 +443,7 @@ getVerificationCodeEnabled :: getVerificationCodeEnabled tid = do debug $ remote "galley" . msg (val "Get snd factor password challenge settings") response <- galleyRequest req - status <- wsStatus <$> decodeBodyOrThrow @(WithStatus SndFactorPasswordChallengeConfig) "galley" response + status <- wsStatus <$> decodeBodyOrThrow @(LockableFeature SndFactorPasswordChallengeConfig) "galley" response case status of FeatureStatusEnabled -> pure True FeatureStatusDisabled -> pure False @@ -500,7 +500,7 @@ getTeamExposeInvitationURLsToTeamAdmin :: getTeamExposeInvitationURLsToTeamAdmin tid = do debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") response <- galleyRequest req - status <- wsStatus <$> decodeBodyOrThrow @(WithStatus ExposeInvitationURLsToTeamAdminConfig) "galley" response + status <- wsStatus <$> decodeBodyOrThrow @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) "galley" response case status of FeatureStatusEnabled -> pure ShowInvitationUrl FeatureStatusDisabled -> pure HideInvitationUrl diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 85d5342bc0b..ab43f085d49 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -350,12 +350,12 @@ updateFederationRemote dom fedcfg = do \do that, removing or updating items listed in the config file is not allowed." -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. -getAccountConferenceCallingConfig :: UserId -> (Handler r) (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig) +getAccountConferenceCallingConfig :: UserId -> (Handler r) (ApiFt.Feature ApiFt.ConferenceCallingConfig) getAccountConferenceCallingConfig uid = lift (wrapClient $ Data.lookupFeatureConferenceCalling uid) >>= maybe (ApiFt.forgetLock <$> view (settings . getAfcConferenceCallingDefNull)) pure -putAccountConferenceCallingConfig :: UserId -> ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig -> (Handler r) NoContent +putAccountConferenceCallingConfig :: UserId -> ApiFt.Feature ApiFt.ConferenceCallingConfig -> (Handler r) NoContent putAccountConferenceCallingConfig uid status = lift $ wrapClient $ Data.updateFeatureConferenceCalling uid (Just status) $> NoContent diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 147fd666c7a..df384839c08 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -299,7 +299,7 @@ updateManagedBy u h = retry x5 $ write userManagedByUpdate (params LocalQuorum ( updateRichInfo :: (MonadClient m) => UserId -> RichInfoAssocList -> m () updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (ri, u)) -updateFeatureConferenceCalling :: (MonadClient m) => UserId -> Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig) -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) +updateFeatureConferenceCalling :: (MonadClient m) => UserId -> Maybe (ApiFt.Feature ApiFt.ConferenceCallingConfig) -> m (Maybe (ApiFt.Feature ApiFt.ConferenceCallingConfig)) updateFeatureConferenceCalling uid mbStatus = do let flag = ApiFt.wssStatus <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) @@ -436,7 +436,7 @@ lookupServiceUsersForTeam pid sid tid = "SELECT user, conv FROM service_team \ \WHERE provider = ? AND service = ? AND team = ?" -lookupFeatureConferenceCalling :: (MonadClient m) => UserId -> m (Maybe (ApiFt.WithStatusNoLock ApiFt.ConferenceCallingConfig)) +lookupFeatureConferenceCalling :: (MonadClient m) => UserId -> m (Maybe (ApiFt.Feature ApiFt.ConferenceCallingConfig)) lookupFeatureConferenceCalling uid = do let q = query1 select (params LocalQuorum (Identity uid)) mStatusValue <- (>>= runIdentity) <$> retry x1 q diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 36ddf319be2..89f880de956 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -740,10 +740,10 @@ instance ToJSON AccountFeatureConfigs where ] ] -getAfcConferenceCallingDefNewMaybe :: Lens.Getter Settings (Maybe (Public.WithStatus Public.ConferenceCallingConfig)) +getAfcConferenceCallingDefNewMaybe :: Lens.Getter Settings (Maybe (Public.LockableFeature Public.ConferenceCallingConfig)) getAfcConferenceCallingDefNewMaybe = Lens.to (Lens.^? (Lens.to setFeatureFlags . Lens._Just . Lens.to afcConferenceCallingDefNew . unImplicitLockStatus)) -getAfcConferenceCallingDefNull :: Lens.Getter Settings (Public.WithStatus Public.ConferenceCallingConfig) +getAfcConferenceCallingDefNull :: Lens.Getter Settings (Public.LockableFeature Public.ConferenceCallingConfig) getAfcConferenceCallingDefNull = Lens.to (Public._unImplicitLockStatus . afcConferenceCallingDefNull . fromMaybe defAccountFeatureConfigs . setFeatureFlags) defAccountFeatureConfigs :: AccountFeatureConfigs diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 0d2aad8a5db..cde489da5b8 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1580,7 +1580,7 @@ enabled2ndFaForTeamInternal galley tid = do ( galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson - . Bilge.json (Public.WithStatusNoLock Public.FeatureStatusEnabled Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited) + . Bilge.json (Public.Feature Public.FeatureStatusEnabled Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited) ) !!! const 200 === statusCode diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 331309043cf..202aa228f1e 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -266,7 +266,7 @@ putLegalHoldEnabled tid enabled g = do g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] . contentJson - . lbytes (encode (Public.WithStatusNoLock enabled Public.LegalholdConfig Public.FeatureTTLUnlimited)) + . lbytes (encode (Public.Feature enabled Public.LegalholdConfig Public.FeatureTTLUnlimited)) . expect2xx putLHWhitelistTeam :: (HasCallStack) => Galley -> TeamId -> Http ResponseLBS @@ -436,7 +436,7 @@ setTeamTeamSearchVisibilityAvailable galley tid status = ( galley . paths ["i/teams", toByteString' tid, "features/searchVisibility"] . contentJson - . body (RequestBodyLBS . encode $ Public.WithStatusNoLock status Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) + . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) ) !!! do const 200 === statusCode @@ -458,7 +458,7 @@ setTeamSearchVisibilityInboundAvailable galley tid status = ( galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SearchVisibilityInboundConfig] . contentJson - . body (RequestBodyLBS . encode $ Public.WithStatusNoLock status Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) + . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) ) !!! do const 200 === statusCode diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index 8627d78c989..b52f8ae8659 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -441,7 +441,7 @@ generateVerificationCode' brig req = do setTeamSndFactorPasswordChallenge :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Galley -> TeamId -> Public.FeatureStatus -> m () setTeamSndFactorPasswordChallenge galley tid status = do - let js = RequestBodyLBS $ encode $ Public.WithStatusNoLock status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode setTeamFeatureLockStatus :: diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 92a176a4dea..ce683c960ee 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -72,7 +72,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P -import Servant hiding (JSON, WithStatus) +import Servant hiding (JSON) import System.Logger.Class hiding (Path, name) import System.Logger.Class qualified as Log import Wire.API.Conversation hiding (Member) diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/services/galley/src/Galley/API/MLS/Migration.hs index 747de458cd4..f34e3c65235 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/services/galley/src/Galley/API/MLS/Migration.hs @@ -52,7 +52,7 @@ checkMigrationCriteria :: ) => UTCTime -> MLSConversation -> - WithStatus MlsMigrationConfig -> + LockableFeature MlsMigrationConfig -> Sem r Bool checkMigrationCriteria now conv ws | wsStatus ws == FeatureStatusDisabled = pure False diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 29073e71bbc..6d326ab2096 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -667,7 +667,7 @@ getConversationGuestLinksStatus :: ) => UserId -> ConvId -> - Sem r (WithStatus GuestLinksConfig) + Sem r (LockableFeature GuestLinksConfig) getConversationGuestLinksStatus uid convId = do conv <- E.getConversation convId >>= noteS @'ConvNotFound ensureConvAdmin (Data.convLocalMembers conv) uid @@ -679,7 +679,7 @@ getConversationGuestLinksFeatureStatus :: Member (Input Opts) r ) => Maybe TeamId -> - Sem r (WithStatus GuestLinksConfig) + Sem r (LockableFeature GuestLinksConfig) getConversationGuestLinksFeatureStatus Nothing = getConfigForServer @GuestLinksConfig getConversationGuestLinksFeatureStatus (Just tid) = getConfigForTeam @GuestLinksConfig tid diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 7fb0e456069..1e420dd8315 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -90,8 +90,8 @@ patchFeatureStatusInternal :: Member NotificationSubsystem r ) => TeamId -> - WithStatusPatch cfg -> - Sem r (WithStatus cfg) + LockableFeaturePatch cfg -> + Sem r (LockableFeature cfg) patchFeatureStatusInternal tid patch = do assertTeamExists tid currentFeatureStatus <- getFeatureStatus @cfg DontDoAuth tid @@ -101,7 +101,7 @@ patchFeatureStatusInternal tid patch = do when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @cfg tid (wsLockStatus newFeatureStatus) getFeatureStatus @cfg DontDoAuth tid where - applyPatch :: WithStatus cfg -> WithStatus cfg + applyPatch :: LockableFeature cfg -> LockableFeature cfg applyPatch current = current & setStatus (fromMaybe (wsStatus current) (wspStatus patch)) @@ -126,8 +126,8 @@ setFeatureStatus :: ) => DoAuth -> TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) + Feature cfg -> + Sem r (LockableFeature cfg) setFeatureStatus doauth tid wsnl = do case doauth of DoAuth uid -> do @@ -154,8 +154,8 @@ setFeatureStatusInternal :: Member NotificationSubsystem r ) => TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) + Feature cfg -> + Sem r (LockableFeature cfg) setFeatureStatusInternal = setFeatureStatus @cfg DontDoAuth updateLockStatus :: @@ -186,8 +186,8 @@ persistAndPushEvent :: Member TeamStore r ) => TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) + Feature cfg -> + Sem r (LockableFeature cfg) persistAndPushEvent tid wsnl = do setFeatureConfig (featureSingleton @cfg) tid wsnl fs <- getConfigForTeam @cfg tid @@ -247,8 +247,8 @@ class (GetFeatureConfig cfg) => SetFeatureConfig cfg where Member TeamStore r ) => TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) + Feature cfg -> + Sem r (LockableFeature cfg) default setConfigForTeam :: ( ComputeFeatureConstraints cfg r, KnownSymbol (FeatureSymbol cfg), @@ -260,8 +260,8 @@ class (GetFeatureConfig cfg) => SetFeatureConfig cfg where Member TeamStore r ) => TeamId -> - WithStatusNoLock cfg -> - Sem r (WithStatus cfg) + Feature cfg -> + Sem r (LockableFeature cfg) setConfigForTeam tid wsnl = persistAndPushEvent tid wsnl instance SetFeatureConfig SSOConfig where @@ -399,10 +399,10 @@ instance SetFeatureConfig MlsE2EIdConfig guardMlsE2EIdConfig :: forall r a. (Member (Error TeamFeatureError) r) => - (UserId -> TeamId -> WithStatusNoLock MlsE2EIdConfig -> Sem r a) -> + (UserId -> TeamId -> Feature MlsE2EIdConfig -> Sem r a) -> UserId -> TeamId -> - WithStatusNoLock MlsE2EIdConfig -> + Feature MlsE2EIdConfig -> Sem r a guardMlsE2EIdConfig handler uid tid conf = do when (isNothing . crlProxy . wssConfig $ conf) $ throw MLSE2EIDMissingCrlProxy diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index a83d1bad4f7..eec04766394 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -79,36 +79,36 @@ class (IsFeatureConfig cfg) => GetFeatureConfig cfg where getConfigForServer :: (Member (Input Opts) r) => - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) -- only override if there is additional business logic for getting the feature config -- and/or if the feature flag is configured for the backend in 'FeatureFlags' for galley in 'Galley.Types.Teams' -- otherwise this will return the default config from wire-api - default getConfigForServer :: Sem r (WithStatus cfg) + default getConfigForServer :: Sem r (LockableFeature cfg) getConfigForServer = pure defFeatureStatus getConfigForUser :: (GetConfigForUserConstraints cfg r) => UserId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) default getConfigForUser :: (DefaultGetConfigForUserConstraints cfg r) => UserId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) getConfigForUser _ = getConfigForServer computeFeature :: (ComputeFeatureConstraints cfg r) => TeamId -> - WithStatus cfg -> + LockableFeature cfg -> Maybe LockStatus -> DbFeature cfg -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) default computeFeature :: TeamId -> - WithStatus cfg -> + LockableFeature cfg -> Maybe LockStatus -> DbFeature cfg -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) computeFeature _tid defFeature lockStatus dbFeature = pure $ genericComputeFeature @cfg defFeature lockStatus dbFeature @@ -125,7 +125,7 @@ getFeatureStatus :: ) => DoAuth -> TeamId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) getFeatureStatus doauth tid = do case doauth of DoAuth uid -> @@ -148,7 +148,7 @@ getFeatureStatusMulti (Multi.TeamFeatureNoConfigMultiRequest tids) = do let xs = uncurry toTeamStatus . second forgetLock <$> cfgs pure $ Multi.TeamFeatureNoConfigMultiResponse xs -toTeamStatus :: TeamId -> WithStatusNoLock cfg -> Multi.TeamStatus cfg +toTeamStatus :: TeamId -> Feature cfg -> Multi.TeamStatus cfg toTeamStatus tid ws = Multi.TeamStatus tid (wssStatus ws) getTeamAndCheckMembership :: @@ -198,9 +198,9 @@ computeFeatureWithLock :: forall cfg r. (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => TeamId -> - WithStatus cfg -> + LockableFeature cfg -> DbFeatureWithLock cfg -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) computeFeatureWithLock tid defFeature feat = computeFeature @cfg tid defFeature feat.lockStatus feat.feature @@ -316,7 +316,7 @@ getSingleFeatureConfigForUser :: ComputeFeatureConstraints cfg r ) => UserId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) getSingleFeatureConfigForUser uid = do mTid <- getTeamAndCheckMembership uid getConfigForTeamUser @cfg uid mTid @@ -329,7 +329,7 @@ getConfigForTeam :: Member TeamFeatureStore r ) => TeamId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) getConfigForTeam tid = do dbFeature <- TeamFeatures.getFeatureConfig (featureSingleton @cfg) tid lockStatus <- TeamFeatures.getFeatureLockStatus (featureSingleton @cfg) tid @@ -349,7 +349,7 @@ getConfigForMultiTeam :: Member (Input Opts) r ) => [TeamId] -> - Sem r [(TeamId, WithStatus cfg)] + Sem r [(TeamId, LockableFeature cfg)] getConfigForMultiTeam tids = do defFeature <- getConfigForServer features <- TeamFeatures.getFeatureConfigMulti (featureSingleton @cfg) tids @@ -367,7 +367,7 @@ getConfigForTeamUser :: ) => UserId -> Maybe TeamId -> - Sem r (WithStatus cfg) + Sem r (LockableFeature cfg) getConfigForTeamUser uid Nothing = getConfigForUser uid getConfigForTeamUser _ (Just tid) = getConfigForTeam @cfg tid diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index a751060e668..d46c1db12a0 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -118,7 +118,7 @@ getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid = getFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid = getFeature "limited_event_fanout_status" tid -setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> WithStatusNoLock cfg -> m () +setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () setFeatureConfig FeatureSingletonLegalholdConfig tid statusNoLock = setFeatureStatusC "legalhold_status" tid (wssStatus statusNoLock) setFeatureConfig FeatureSingletonSSOConfig tid statusNoLock = setFeatureStatusC "sso_status" tid (wssStatus statusNoLock) setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index c825a3e7129..2e14a25c104 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -122,7 +122,7 @@ data BrigAccess m a where LastPrekey -> BrigAccess m (Either AuthenticationError ClientId) RemoveLegalHoldClientFromUser :: UserId -> BrigAccess m () - GetAccountConferenceCallingConfigClient :: UserId -> BrigAccess m (WithStatusNoLock ConferenceCallingConfig) + GetAccountConferenceCallingConfigClient :: UserId -> BrigAccess m (Feature ConferenceCallingConfig) GetLocalMLSClients :: Local UserId -> CipherSuiteTag -> BrigAccess m (Set ClientInfo) UpdateSearchVisibilityInbound :: Multi.TeamStatus SearchVisibilityInboundConfig -> diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index 0d24a1821af..18ac6648a70 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -37,7 +37,7 @@ data TeamFeatureStore m a where SetFeatureConfig :: FeatureSingleton cfg -> TeamId -> - WithStatusNoLock cfg -> + Feature cfg -> TeamFeatureStore m () GetFeatureLockStatus :: FeatureSingleton cfg -> diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 5419b68ecea..6e6ef60859e 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -238,7 +238,7 @@ getRichInfoMultiUser = chunkify $ \uids -> do . expect2xx parseResponse (mkError status502 "server-error: could not parse response to `GET brig:/i/users/rich-info`") resp -getAccountConferenceCallingConfigClient :: (HasCallStack) => UserId -> App (WithStatusNoLock ConferenceCallingConfig) +getAccountConferenceCallingConfigClient :: (HasCallStack) => UserId -> App (Feature ConferenceCallingConfig) getAccountConferenceCallingConfigClient uid = runHereClientM (namedClient @IAPI.API @"get-account-conference-calling-config" uid) >>= handleServantResp diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f05541d3a76..92b7d20f34d 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1176,7 +1176,7 @@ testGetCodeRejectedIfGuestLinksDisabled = do convId <- createConvWithGuestLink let checkGetCode expectedStatus = getConvCode owner convId !!! const expectedStatus === statusCode let setStatus tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode checkGetCode 200 @@ -1192,7 +1192,7 @@ testPostCodeRejectedIfGuestLinksDisabled = do convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just noGuestsAccess) Nothing let checkPostCode expectedStatus = postConvCode owner convId !!! statusCode === const expectedStatus let setStatus tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode checkPostCode 201 @@ -1229,7 +1229,7 @@ testJoinTeamConvGuestLinksDisabled = do postJoinCodeConv bob cCode !!! const 200 === statusCode -- disabled guest links feature - let disabled = Public.WithStatusNoLock Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited + let disabled = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId disabled !!! do const 200 === statusCode @@ -1248,7 +1248,7 @@ testJoinTeamConvGuestLinksDisabled = do checkFeatureStatus Public.FeatureStatusDisabled -- after re-enabling, the old link is still valid - let enabled = Public.WithStatusNoLock Public.FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited + let enabled = Public.Feature Public.FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId enabled !!! do const 200 === statusCode getJoinCodeConv eve' (conversationKey cCode) (conversationCode cCode) !!! do @@ -1276,7 +1276,7 @@ testJoinNonTeamConvGuestLinksDisabled = do const 200 === statusCode -- 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 + let tfStatus = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId tfStatus !!! do const 200 === statusCode @@ -1516,12 +1516,12 @@ getGuestLinksStatusFromForeignTeamConv = do localDomain <- viewFederationDomain galley <- viewGalley let setTeamStatus u tid tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig u tid (Public.WithStatusNoLock tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig u tid (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do const 200 === statusCode let checkGuestLinksStatus u c s = getGuestLinkStatus galley u c !!! do const 200 === statusCode - const s === (Public.wsStatus . (responseJsonUnsafe @(Public.WithStatus Public.GuestLinksConfig))) + const s === (Public.wsStatus . (responseJsonUnsafe @(Public.LockableFeature Public.GuestLinksConfig))) let checkGetGuestLinksStatus s u c = getGuestLinkStatus galley u c !!! do const s === statusCode diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 8aca27809c2..70971405395 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -398,7 +398,7 @@ testEnableSSOPerTeam = do assertTeamActivate "create team" tid let check :: (HasCallStack) => String -> Public.FeatureStatus -> TestM () check msg enabledness = do - status :: Public.WithStatusNoLock Public.SSOConfig <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () @@ -409,7 +409,7 @@ testEnableSSOPerTeam = do <$> put ( g . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (Public.WithStatusNoLock Public.FeatureStatusDisabled Public.SSOConfig Public.FeatureTTLUnlimited) + . json (Public.Feature Public.FeatureStatusDisabled Public.SSOConfig Public.FeatureTTLUnlimited) ) liftIO $ do assertEqual "bad status" status403 (Wai.code waierr) @@ -427,7 +427,7 @@ testEnableTeamSearchVisibilityPerTeam = do (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: String -> Public.FeatureStatus -> TestM () check msg enabledness = do - status :: Public.WithStatusNoLock Public.SearchVisibilityAvailableConfig <- responseJsonUnsafe <$> (Util.getTeamFeatureInternal @Public.SearchVisibilityAvailableConfig tid (Util.getTeamFeatureInternal @Public.SearchVisibilityAvailableConfig tid Public.FeatureStatus -> TestM () setTeamSndFactorPasswordChallenge tid status = do g <- viewGalley - let js = RequestBodyLBS $ encode $ Public.WithStatusNoLock status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited put (g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode getVerificationCode :: UserId -> Public.VerificationAction -> TestM Code.Value @@ -1745,7 +1745,7 @@ getSSOEnabledInternal = Util.getTeamFeatureInternal @Public.SSOConfig putSSOEnabledInternal :: (HasCallStack) => TeamId -> Public.FeatureStatus -> TestM () putSSOEnabledInternal tid statusValue = - void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.WithStatusNoLock statusValue Public.SSOConfig Public.FeatureTTLUnlimited) + void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.Feature 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/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 0ed8319d99e..ec8fe35daa9 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -502,12 +502,12 @@ testEnablePerTeam = do member <- randomUser addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing do - status :: Public.WithStatusNoLock Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do @@ -519,7 +519,7 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.FeatureStatusDisabled -- disable again - status :: Public.WithStatusNoLock Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 630f030e3f2..9d23db90c19 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -50,7 +50,7 @@ putTeamSearchVisibilityAvailableInternal tid statusValue = @Public.SearchVisibilityAvailableConfig expect2xx tid - (Public.WithStatusNoLock statusValue Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) + (Public.Feature statusValue Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) putTeamFeatureInternal :: forall cfg m. @@ -59,11 +59,11 @@ putTeamFeatureInternal :: MonadHttp m, HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), - ToJSON (Public.WithStatusNoLock cfg) + ToJSON (Public.Feature cfg) ) => (Request -> Request) -> TeamId -> - Public.WithStatusNoLock cfg -> + Public.Feature cfg -> m ResponseLBS putTeamFeatureInternal reqmod tid status = do galley <- viewGalley @@ -77,11 +77,11 @@ putTeamFeature :: forall cfg. ( HasCallStack, KnownSymbol (Public.FeatureSymbol cfg), - ToJSON (Public.WithStatusNoLock cfg) + ToJSON (Public.Feature cfg) ) => UserId -> TeamId -> - Public.WithStatusNoLock cfg -> + Public.Feature cfg -> TestM ResponseLBS putTeamFeature uid tid status = do galley <- viewGalley diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index 03dc835df67..72f2bf4983c 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -99,7 +99,7 @@ assertSSOEnabled tid = do . paths ["i", "teams", toByteString' tid, "features", "sso"] unless (statusCode resp == 200) $ rethrow "galley" resp - ws :: WithStatus SSOConfig <- parseResponse "galley" resp + ws :: LockableFeature SSOConfig <- parseResponse "galley" resp unless (wsStatus ws == FeatureStatusEnabled) $ throwSpar SparSSODisabled @@ -108,7 +108,7 @@ isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure ( statusCode resp == 200 - && ( (wsStatus <$> responseJsonMaybe @(WithStatus ValidateSAMLEmailsConfig) resp) + && ( (wsStatus <$> responseJsonMaybe @(LockableFeature ValidateSAMLEmailsConfig) resp) == Just FeatureStatusEnabled ) ) diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index 69a064400cf..d071c56940b 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -151,7 +151,7 @@ unlockFeature galley tid = setSndFactorPasswordChallengeStatus :: GalleyReq -> TeamId -> Public.FeatureStatus -> TestSpar () setSndFactorPasswordChallengeStatus galley tid status = do - let js = RequestBodyLBS $ encode $ Public.WithStatusNoLock @Public.SndFactorPasswordChallengeConfig status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature @Public.SndFactorPasswordChallengeConfig status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited call $ put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 30e18ed8cfa..def3f87d466 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -385,7 +385,7 @@ putSSOEnabledInternal gly tid enabled = do void . put $ gly . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (WithStatusNoLock @SSOConfig enabled SSOConfig FeatureTTLUnlimited) + . json (Feature @SSOConfig enabled SSOConfig FeatureTTLUnlimited) . expect2xx -- | cloned from `/services/brig/test/integration/API/Team/Util.hs`. diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index 0a1910127fe..aa39af7cdd3 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -110,6 +110,6 @@ activate brig (k, c) = setSamlEmailValidation :: (HasCallStack) => TeamId -> Feature.FeatureStatus -> TestSpar () setSamlEmailValidation tid status = do galley <- view teGalley - let req = put $ galley . paths p . json (Feature.WithStatusNoLock @Feature.ValidateSAMLEmailsConfig status Feature.ValidateSAMLEmailsConfig Feature.FeatureTTLUnlimited) + let req = put $ galley . paths p . json (Feature.Feature @Feature.ValidateSAMLEmailsConfig status Feature.ValidateSAMLEmailsConfig Feature.FeatureTTLUnlimited) p = ["/i/teams", toByteString' tid, "features", Feature.featureNameBS @Feature.ValidateSAMLEmailsConfig] call req !!! const 200 === statusCode diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index b95aa15c989..97b3e704117 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -314,16 +314,16 @@ mkFeatureGetRoute :: Typeable cfg ) => TeamId -> - Handler (WithStatus cfg) + Handler (LockableFeature cfg) mkFeatureGetRoute = Intra.getTeamFeatureFlag @cfg mkFeaturePutRoute :: forall cfg. ( KnownSymbol (FeatureSymbol cfg), - ToJSON (WithStatusNoLock cfg) + ToJSON (Feature cfg) ) => TeamId -> - WithStatusNoLock cfg -> + Feature cfg -> Handler NoContent mkFeaturePutRoute tid payload = NoContent <$ Intra.setTeamFeatureFlag @cfg tid payload @@ -331,8 +331,8 @@ type MkFeaturePutConstraints cfg = ( IsFeatureConfig cfg, KnownSymbol (FeatureSymbol cfg), ToSchema cfg, - FromJSON (WithStatusNoLock cfg), - ToJSON (WithStatusNoLock cfg), + FromJSON (Feature cfg), + ToJSON (Feature cfg), Typeable cfg ) diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 93b99fce9f1..f0472676e47 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -484,7 +484,7 @@ type MkFeatureGetRoute (feature :: Type) = :> Capture "tid" TeamId :> "features" :> FeatureSymbol feature - :> Get '[JSON] (WithStatus feature) + :> Get '[JSON] (LockableFeature feature) type MkFeaturePutRouteNoTTL (feature :: Type) = Summary "Disable / enable status for a given feature / team" @@ -522,5 +522,5 @@ type MkFeaturePutRoute (feature :: Type) = :> Capture "tid" TeamId :> "features" :> FeatureSymbol feature - :> ReqBody '[JSON] (WithStatusNoLock feature) + :> ReqBody '[JSON] (Feature feature) :> Put '[JSON] NoContent diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index f3350ee7bcc..0a3670d5c0a 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -504,12 +504,12 @@ setBlacklistStatus status email = do getTeamFeatureFlag :: forall cfg. - ( Typeable (Public.WithStatus cfg), - FromJSON (Public.WithStatus cfg), + ( Typeable (Public.LockableFeature cfg), + FromJSON (Public.LockableFeature cfg), KnownSymbol (Public.FeatureSymbol cfg) ) => TeamId -> - Handler (Public.WithStatus cfg) + Handler (Public.LockableFeature cfg) getTeamFeatureFlag tid = do info $ msg "Getting team feature status" gly <- view galley @@ -518,17 +518,17 @@ getTeamFeatureFlag tid = do . Bilge.paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] resp <- catchRpcErrors $ rpc' "galley" gly req case Bilge.statusCode resp of - 200 -> pure $ responseJsonUnsafe @(Public.WithStatus cfg) resp + 200 -> pure $ responseJsonUnsafe @(Public.LockableFeature cfg) resp 404 -> throwE (mkError status404 "bad-upstream" "team doesnt exist") _ -> throwE (mkError status502 "bad-upstream" (errorMessage resp)) setTeamFeatureFlag :: forall cfg. - ( ToJSON (Public.WithStatusNoLock cfg), + ( ToJSON (Public.Feature cfg), KnownSymbol (Public.FeatureSymbol cfg) ) => TeamId -> - Public.WithStatusNoLock cfg -> + Public.Feature cfg -> Handler () setTeamFeatureFlag tid status = do info $ msg "Setting team feature status" @@ -541,11 +541,11 @@ setTeamFeatureFlag tid status = do patchTeamFeatureFlag :: forall cfg. - ( ToJSON (Public.WithStatusPatch cfg), + ( ToJSON (Public.LockableFeaturePatch cfg), KnownSymbol (Public.FeatureSymbol cfg) ) => TeamId -> - Public.WithStatusPatch cfg -> + Public.LockableFeaturePatch cfg -> Handler () patchTeamFeatureFlag tid patch = do info $ msg "Patching team feature status" diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index b35aadcf554..ffc0aeafdd8 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -105,7 +105,7 @@ tests s = -- - `POST /teams/:tid/billing` ] -defConfCalling :: WithStatus ConferenceCallingConfig +defConfCalling :: LockableFeature ConferenceCallingConfig defConfCalling = setStatus FeatureStatusDisabled defFeatureStatus testRudSsoDomainRedirect :: TestM () @@ -321,7 +321,7 @@ testFeatureStatusOptTtl :: Eq cfg, Show cfg ) => - WithStatus cfg -> + LockableFeature cfg -> Maybe FeatureTTL -> TestM () testFeatureStatusOptTtl defValue mTtl = do @@ -614,7 +614,7 @@ getFeatureConfig :: IsFeatureConfig cfg ) => TeamId -> - TestM (WithStatus cfg) + TestM (LockableFeature cfg) getFeatureConfig tid = do s <- view tsStern r <- get (s . paths ["teams", toByteString' tid, "features", Public.featureNameBS @cfg] . expect2xx) @@ -669,10 +669,10 @@ putFeatureConfig :: ToSchema cfg, Typeable cfg, IsFeatureConfig cfg, - ToJSON (WithStatus cfg) + ToJSON (LockableFeature cfg) ) => TeamId -> - WithStatus cfg -> + LockableFeature cfg -> TestM ResponseLBS putFeatureConfig tid cfg = do s <- view tsStern @@ -706,7 +706,7 @@ unlockFeature :: ToSchema cfg, Typeable cfg, IsFeatureConfig cfg, - ToJSON (WithStatus cfg) + ToJSON (LockableFeature cfg) ) => TeamId -> TestM () From 18423bd567adb76e3083f0419faf446822c68363 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 1 Aug 2024 16:48:57 +0200 Subject: [PATCH 02/34] Cleanup LockableFeature --- libs/wire-api/src/Wire/API/Team/Feature.hs | 179 ++++++++---------- .../Generated/LockableFeaturePatch_team.hs | 2 +- .../Golden/Generated/LockableFeature_team.hs | 44 ++--- .../test/unit/Test/Wire/API/Team/Feature.hs | 15 +- .../src/Wire/GalleyAPIAccess/Rpc.hs | 4 +- .../src/Wire/UserSubsystem/Interpreter.hs | 2 +- .../test/unit/Wire/MiniBackend.hs | 2 + .../Wire/UserSubsystem/InterpreterSpec.hs | 19 +- services/brig/src/Brig/Calling/API.hs | 4 +- services/brig/src/Brig/Options.hs | 7 +- services/brig/src/Brig/Provider/API.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 6 +- services/brig/test/integration/API/Team.hs | 3 +- .../brig/test/integration/API/User/Account.hs | 5 +- services/galley/src/Galley/API/Internal.hs | 4 +- .../galley/src/Galley/API/MLS/Migration.hs | 5 +- services/galley/src/Galley/API/Query.hs | 4 +- services/galley/src/Galley/API/Teams.hs | 2 +- .../galley/src/Galley/API/Teams/Features.hs | 26 +-- .../src/Galley/API/Teams/Features/Get.hs | 19 +- services/galley/src/Galley/App.hs | 4 +- services/galley/test/integration/API.hs | 13 +- services/spar/src/Spar/Intra/Galley.hs | 4 +- tools/stern/src/Stern/API.hs | 2 +- tools/stern/test/integration/API.hs | 36 ++-- 25 files changed, 200 insertions(+), 213 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 5ecdc89ae57..dbc05567f03 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. -- @@ -33,19 +34,12 @@ module Wire.API.Team.Feature dbFeatureTTL, dbFeatureConfig, dbFeatureModConfig, - LockableFeature, - withStatus, + LockableFeature (..), + defUnlockedFeature, + defLockedFeature, withStatus', - wsStatus, - wsLockStatus, - wsConfig, - wsTTL, - setStatus, - setLockStatus, - setConfig, setConfig', setTTL, - setWsTTL, LockableFeaturePatch, wsPatch, wspStatus, @@ -245,6 +239,12 @@ data LockableFeatureBase (m :: Type -> Type) (cfg :: Type) = LockableFeatureBase } deriving stock (Generic, Typeable, Functor) +setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg +setConfig' c (LockableFeatureBase s ls _ ttl) = LockableFeatureBase s ls (pure c) ttl + +setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg +setTTL ttl (LockableFeatureBase s ls c _) = LockableFeatureBase s ls c (pure ttl) + -------------------------------------------------------------------------------- -- DbFeature @@ -296,66 +296,49 @@ data DbFeatureWithLock cfg = DbFeatureWithLock -- See the implementation of 'computeFeature' for 'ConferenceCallingConfig' for -- an example of this mechanism in practice. --- FUTUREWORK: use lenses, maybe? -wsStatus :: LockableFeature cfg -> FeatureStatus -wsStatus = runIdentity . wsbStatus - -wsLockStatus :: LockableFeature cfg -> LockStatus -wsLockStatus = runIdentity . wsbLockStatus - -wsConfig :: LockableFeature cfg -> cfg -wsConfig = runIdentity . wsbConfig - -wsTTL :: LockableFeature cfg -> FeatureTTL -wsTTL = runIdentity . wsbTTL - -withStatus :: FeatureStatus -> LockStatus -> cfg -> FeatureTTL -> LockableFeature cfg -withStatus s ls c ttl = LockableFeatureBase (Identity s) (Identity ls) (Identity c) (Identity ttl) - -setStatus :: FeatureStatus -> LockableFeature cfg -> LockableFeature cfg -setStatus s (LockableFeatureBase _ ls c ttl) = LockableFeatureBase (Identity s) ls c ttl - -setLockStatus :: LockStatus -> LockableFeature cfg -> LockableFeature cfg -setLockStatus ls (LockableFeatureBase s _ c ttl) = LockableFeatureBase s (Identity ls) c ttl - -setConfig :: cfg -> LockableFeature cfg -> LockableFeature cfg -setConfig = setConfig' - -setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg -setConfig' c (LockableFeatureBase s ls _ ttl) = LockableFeatureBase s ls (pure c) ttl - -setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg -setTTL ttl (LockableFeatureBase s ls c _) = LockableFeatureBase s ls c (pure ttl) - -setWsTTL :: FeatureTTL -> LockableFeature cfg -> LockableFeature cfg -setWsTTL = setTTL - -type LockableFeature = LockableFeatureBase Identity - -deriving instance (Eq cfg) => Eq (LockableFeature cfg) - -deriving instance (Show cfg) => Show (LockableFeature cfg) - -deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg)) => ToJSON (LockableFeature cfg) - -deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg)) => FromJSON (LockableFeature cfg) - -deriving via (Schema (LockableFeature cfg)) instance (ToSchema (LockableFeature cfg), Typeable cfg) => S.ToSchema (LockableFeature cfg) +data LockableFeature cfg = LockableFeature + { status :: FeatureStatus, + lockStatus :: LockStatus, + config :: cfg + } + deriving stock (Eq, Show) + deriving (ToJSON, FromJSON, S.ToSchema) via Schema (LockableFeature cfg) + +-- | A feature that is disabled and locked. +defLockedFeature :: cfg -> LockableFeature cfg +defLockedFeature c = + LockableFeature + { status = FeatureStatusDisabled, + lockStatus = LockStatusLocked, + config = c + } + +-- | A feature that is enabled and unlocked. +defUnlockedFeature :: cfg -> LockableFeature cfg +defUnlockedFeature c = + LockableFeature + { status = FeatureStatusEnabled, + lockStatus = LockStatusUnlocked, + config = c + } instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where schema = object name $ - LockableFeatureBase - <$> (runIdentity . wsbStatus) .= (Identity <$> field "status" schema) - <*> (runIdentity . wsbLockStatus) .= (Identity <$> field "lockStatus" schema) - <*> (runIdentity . wsbConfig) .= (Identity <$> objectSchema @cfg) - <*> (runIdentity . wsbTTL) .= (Identity . fromMaybe FeatureTTLUnlimited <$> optField "ttl" schema) + LockableFeature + <$> (.status) .= field "status" schema + <*> (.lockStatus) .= field "lockStatus" schema + <*> (.config) .= objectSchema @cfg + <* const FeatureTTLUnlimited + .= optField + "ttl" + (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) where inner = schema @cfg name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeature" instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeature cfg) where - arbitrary = LockableFeatureBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = LockableFeature <$> arbitrary <*> arbitrary <*> arbitrary ---------------------------------------------------------------------- -- LockableFeaturePatch @@ -422,10 +405,10 @@ instance (Arbitrary cfg) => Arbitrary (Feature cfg) where arbitrary = Feature <$> arbitrary <*> arbitrary <*> arbitrary forgetLock :: LockableFeature a -> Feature a -forgetLock ws = Feature (wsStatus ws) (wsConfig ws) (wsTTL ws) +forgetLock ws = Feature ws.status ws.config FeatureTTLUnlimited withLockStatus :: LockStatus -> Feature a -> LockableFeature a -withLockStatus ls (Feature s c ttl) = withStatus s ls c ttl +withLockStatus ls (Feature s c _ttl) = LockableFeature s ls c withUnlocked :: Feature a -> LockableFeature a withUnlocked = withLockStatus LockStatusUnlocked @@ -609,7 +592,7 @@ instance (IsFeatureConfig a, ToSchema a) => ToJSON (ImplicitLockStatus a) where toJSON (ImplicitLockStatus a) = A.toJSON $ forgetLock a instance (IsFeatureConfig a, ToSchema a) => FromJSON (ImplicitLockStatus a) where - parseJSON v = ImplicitLockStatus . withLockStatus (wsLockStatus $ defFeatureStatus @a) <$> A.parseJSON v + parseJSON v = ImplicitLockStatus . withLockStatus ((defFeatureStatus @a).lockStatus) <$> A.parseJSON v -- | Convert a feature coming from the database to its public form. This can be -- overridden on a feature basis by implementing the `computeFeature` method of @@ -620,8 +603,8 @@ genericComputeFeature :: DbFeature cfg -> LockableFeature cfg genericComputeFeature defFeature lockStatus dbFeature = - case fromMaybe (wsLockStatus defFeature) lockStatus of - LockStatusLocked -> setLockStatus LockStatusLocked defFeature + case fromMaybe defFeature.lockStatus lockStatus of + LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} LockStatusUnlocked -> withUnlocked $ unDbFeature dbFeature (forgetLock defFeature) -- | This contains the pure business logic for users from teams @@ -635,7 +618,7 @@ computeFeatureConfigForTeamUser mStatusDb mLockStatusDb defStatus = Nothing -> forgetLock defStatus Just fs -> fs where - lockStatus = fromMaybe (wsLockStatus defStatus) mLockStatusDb + lockStatus = fromMaybe defStatus.lockStatus mLockStatusDb -------------------------------------------------------------------------------- -- GuestLinks feature @@ -652,7 +635,7 @@ instance ToSchema GuestLinksConfig where instance IsFeatureConfig GuestLinksConfig where type FeatureSymbol GuestLinksConfig = "conversationGuestLinks" - defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature GuestLinksConfig featureSingleton = FeatureSingletonGuestLinksConfig objectSchema = pure GuestLinksConfig @@ -669,7 +652,7 @@ instance RenderableSymbol LegalholdConfig where instance IsFeatureConfig LegalholdConfig where type FeatureSymbol LegalholdConfig = "legalhold" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked LegalholdConfig FeatureTTLUnlimited + defFeatureStatus = (defUnlockedFeature LegalholdConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonLegalholdConfig objectSchema = pure LegalholdConfig @@ -689,7 +672,7 @@ instance RenderableSymbol SSOConfig where instance IsFeatureConfig SSOConfig where type FeatureSymbol SSOConfig = "sso" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SSOConfig FeatureTTLUnlimited + defFeatureStatus = (defUnlockedFeature SSOConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSSOConfig objectSchema = pure SSOConfig @@ -710,7 +693,7 @@ instance RenderableSymbol SearchVisibilityAvailableConfig where instance IsFeatureConfig SearchVisibilityAvailableConfig where type FeatureSymbol SearchVisibilityAvailableConfig = "searchVisibility" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityAvailableConfig FeatureTTLUnlimited + defFeatureStatus = (defUnlockedFeature SearchVisibilityAvailableConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSearchVisibilityAvailableConfig objectSchema = pure SearchVisibilityAvailableConfig @@ -736,7 +719,7 @@ instance ToSchema ValidateSAMLEmailsConfig where instance IsFeatureConfig ValidateSAMLEmailsConfig where type FeatureSymbol ValidateSAMLEmailsConfig = "validateSAMLemails" - defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked ValidateSAMLEmailsConfig FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature ValidateSAMLEmailsConfig featureSingleton = FeatureSingletonValidateSAMLEmailsConfig objectSchema = pure ValidateSAMLEmailsConfig @@ -756,7 +739,7 @@ instance RenderableSymbol DigitalSignaturesConfig where instance IsFeatureConfig DigitalSignaturesConfig where type FeatureSymbol DigitalSignaturesConfig = "digitalSignatures" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked DigitalSignaturesConfig FeatureTTLUnlimited + defFeatureStatus = (defUnlockedFeature DigitalSignaturesConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonDigitalSignaturesConfig objectSchema = pure DigitalSignaturesConfig @@ -806,7 +789,7 @@ instance RenderableSymbol ConferenceCallingConfig where instance IsFeatureConfig ConferenceCallingConfig where type FeatureSymbol ConferenceCallingConfig = "conferenceCalling" - defFeatureStatus = withStatus FeatureStatusEnabled LockStatusLocked def FeatureTTLUnlimited + defFeatureStatus = (defLockedFeature def) {status = FeatureStatusEnabled} featureSingleton = FeatureSingletonConferenceCallingConfig objectSchema = fromMaybe def <$> optField "config" schema @@ -834,7 +817,7 @@ instance ToSchema SndFactorPasswordChallengeConfig where instance IsFeatureConfig SndFactorPasswordChallengeConfig where type FeatureSymbol SndFactorPasswordChallengeConfig = "sndFactorPasswordChallenge" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked SndFactorPasswordChallengeConfig FeatureTTLUnlimited + defFeatureStatus = defLockedFeature SndFactorPasswordChallengeConfig featureSingleton = FeatureSingletonSndFactorPasswordChallengeConfig objectSchema = pure SndFactorPasswordChallengeConfig @@ -851,7 +834,7 @@ instance RenderableSymbol SearchVisibilityInboundConfig where instance IsFeatureConfig SearchVisibilityInboundConfig where type FeatureSymbol SearchVisibilityInboundConfig = "searchVisibilityInbound" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked SearchVisibilityInboundConfig FeatureTTLUnlimited + defFeatureStatus = (defUnlockedFeature SearchVisibilityInboundConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSearchVisibilityInboundConfig objectSchema = pure SearchVisibilityInboundConfig @@ -885,11 +868,9 @@ instance IsFeatureConfig ClassifiedDomainsConfig where type FeatureSymbol ClassifiedDomainsConfig = "classifiedDomains" defFeatureStatus = - withStatus - FeatureStatusDisabled - LockStatusUnlocked - (ClassifiedDomainsConfig []) - FeatureTTLUnlimited + (defUnlockedFeature (ClassifiedDomainsConfig [])) + { status = FeatureStatusDisabled + } featureSingleton = FeatureSingletonClassifiedDomainsConfig objectSchema = field "config" schema @@ -917,12 +898,7 @@ instance ToSchema AppLockConfig where instance IsFeatureConfig AppLockConfig where type FeatureSymbol AppLockConfig = "appLock" - defFeatureStatus = - withStatus - FeatureStatusEnabled - LockStatusUnlocked - (AppLockConfig (EnforceAppLock False) 60) - FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature (AppLockConfig (EnforceAppLock False) 60) featureSingleton = FeatureSingletonAppLockConfig objectSchema = field "config" schema @@ -946,7 +922,7 @@ instance RenderableSymbol FileSharingConfig where instance IsFeatureConfig FileSharingConfig where type FeatureSymbol FileSharingConfig = "fileSharing" - defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked FileSharingConfig FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature FileSharingConfig featureSingleton = FeatureSingletonFileSharingConfig objectSchema = pure FileSharingConfig @@ -974,12 +950,7 @@ instance ToSchema SelfDeletingMessagesConfig where instance IsFeatureConfig SelfDeletingMessagesConfig where type FeatureSymbol SelfDeletingMessagesConfig = "selfDeletingMessages" - defFeatureStatus = - withStatus - FeatureStatusEnabled - LockStatusUnlocked - (SelfDeletingMessagesConfig 0) - FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature (SelfDeletingMessagesConfig 0) featureSingleton = FeatureSingletonSelfDeletingMessagesConfig objectSchema = field "config" schema @@ -1019,7 +990,7 @@ instance IsFeatureConfig MLSConfig where [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 [ProtocolProteusTag, ProtocolMLSTag] - in withStatus FeatureStatusDisabled LockStatusUnlocked config FeatureTTLUnlimited + in (defUnlockedFeature config) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonMLSConfig objectSchema = field "config" schema @@ -1035,7 +1006,7 @@ instance RenderableSymbol ExposeInvitationURLsToTeamAdminConfig where instance IsFeatureConfig ExposeInvitationURLsToTeamAdminConfig where type FeatureSymbol ExposeInvitationURLsToTeamAdminConfig = "exposeInvitationURLsToTeamAdmin" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig FeatureTTLUnlimited + defFeatureStatus = defLockedFeature ExposeInvitationURLsToTeamAdminConfig featureSingleton = FeatureSingletonExposeInvitationURLsToTeamAdminConfig objectSchema = pure ExposeInvitationURLsToTeamAdminConfig @@ -1056,7 +1027,7 @@ instance RenderableSymbol OutlookCalIntegrationConfig where instance IsFeatureConfig OutlookCalIntegrationConfig where type FeatureSymbol OutlookCalIntegrationConfig = "outlookCalIntegration" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked OutlookCalIntegrationConfig FeatureTTLUnlimited + defFeatureStatus = defLockedFeature OutlookCalIntegrationConfig featureSingleton = FeatureSingletonOutlookCalIntegrationConfig objectSchema = pure OutlookCalIntegrationConfig @@ -1118,9 +1089,9 @@ instance ToSchema MlsE2EIdConfig where instance IsFeatureConfig MlsE2EIdConfig where type FeatureSymbol MlsE2EIdConfig = "mlsE2EId" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusUnlocked defValue FeatureTTLUnlimited - where - defValue = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False + defFeatureStatus = + defLockedFeature $ + MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema @@ -1155,9 +1126,7 @@ instance ToSchema MlsMigrationConfig where instance IsFeatureConfig MlsMigrationConfig where type FeatureSymbol MlsMigrationConfig = "mlsMigration" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked defValue FeatureTTLUnlimited - where - defValue = MlsMigrationConfig Nothing Nothing + defFeatureStatus = defLockedFeature (MlsMigrationConfig Nothing Nothing) featureSingleton = FeatureSingletonMlsMigration objectSchema = field "config" schema @@ -1183,7 +1152,7 @@ instance ToSchema EnforceFileDownloadLocationConfig where instance IsFeatureConfig EnforceFileDownloadLocationConfig where type FeatureSymbol EnforceFileDownloadLocationConfig = "enforceFileDownloadLocation" - defFeatureStatus = withStatus FeatureStatusDisabled LockStatusLocked (EnforceFileDownloadLocationConfig Nothing) FeatureTTLUnlimited + defFeatureStatus = defLockedFeature (EnforceFileDownloadLocationConfig Nothing) featureSingleton = FeatureSingletonEnforceFileDownloadLocationConfig objectSchema = field "config" schema @@ -1204,7 +1173,7 @@ instance RenderableSymbol LimitedEventFanoutConfig where instance IsFeatureConfig LimitedEventFanoutConfig where type FeatureSymbol LimitedEventFanoutConfig = "limitedEventFanout" - defFeatureStatus = withStatus FeatureStatusEnabled LockStatusUnlocked LimitedEventFanoutConfig FeatureTTLUnlimited + defFeatureStatus = defUnlockedFeature LimitedEventFanoutConfig featureSingleton = FeatureSingletonLimitedEventFanoutConfig objectSchema = pure LimitedEventFanoutConfig diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs index adef236459c..638ea52475b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs @@ -21,7 +21,7 @@ module Test.Wire.API.Golden.Generated.LockableFeaturePatch_team where import Data.Domain import Imports -import Wire.API.Team.Feature hiding (withStatus) +import Wire.API.Team.Feature testObject_LockableFeaturePatch_team_1 :: LockableFeaturePatch AppLockConfig testObject_LockableFeaturePatch_team_1 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (AppLockConfig (EnforceAppLock False) (-98))) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs index 0a85c632e03..8c4f9562f39 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeature_team.hs @@ -23,63 +23,62 @@ import Data.ByteString.Conversion (parser, runParser) import Data.Domain import Data.Misc import Imports -import Wire.API.Team.Feature hiding (withStatus) -import Wire.API.Team.Feature qualified as F +import Wire.API.Team.Feature testObject_LockableFeature_team_1 :: LockableFeature AppLockConfig -testObject_LockableFeature_team_1 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock False) (-98)) +testObject_LockableFeature_team_1 = LockableFeature FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock False) (-98)) testObject_LockableFeature_team_2 :: LockableFeature AppLockConfig -testObject_LockableFeature_team_2 = withStatus FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock True) 0) +testObject_LockableFeature_team_2 = LockableFeature FeatureStatusEnabled LockStatusUnlocked (AppLockConfig (EnforceAppLock True) 0) testObject_LockableFeature_team_3 :: LockableFeature AppLockConfig -testObject_LockableFeature_team_3 = withStatus FeatureStatusEnabled LockStatusLocked (AppLockConfig (EnforceAppLock True) 111) +testObject_LockableFeature_team_3 = LockableFeature FeatureStatusEnabled LockStatusLocked (AppLockConfig (EnforceAppLock True) 111) testObject_LockableFeature_team_4 :: LockableFeature SelfDeletingMessagesConfig -testObject_LockableFeature_team_4 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig (-97)) +testObject_LockableFeature_team_4 = LockableFeature FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig (-97)) testObject_LockableFeature_team_5 :: LockableFeature SelfDeletingMessagesConfig -testObject_LockableFeature_team_5 = withStatus FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig 0) +testObject_LockableFeature_team_5 = LockableFeature FeatureStatusEnabled LockStatusUnlocked (SelfDeletingMessagesConfig 0) testObject_LockableFeature_team_6 :: LockableFeature SelfDeletingMessagesConfig -testObject_LockableFeature_team_6 = withStatus FeatureStatusEnabled LockStatusLocked (SelfDeletingMessagesConfig 77) +testObject_LockableFeature_team_6 = LockableFeature FeatureStatusEnabled LockStatusLocked (SelfDeletingMessagesConfig 77) testObject_LockableFeature_team_7 :: LockableFeature ClassifiedDomainsConfig -testObject_LockableFeature_team_7 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig []) +testObject_LockableFeature_team_7 = LockableFeature FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig []) testObject_LockableFeature_team_8 :: LockableFeature ClassifiedDomainsConfig -testObject_LockableFeature_team_8 = withStatus FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) +testObject_LockableFeature_team_8 = LockableFeature FeatureStatusEnabled LockStatusLocked (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) testObject_LockableFeature_team_9 :: LockableFeature ClassifiedDomainsConfig -testObject_LockableFeature_team_9 = withStatus FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "test.foobar"]) +testObject_LockableFeature_team_9 = LockableFeature FeatureStatusEnabled LockStatusUnlocked (ClassifiedDomainsConfig [Domain "test.foobar"]) testObject_LockableFeature_team_10 :: LockableFeature SSOConfig -testObject_LockableFeature_team_10 = withStatus FeatureStatusDisabled LockStatusLocked SSOConfig +testObject_LockableFeature_team_10 = LockableFeature FeatureStatusDisabled LockStatusLocked SSOConfig testObject_LockableFeature_team_11 :: LockableFeature SearchVisibilityAvailableConfig -testObject_LockableFeature_team_11 = withStatus FeatureStatusEnabled LockStatusLocked SearchVisibilityAvailableConfig +testObject_LockableFeature_team_11 = LockableFeature FeatureStatusEnabled LockStatusLocked SearchVisibilityAvailableConfig testObject_LockableFeature_team_12 :: LockableFeature ValidateSAMLEmailsConfig -testObject_LockableFeature_team_12 = withStatus FeatureStatusDisabled LockStatusLocked ValidateSAMLEmailsConfig +testObject_LockableFeature_team_12 = LockableFeature FeatureStatusDisabled LockStatusLocked ValidateSAMLEmailsConfig testObject_LockableFeature_team_13 :: LockableFeature DigitalSignaturesConfig -testObject_LockableFeature_team_13 = withStatus FeatureStatusEnabled LockStatusLocked DigitalSignaturesConfig +testObject_LockableFeature_team_13 = LockableFeature FeatureStatusEnabled LockStatusLocked DigitalSignaturesConfig testObject_LockableFeature_team_14 :: LockableFeature ConferenceCallingConfig -testObject_LockableFeature_team_14 = withStatus FeatureStatusDisabled LockStatusUnlocked (ConferenceCallingConfig One2OneCallsTurn) +testObject_LockableFeature_team_14 = LockableFeature FeatureStatusDisabled LockStatusUnlocked (ConferenceCallingConfig One2OneCallsTurn) testObject_LockableFeature_team_15 :: LockableFeature GuestLinksConfig -testObject_LockableFeature_team_15 = withStatus FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig +testObject_LockableFeature_team_15 = LockableFeature FeatureStatusEnabled LockStatusUnlocked GuestLinksConfig testObject_LockableFeature_team_16 :: LockableFeature SndFactorPasswordChallengeConfig -testObject_LockableFeature_team_16 = withStatus FeatureStatusDisabled LockStatusUnlocked SndFactorPasswordChallengeConfig +testObject_LockableFeature_team_16 = LockableFeature FeatureStatusDisabled LockStatusUnlocked SndFactorPasswordChallengeConfig testObject_LockableFeature_team_17 :: LockableFeature SearchVisibilityInboundConfig -testObject_LockableFeature_team_17 = withStatus FeatureStatusEnabled LockStatusUnlocked SearchVisibilityInboundConfig +testObject_LockableFeature_team_17 = LockableFeature FeatureStatusEnabled LockStatusUnlocked SearchVisibilityInboundConfig testObject_LockableFeature_team_18 :: LockableFeature MlsE2EIdConfig testObject_LockableFeature_team_18 = - withStatus + LockableFeature FeatureStatusEnabled LockStatusLocked ( MlsE2EIdConfig @@ -94,7 +93,7 @@ parseHttpsUrl url = runParser parser url testObject_LockableFeature_team_19 :: LockableFeature MlsE2EIdConfig testObject_LockableFeature_team_19 = - withStatus + LockableFeature FeatureStatusEnabled LockStatusLocked ( MlsE2EIdConfig @@ -103,6 +102,3 @@ testObject_LockableFeature_team_19 = Nothing True ) - -withStatus :: FeatureStatus -> LockStatus -> cfg -> LockableFeature cfg -withStatus fs ls cfg = F.withStatus fs ls cfg FeatureTTLUnlimited 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 index 60b634c9d17..3d65c0e6ca2 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. @@ -39,11 +40,10 @@ testComputeFeatureConfigForTeamUserLsIsNothing = do let mStatusDb = undefined let mLockStatusDb = Nothing let defStatus = - withStatus + LockableFeature FeatureStatusEnabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited let expected = defStatus let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus actual @?= expected @@ -53,11 +53,10 @@ testComputeFeatureConfigForTeamUserLocked = do let mStatusDb = undefined let mLockStatusDb = Just LockStatusLocked let defStatus = - withStatus + LockableFeature FeatureStatusEnabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited let expected = defStatus let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus actual @?= expected @@ -67,12 +66,11 @@ testComputeFeatureConfigForTeamUserUnlocked = do let mStatusDb = Nothing let mLockStatusDb = Just LockStatusUnlocked let defStatus = - withStatus + LockableFeature FeatureStatusEnabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited - let expected = defStatus & setLockStatus LockStatusUnlocked + let expected = defStatus {lockStatus = LockStatusUnlocked} :: LockableFeature ExposeInvitationURLsToTeamAdminConfig let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus actual @?= expected @@ -80,11 +78,10 @@ testComputeFeatureConfigForTeamWithDbStatus :: Assertion testComputeFeatureConfigForTeamWithDbStatus = do let mStatusDb = Just . forgetLock $ - withStatus + LockableFeature FeatureStatusDisabled LockStatusUnlocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited let mLockStatusDb = Just LockStatusUnlocked let defStatus = undefined let (Just expected) = withUnlocked <$> mStatusDb diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index eed8eb169c1..7f451bad632 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -443,7 +443,7 @@ getVerificationCodeEnabled :: getVerificationCodeEnabled tid = do debug $ remote "galley" . msg (val "Get snd factor password challenge settings") response <- galleyRequest req - status <- wsStatus <$> decodeBodyOrThrow @(LockableFeature SndFactorPasswordChallengeConfig) "galley" response + status <- (.status) <$> decodeBodyOrThrow @(LockableFeature SndFactorPasswordChallengeConfig) "galley" response case status of FeatureStatusEnabled -> pure True FeatureStatusDisabled -> pure False @@ -500,7 +500,7 @@ getTeamExposeInvitationURLsToTeamAdmin :: getTeamExposeInvitationURLsToTeamAdmin tid = do debug $ remote "galley" . msg (val "Get expose invitation URLs to team admin settings") response <- galleyRequest req - status <- wsStatus <$> decodeBodyOrThrow @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) "galley" response + status <- (.status) <$> decodeBodyOrThrow @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) "galley" response case status of FeatureStatusEnabled -> pure ShowInvitationUrl FeatureStatusDisabled -> pure HideInvitationUrl diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 7daba81f6d8..0fd15702e2e 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -472,7 +472,7 @@ checkHandleImpl uhandle = do hasE2EId :: (Member GalleyAPIAccess r) => StoredUser -> Sem r Bool hasE2EId user = - wsStatus . afcMlsE2EId + (.status) . afcMlsE2EId <$> getAllFeatureConfigsForUser (Just user.id) <&> \case FeatureStatusEnabled -> True FeatureStatusDisabled -> False diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index 1c0e673fa88..84f870e01b2 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + module Wire.MiniBackend ( -- * Mini backends MiniBackend (..), diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 03fb0a2cda5..249cb10f810 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -223,7 +223,7 @@ spec = describe "UserSubsystem.Interpreter" do prop "should mark user as managed by scim if E2EId is enabled for the user and they have a handle" \storedSelf domain susbsystemConfig mlsE2EIdConfig -> let localBackend = def {users = [storedSelf]} - allFeatureConfigs = def {afcMlsE2EId = withStatus FeatureStatusEnabled LockStatusUnlocked mlsE2EIdConfig FeatureTTLUnlimited} + allFeatureConfigs = def {afcMlsE2EId = defUnlockedFeature mlsE2EIdConfig} SelfProfile retrievedUser = fromJust . runAllErrorsUnsafe @@ -326,9 +326,20 @@ spec = describe "UserSubsystem.Interpreter" do run . runErrorUnsafe . runError - $ interpretNoFederationStack localBackend Nothing def {afcMlsE2EId = setStatus FeatureStatusEnabled defFeatureStatus} config do - updateUserProfile lusr Nothing UpdateOriginScim (def {name = Just newName}) - getUserProfile lusr (tUntagged lusr) + $ interpretNoFederationStack + localBackend + Nothing + def + { afcMlsE2EId = + defFeatureStatus + { status = FeatureStatusEnabled + } :: + LockableFeature MlsE2EIdConfig + } + config + do + updateUserProfile lusr Nothing UpdateOriginScim (def {name = Just newName}) + getUserProfile lusr (tUntagged lusr) in profileErr === Left UserSubsystemDisplayNameManagedByScim prop diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index e1e71eb74d0..35d5f0a858c 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -83,7 +83,7 @@ getCallsConfigV2 uid _ limit = do sftFederation <- view enableSFTFederation discoveredServers <- turnServersV2 (env ^. turnServers) shared <- do - ccStatus <- lift $ liftSem $ (wsStatus . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + ccStatus <- lift $ liftSem $ ((.status) . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) pure $ case ccStatus of FeatureStatusEnabled -> True FeatureStatusDisabled -> False @@ -118,7 +118,7 @@ getCallsConfig uid _ = do env <- view turnEnv discoveredServers <- turnServersV1 (env ^. turnServers) shared <- do - ccStatus <- lift $ liftSem $ (wsStatus . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + ccStatus <- lift $ liftSem $ ((.status) . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) pure $ case ccStatus of FeatureStatusEnabled -> True FeatureStatusDisabled -> False diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 89f880de956..371faa3565a 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- Disabling to stop errors on Getters {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -708,7 +709,11 @@ instance Arbitrary AccountFeatureConfigs where arbitrary = AccountFeatureConfigs <$> fmap locked arbitrary <*> fmap locked arbitrary where locked :: Public.ImplicitLockStatus a -> Public.ImplicitLockStatus a - locked = Public.ImplicitLockStatus . Public.setLockStatus Public.LockStatusLocked . Public._unImplicitLockStatus + locked impl = + Public.ImplicitLockStatus $ + (Public._unImplicitLockStatus impl) + { Public.lockStatus = Public.LockStatusLocked + } instance FromJSON AccountFeatureConfigs where parseJSON = diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index f87e181648d..2bff95f36af 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -804,7 +804,7 @@ guardSecondFactorDisabled :: Maybe UserId -> ExceptT HttpError (AppT r) () guardSecondFactorDisabled mbUserId = do - enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.wsStatus . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId + enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.status . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId when enabled $ (throwStd (errorToWai @'E.AccessDenied)) minRsaKeySize :: Int diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 8f5fbe0392e..c2d349a2fc9 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -134,7 +134,7 @@ verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId - pure $ fromMaybe (Public.wsStatus (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled + pure $ fromMaybe (Public.status (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of @@ -421,8 +421,8 @@ assertLegalHoldEnabled :: TeamId -> ExceptT LegalHoldLoginError (AppT r) () assertLegalHoldEnabled tid = do - stat <- lift $ liftSem $ GalleyAPIAccess.getTeamLegalHoldStatus tid - case wsStatus stat of + feat <- lift $ liftSem $ GalleyAPIAccess.getTeamLegalHoldStatus tid + case feat.status of FeatureStatusDisabled -> throwE LegalHoldLoginLegalHoldNotEnabled FeatureStatusEnabled -> pure () diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 3e829d00d25..72ff959ab9f 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -274,11 +274,10 @@ invitationUrlGalleyMock featureStatus tid inviter (ReceivedRequest mth pth body_ && pth == ["i", "teams", Text.pack (show tid), "features", "exposeInvitationURLsToTeamAdmin"] = pure . Wai.responseLBS HTTP.status200 mempty $ encode - ( withStatus + ( LockableFeature featureStatus LockStatusUnlocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited ) | mth == "GET" && pth == ["i", "teams", Text.pack (show tid), "members", Text.pack (show inviter)] = diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index b041300dca0..3c378e4f4ae 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -86,7 +86,7 @@ import Wire.API.Asset qualified as Asset import Wire.API.Connection import Wire.API.Conversation import Wire.API.Routes.MultiTablePaging -import Wire.API.Team.Feature (ExposeInvitationURLsToTeamAdminConfig (..), FeatureStatus (..), FeatureTTL' (..), LockStatus (LockStatusLocked), withStatus) +import Wire.API.Team.Feature import Wire.API.Team.Invitation (Invitation (inInvitation)) import Wire.API.Team.Permission hiding (self) import Wire.API.User @@ -1408,11 +1408,10 @@ testTooManyMembersForLegalhold opts brig = do && pth == ["i", "teams", Text.pack (show tid), "features", "exposeInvitationURLsToTeamAdmin"] = pure . Wai.responseLBS HTTP.status200 mempty $ encode - ( withStatus + ( LockableFeature FeatureStatusDisabled LockStatusLocked ExposeInvitationURLsToTeamAdminConfig - FeatureTTLUnlimited ) | otherwise = pure $ Wai.responseLBS HTTP.status500 mempty "Unexpected request to mocked galley" diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index ce683c960ee..ee5e94c3c45 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -90,7 +90,7 @@ import Wire.API.Routes.Internal.Galley import Wire.API.Routes.Internal.Galley.TeamsIntra import Wire.API.Routes.MultiTablePaging (mtpHasMore, mtpPagingState, mtpResults) import Wire.API.Routes.MultiTablePaging qualified as MTP -import Wire.API.Team.Feature hiding (setStatus) +import Wire.API.Team.Feature import Wire.API.User.Client import Wire.NotificationSubsystem import Wire.Sem.Paging @@ -364,7 +364,7 @@ rmUser lusr conn = do FeatureStatusEnabled -> Left <$> E.getTeamAdmins tid FeatureStatusDisabled -> Right <$> getTeamMembersForFanout tid ) - . wsStatus + . (.status) uncheckedDeleteTeamMember lusr conn tid (tUnqualified lusr) toNotify page' <- listTeams @p2 (tUnqualified lusr) (Just (pageState page)) maxBound leaveTeams page' diff --git a/services/galley/src/Galley/API/MLS/Migration.hs b/services/galley/src/Galley/API/MLS/Migration.hs index f34e3c65235..4cb5c35d8a6 100644 --- a/services/galley/src/Galley/API/MLS/Migration.hs +++ b/services/galley/src/Galley/API/MLS/Migration.hs @@ -55,12 +55,11 @@ checkMigrationCriteria :: LockableFeature MlsMigrationConfig -> Sem r Bool checkMigrationCriteria now conv ws - | wsStatus ws == FeatureStatusDisabled = pure False + | ws.status == FeatureStatusDisabled = pure False | afterDeadline = pure True | otherwise = unApAll $ mconcat [localUsersMigrated, remoteUsersMigrated] where - mig = wsConfig ws - afterDeadline = maybe False (now >=) mig.finaliseRegardlessAfter + afterDeadline = maybe False (now >=) ws.config.finaliseRegardlessAfter containsMLS = Set.member BaseProtocolMLSTag diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 6d326ab2096..87457e2ccab 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -97,7 +97,7 @@ import Wire.API.Federation.Client (FederatorClient) import Wire.API.Federation.Error import Wire.API.Provider.Bot qualified as Public import Wire.API.Routes.MultiTablePaging qualified as Public -import Wire.API.Team.Feature as Public hiding (setStatus) +import Wire.API.Team.Feature as Public import Wire.API.User import Wire.Sem.Paging.Cassandra @@ -653,7 +653,7 @@ ensureGuestLinksEnabled :: Maybe TeamId -> Sem r () ensureGuestLinksEnabled mbTid = - getConversationGuestLinksFeatureStatus mbTid >>= \ws -> case wsStatus ws of + getConversationGuestLinksFeatureStatus mbTid >>= \ws -> case ws.status of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> throwS @'GuestLinksDisabled diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index e3aed8fbd4c..c489516322b 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1000,7 +1000,7 @@ deleteTeamMember' lusr zcon tid remove mBody = do mems <- getTeamMembersForFanout tid uncheckedDeleteTeamMember lusr (Just zcon) tid remove (Right mems) ) - . wsStatus + . (.status) pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 1e420dd8315..b23d06c2005 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -98,16 +98,16 @@ patchFeatureStatusInternal tid patch = do let newFeatureStatus = applyPatch currentFeatureStatus -- setting the config can fail, so we need to do it first void $ setConfigForTeam @cfg tid (forgetLock newFeatureStatus) - when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @cfg tid (wsLockStatus newFeatureStatus) + when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @cfg tid newFeatureStatus.lockStatus getFeatureStatus @cfg DontDoAuth tid where applyPatch :: LockableFeature cfg -> LockableFeature cfg applyPatch current = current - & setStatus (fromMaybe (wsStatus current) (wspStatus patch)) - & setLockStatus (fromMaybe (wsLockStatus current) (wspLockStatus patch)) - & setConfig (fromMaybe (wsConfig current) (wspConfig patch)) - & setWsTTL (fromMaybe (wsTTL current) (wspTTL patch)) + { status = fromMaybe current.status (wspStatus patch), + lockStatus = fromMaybe current.lockStatus (wspLockStatus patch), + config = fromMaybe current.config (wspConfig patch) + } setFeatureStatus :: forall cfg r. @@ -135,7 +135,7 @@ setFeatureStatus doauth tid wsnl = do void $ permissionCheck ChangeTeamFeature zusrMembership DontDoAuth -> assertTeamExists tid - guardLockStatus . wsLockStatus =<< getConfigForTeam @cfg tid + guardLockStatus . (.lockStatus) =<< getConfigForTeam @cfg tid setConfigForTeam @cfg tid wsnl setFeatureStatusInternal :: @@ -379,16 +379,16 @@ instance SetFeatureConfig SearchVisibilityInboundConfig where instance SetFeatureConfig MLSConfig where type SetConfigForTeamConstraints MLSConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) - setConfigForTeam tid wsnl = do + setConfigForTeam tid feat = do mlsMigrationConfig <- getConfigForTeam @MlsMigrationConfig tid unless ( -- default protocol needs to be included in supported protocols - mlsDefaultProtocol (wssConfig wsnl) `elem` mlsSupportedProtocols (wssConfig wsnl) + mlsDefaultProtocol (wssConfig feat) `elem` mlsSupportedProtocols (wssConfig feat) -- when MLS migration is enabled, MLS needs to be enabled as well - && (wsStatus mlsMigrationConfig == FeatureStatusDisabled || wssStatus wsnl == FeatureStatusEnabled) + && (mlsMigrationConfig.status == FeatureStatusDisabled || wssStatus feat == FeatureStatusEnabled) ) $ throw MLSProtocolMismatch - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig ExposeInvitationURLsToTeamAdminConfig @@ -410,14 +410,14 @@ guardMlsE2EIdConfig handler uid tid conf = do instance SetFeatureConfig MlsMigrationConfig where type SetConfigForTeamConstraints MlsMigrationConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) - setConfigForTeam tid wsnl = do + setConfigForTeam tid feat = do mlsConfig <- getConfigForTeam @MLSConfig tid unless ( -- when MLS migration is enabled, MLS needs to be enabled as well - wssStatus wsnl == FeatureStatusDisabled || wsStatus mlsConfig == FeatureStatusEnabled + wssStatus feat == FeatureStatusDisabled || mlsConfig.status == FeatureStatusEnabled ) $ throw MLSProtocolMismatch - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig EnforceFileDownloadLocationConfig diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index eec04766394..2395e6d9b1a 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. -- @@ -380,7 +381,7 @@ instance GetFeatureConfig SSOConfig where inputs (view (settings . featureFlags . flagSSO)) <&> \case FeatureSSOEnabledByDefault -> FeatureStatusEnabled FeatureSSODisabledByDefault -> FeatureStatusDisabled - pure $ setStatus status defFeatureStatus + pure $ defFeatureStatus {status = status} instance GetFeatureConfig SearchVisibilityAvailableConfig where getConfigForServer = do @@ -388,7 +389,7 @@ instance GetFeatureConfig SearchVisibilityAvailableConfig where inputs (view (settings . featureFlags . flagTeamSearchVisibility)) <&> \case FeatureTeamSearchVisibilityAvailableByDefault -> FeatureStatusEnabled FeatureTeamSearchVisibilityUnavailableByDefault -> FeatureStatusDisabled - pure $ setStatus status defFeatureStatus + pure $ defFeatureStatus {status = status} instance GetFeatureConfig ValidateSAMLEmailsConfig where getConfigForServer = @@ -413,7 +414,7 @@ instance GetFeatureConfig LegalholdConfig where computeFeature tid defFeature _lockStatus dbFeature = do status <- computeLegalHoldFeatureStatus tid dbFeature - pure $ setStatus status defFeature + pure $ defFeature {status = status} instance GetFeatureConfig FileSharingConfig where getConfigForServer = @@ -453,12 +454,12 @@ instance GetFeatureConfig ConferenceCallingConfig where input <&> view (settings . featureFlags . flagConferenceCalling . unDefaults) getConfigForUser uid = do - wsnl <- getAccountConferenceCallingConfigClient uid - pure $ withLockStatus (wsLockStatus (defFeatureStatus @ConferenceCallingConfig)) wsnl + feat <- getAccountConferenceCallingConfigClient uid + pure $ withLockStatus (defFeatureStatus @ConferenceCallingConfig).lockStatus feat computeFeature _tid defFeature lockStatus dbFeature = - pure $ case fromMaybe (wsLockStatus defFeature) lockStatus of - LockStatusLocked -> setLockStatus LockStatusLocked defFeature + pure $ case fromMaybe defFeature.lockStatus lockStatus of + LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} LockStatusUnlocked -> withUnlocked $ (unDbFeature dbFeature) @@ -542,7 +543,7 @@ guardSecondFactorDisabled uid cid = do pure tid tf <- getConfigForTeamUser @SndFactorPasswordChallengeConfig uid mTid - case wsStatus tf of + case tf.status of FeatureStatusDisabled -> pure () FeatureStatusEnabled -> throwS @'AccessDenied @@ -560,5 +561,5 @@ featureEnabledForTeam :: Sem r Bool featureEnabledForTeam tid = (==) FeatureStatusEnabled - . wsStatus + . (.status) <$> getFeatureStatus @cfg DontDoAuth tid diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 0eab89da5c7..1e87befbc8d 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -147,8 +147,8 @@ validateOptions o = do (Just _, Nothing) -> error "Federator is specified and RabbitMQ config is not, please specify both or none" _ -> pure () let mlsFlag = settings' ^. featureFlags . Teams.flagMLS . Teams.unDefaults - mlsConfig = wsConfig mlsFlag - migrationStatus = wsStatus $ settings' ^. featureFlags . Teams.flagMlsMigration . Teams.unDefaults + mlsConfig = mlsFlag.config + migrationStatus = (.status) $ settings' ^. featureFlags . Teams.flagMlsMigration . Teams.unDefaults when (migrationStatus == FeatureStatusEnabled && ProtocolMLSTag `notElem` mlsSupportedProtocols mlsConfig) $ error "For starting MLS migration, MLS must be included in the supportedProtocol list" unless (mlsDefaultProtocol mlsConfig `elem` mlsSupportedProtocols mlsConfig) $ diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 92b7d20f34d..f7df98c8f52 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1216,7 +1216,16 @@ testJoinTeamConvGuestLinksDisabled = do let checkFeatureStatus fstatus = Util.getTeamFeature @Public.GuestLinksConfig owner teamId !!! do const 200 === statusCode - const (Right (Public.withStatus fstatus Public.LockStatusUnlocked Public.GuestLinksConfig Public.FeatureTTLUnlimited)) === responseJsonEither + const + ( Right + ( Public.LockableFeature + { Public.status = fstatus, + Public.lockStatus = Public.LockStatusUnlocked, + Public.config = Public.GuestLinksConfig + } + ) + ) + === responseJsonEither -- guest can join if guest link feature is enabled checkFeatureStatus Public.FeatureStatusEnabled @@ -1521,7 +1530,7 @@ getGuestLinksStatusFromForeignTeamConv = do let checkGuestLinksStatus u c s = getGuestLinkStatus galley u c !!! do const 200 === statusCode - const s === (Public.wsStatus . (responseJsonUnsafe @(Public.LockableFeature Public.GuestLinksConfig))) + const s === (Public.status . (responseJsonUnsafe @(Public.LockableFeature Public.GuestLinksConfig))) let checkGetGuestLinksStatus s u c = getGuestLinkStatus galley u c !!! do const s === statusCode diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index 72f2bf4983c..8e9b508c947 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -100,7 +100,7 @@ assertSSOEnabled tid = do unless (statusCode resp == 200) $ rethrow "galley" resp ws :: LockableFeature SSOConfig <- parseResponse "galley" resp - unless (wsStatus ws == FeatureStatusEnabled) $ + unless (ws.status == FeatureStatusEnabled) $ throwSpar SparSSODisabled isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> m Bool @@ -108,7 +108,7 @@ isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure ( statusCode resp == 200 - && ( (wsStatus <$> responseJsonMaybe @(LockableFeature ValidateSAMLEmailsConfig) resp) + && ( ((.status) <$> responseJsonMaybe @(LockableFeature ValidateSAMLEmailsConfig) resp) == Just FeatureStatusEnabled ) ) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 97b3e704117..4704ce94f14 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -70,7 +70,7 @@ import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Named (Named (Named)) -import Wire.API.Team.Feature hiding (setStatus) +import Wire.API.Team.Feature import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Search diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index ffc0aeafdd8..645d853bcbc 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -106,7 +106,7 @@ tests s = ] defConfCalling :: LockableFeature ConferenceCallingConfig -defConfCalling = setStatus FeatureStatusDisabled defFeatureStatus +defConfCalling = defFeatureStatus {status = FeatureStatusDisabled} testRudSsoDomainRedirect :: TestM () testRudSsoDomainRedirect = do @@ -279,10 +279,10 @@ testFeatureConfig = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @cfg tid liftIO $ cfg @?= defFeatureStatus @cfg - let newStatus = if wsStatus cfg == FeatureStatusEnabled then FeatureStatusDisabled else FeatureStatusEnabled - putFeatureConfig @cfg tid (setStatus newStatus cfg) !!! const 200 === statusCode + let newStatus = if cfg.status == FeatureStatusEnabled then FeatureStatusDisabled else FeatureStatusEnabled + putFeatureConfig @cfg tid cfg {status = newStatus} !!! const 200 === statusCode cfg' <- getFeatureConfig @cfg tid - liftIO $ wsStatus cfg' @?= newStatus + liftIO $ cfg'.status @?= newStatus testGetFeatureConfig :: forall cfg. @@ -298,7 +298,7 @@ testGetFeatureConfig :: testGetFeatureConfig mDef = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @cfg tid - liftIO $ wsStatus cfg @?= fromMaybe (wsStatus $ defFeatureStatus @cfg) mDef + liftIO $ cfg.status @?= fromMaybe (defFeatureStatus @cfg).status mDef testFeatureStatus :: forall cfg. @@ -328,11 +328,11 @@ testFeatureStatusOptTtl defValue mTtl = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @cfg tid liftIO $ cfg @?= defValue - when (wsLockStatus cfg == LockStatusLocked) $ unlockFeature @cfg tid - let newStatus = if wsStatus cfg == FeatureStatusEnabled then FeatureStatusDisabled else FeatureStatusEnabled + when (cfg.lockStatus == LockStatusLocked) $ unlockFeature @cfg tid + let newStatus = if cfg.status == FeatureStatusEnabled then FeatureStatusDisabled else FeatureStatusEnabled putFeatureStatus @cfg tid newStatus mTtl !!! const 200 === statusCode cfg' <- getFeatureConfig @cfg tid - liftIO $ wsStatus cfg' @?= newStatus + liftIO $ cfg'.status @?= newStatus testFeatureStatusWithLock :: forall cfg. @@ -351,28 +351,28 @@ testFeatureStatusWithLock = do cfg @?= defFeatureStatus @cfg -- if either of these two lines fails, it's probably because the default is surprising. -- in that case, make the text more flexible. - wsLockStatus cfg @?= LockStatusLocked - wsStatus cfg @?= FeatureStatusDisabled + cfg.lockStatus @?= LockStatusLocked + cfg.status @?= FeatureStatusDisabled void $ putFeatureStatusLock @cfg tid LockStatusUnlocked mTtl getFeatureConfig @cfg tid >>= \cfg -> liftIO $ do - wsLockStatus cfg @?= LockStatusUnlocked - wsStatus cfg @?= FeatureStatusDisabled + cfg.lockStatus @?= LockStatusUnlocked + cfg.status @?= FeatureStatusDisabled void $ putFeatureStatus @cfg tid FeatureStatusEnabled Nothing getFeatureConfig @cfg tid >>= \cfg -> liftIO $ do - wsLockStatus cfg @?= LockStatusUnlocked - wsStatus cfg @?= FeatureStatusEnabled + cfg.lockStatus @?= LockStatusUnlocked + cfg.status @?= FeatureStatusEnabled void $ putFeatureStatusLock @cfg tid LockStatusLocked mTtl getFeatureConfig @cfg tid >>= \cfg -> liftIO $ do - wsLockStatus cfg @?= LockStatusLocked - wsStatus cfg @?= FeatureStatusDisabled + cfg.lockStatus @?= LockStatusLocked + cfg.status @?= FeatureStatusDisabled void $ putFeatureStatusLock @cfg tid LockStatusUnlocked mTtl getFeatureConfig @cfg tid >>= \cfg -> liftIO $ do - wsLockStatus cfg @?= LockStatusUnlocked - wsStatus cfg @?= FeatureStatusEnabled + cfg.lockStatus @?= LockStatusUnlocked + cfg.status @?= FeatureStatusEnabled testGetConsentLog :: TestM () testGetConsentLog = do From d1b6aa5e4c03e1abb2eef9d0621fd033e801e5b5 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 1 Aug 2024 17:03:41 +0200 Subject: [PATCH 03/34] Cleanup LockableFeaturePatch --- libs/wire-api/src/Wire/API/Team/Feature.hs | 59 ++++++------------- .../Generated/LockableFeaturePatch_team.hs | 41 ++++++------- services/brig/src/Brig/Provider/API.hs | 2 +- services/brig/src/Brig/User/Auth.hs | 2 +- .../galley/src/Galley/API/Teams/Features.hs | 10 ++-- services/galley/test/integration/API.hs | 3 +- tools/stern/src/Stern/API.hs | 4 +- tools/stern/src/Stern/Intra.hs | 22 ------- tools/stern/test/integration/API.hs | 5 +- 9 files changed, 51 insertions(+), 97 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index dbc05567f03..1fccf9ef1f3 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -37,15 +37,9 @@ module Wire.API.Team.Feature LockableFeature (..), defUnlockedFeature, defLockedFeature, - withStatus', setConfig', setTTL, - LockableFeaturePatch, - wsPatch, - wspStatus, - wspLockStatus, - wspConfig, - wspTTL, + LockableFeaturePatch (..), Feature (..), forgetLock, withLockStatus, @@ -343,52 +337,33 @@ instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeature cfg) ---------------------------------------------------------------------- -- LockableFeaturePatch -type LockableFeaturePatch (cfg :: Type) = LockableFeatureBase Maybe cfg - -deriving instance (Eq cfg) => Eq (LockableFeaturePatch cfg) - -deriving instance (Show cfg) => Show (LockableFeaturePatch cfg) - -deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg)) => ToJSON (LockableFeaturePatch cfg) - -deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg)) => FromJSON (LockableFeaturePatch cfg) - -deriving via (Schema (LockableFeaturePatch cfg)) instance (ToSchema (LockableFeaturePatch cfg), Typeable cfg) => S.ToSchema (LockableFeaturePatch cfg) - -wsPatch :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> LockableFeaturePatch cfg -wsPatch = LockableFeatureBase - -wspStatus :: LockableFeaturePatch cfg -> Maybe FeatureStatus -wspStatus = wsbStatus - -wspLockStatus :: LockableFeaturePatch cfg -> Maybe LockStatus -wspLockStatus = wsbLockStatus - -wspConfig :: LockableFeaturePatch cfg -> Maybe cfg -wspConfig = wsbConfig - -wspTTL :: LockableFeaturePatch cfg -> Maybe FeatureTTL -wspTTL = wsbTTL - -withStatus' :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> Maybe FeatureTTL -> LockableFeaturePatch cfg -withStatus' = LockableFeatureBase +data LockableFeaturePatch (cfg :: Type) = LockableFeaturePatch + { status :: Maybe FeatureStatus, + lockStatus :: Maybe LockStatus, + config :: Maybe cfg + } + deriving stock (Eq, Show) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (LockableFeaturePatch cfg)) -- | The ToJSON implementation of `LockableFeaturePatch` will encode the trivial config as `"config": {}` -- when the value is a `Just`, if it's `Nothing` it will be omitted, which is the important part. instance (ToSchema cfg) => ToSchema (LockableFeaturePatch cfg) where schema = object name $ - LockableFeatureBase - <$> wsbStatus .= maybe_ (optField "status" schema) - <*> wsbLockStatus .= maybe_ (optField "lockStatus" schema) - <*> wsbConfig .= maybe_ (optField "config" schema) - <*> wsbTTL .= maybe_ (optField "ttl" schema) + LockableFeaturePatch + <$> (.status) .= maybe_ (optField "status" schema) + <*> (.lockStatus) .= maybe_ (optField "lockStatus" schema) + <*> (.config) .= maybe_ (optField "config" schema) + <* const FeatureTTLUnlimited + .= optField + "ttl" + (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) where inner = schema @cfg name = fromMaybe "" (getName (schemaDoc inner)) <> ".LockableFeaturePatch" instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeaturePatch cfg) where - arbitrary = LockableFeatureBase <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = LockableFeaturePatch <$> arbitrary <*> arbitrary <*> arbitrary ---------------------------------------------------------------------- -- Feature diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs index 638ea52475b..478398eb383 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/LockableFeaturePatch_team.hs @@ -24,61 +24,58 @@ import Imports import Wire.API.Team.Feature testObject_LockableFeaturePatch_team_1 :: LockableFeaturePatch AppLockConfig -testObject_LockableFeaturePatch_team_1 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (AppLockConfig (EnforceAppLock False) (-98))) +testObject_LockableFeaturePatch_team_1 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (AppLockConfig (EnforceAppLock False) (-98))) testObject_LockableFeaturePatch_team_2 :: LockableFeaturePatch AppLockConfig -testObject_LockableFeaturePatch_team_2 = withStatus Nothing Nothing (Just (AppLockConfig (EnforceAppLock True) 0)) +testObject_LockableFeaturePatch_team_2 = LockableFeaturePatch Nothing Nothing (Just (AppLockConfig (EnforceAppLock True) 0)) testObject_LockableFeaturePatch_team_3 :: LockableFeaturePatch AppLockConfig -testObject_LockableFeaturePatch_team_3 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (AppLockConfig (EnforceAppLock True) 111)) +testObject_LockableFeaturePatch_team_3 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (AppLockConfig (EnforceAppLock True) 111)) testObject_LockableFeaturePatch_team_4 :: LockableFeaturePatch SelfDeletingMessagesConfig -testObject_LockableFeaturePatch_team_4 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig (-97))) +testObject_LockableFeaturePatch_team_4 = LockableFeaturePatch (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig (-97))) testObject_LockableFeaturePatch_team_5 :: LockableFeaturePatch SelfDeletingMessagesConfig -testObject_LockableFeaturePatch_team_5 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (SelfDeletingMessagesConfig 0)) +testObject_LockableFeaturePatch_team_5 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (SelfDeletingMessagesConfig 0)) testObject_LockableFeaturePatch_team_6 :: LockableFeaturePatch SelfDeletingMessagesConfig -testObject_LockableFeaturePatch_team_6 = withStatus (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig 77)) +testObject_LockableFeaturePatch_team_6 = LockableFeaturePatch (Just FeatureStatusEnabled) Nothing (Just (SelfDeletingMessagesConfig 77)) testObject_LockableFeaturePatch_team_7 :: LockableFeaturePatch ClassifiedDomainsConfig -testObject_LockableFeaturePatch_team_7 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [])) +testObject_LockableFeaturePatch_team_7 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [])) testObject_LockableFeaturePatch_team_8 :: LockableFeaturePatch ClassifiedDomainsConfig -testObject_LockableFeaturePatch_team_8 = withStatus Nothing (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"])) +testObject_LockableFeaturePatch_team_8 = LockableFeaturePatch Nothing (Just LockStatusLocked) (Just (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"])) testObject_LockableFeaturePatch_team_9 :: LockableFeaturePatch ClassifiedDomainsConfig -testObject_LockableFeaturePatch_team_9 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (ClassifiedDomainsConfig [Domain "test.foobar"])) +testObject_LockableFeaturePatch_team_9 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just (ClassifiedDomainsConfig [Domain "test.foobar"])) testObject_LockableFeaturePatch_team_10 :: LockableFeaturePatch SSOConfig -testObject_LockableFeaturePatch_team_10 = withStatus (Just FeatureStatusDisabled) (Just LockStatusLocked) (Just SSOConfig) +testObject_LockableFeaturePatch_team_10 = LockableFeaturePatch (Just FeatureStatusDisabled) (Just LockStatusLocked) (Just SSOConfig) testObject_LockableFeaturePatch_team_11 :: LockableFeaturePatch SearchVisibilityAvailableConfig -testObject_LockableFeaturePatch_team_11 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just SearchVisibilityAvailableConfig) +testObject_LockableFeaturePatch_team_11 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just SearchVisibilityAvailableConfig) testObject_LockableFeaturePatch_team_12 :: LockableFeaturePatch ValidateSAMLEmailsConfig -testObject_LockableFeaturePatch_team_12 = withStatus (Just FeatureStatusDisabled) Nothing (Just ValidateSAMLEmailsConfig) +testObject_LockableFeaturePatch_team_12 = LockableFeaturePatch (Just FeatureStatusDisabled) Nothing (Just ValidateSAMLEmailsConfig) testObject_LockableFeaturePatch_team_13 :: LockableFeaturePatch DigitalSignaturesConfig -testObject_LockableFeaturePatch_team_13 = withStatus (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just DigitalSignaturesConfig) +testObject_LockableFeaturePatch_team_13 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusLocked) (Just DigitalSignaturesConfig) testObject_LockableFeaturePatch_team_14 :: LockableFeaturePatch ConferenceCallingConfig -testObject_LockableFeaturePatch_team_14 = withStatus Nothing (Just LockStatusUnlocked) (Just (ConferenceCallingConfig One2OneCallsSft)) +testObject_LockableFeaturePatch_team_14 = LockableFeaturePatch Nothing (Just LockStatusUnlocked) (Just (ConferenceCallingConfig One2OneCallsSft)) testObject_LockableFeaturePatch_team_15 :: LockableFeaturePatch GuestLinksConfig -testObject_LockableFeaturePatch_team_15 = withStatus (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just GuestLinksConfig) +testObject_LockableFeaturePatch_team_15 = LockableFeaturePatch (Just FeatureStatusEnabled) (Just LockStatusUnlocked) (Just GuestLinksConfig) testObject_LockableFeaturePatch_team_16 :: LockableFeaturePatch SndFactorPasswordChallengeConfig -testObject_LockableFeaturePatch_team_16 = withStatus (Just FeatureStatusDisabled) (Just LockStatusUnlocked) (Just SndFactorPasswordChallengeConfig) +testObject_LockableFeaturePatch_team_16 = LockableFeaturePatch (Just FeatureStatusDisabled) (Just LockStatusUnlocked) (Just SndFactorPasswordChallengeConfig) testObject_LockableFeaturePatch_team_17 :: LockableFeaturePatch SearchVisibilityInboundConfig -testObject_LockableFeaturePatch_team_17 = withStatus (Just FeatureStatusEnabled) Nothing (Just SearchVisibilityInboundConfig) +testObject_LockableFeaturePatch_team_17 = LockableFeaturePatch (Just FeatureStatusEnabled) Nothing (Just SearchVisibilityInboundConfig) testObject_LockableFeaturePatch_team_18 :: LockableFeaturePatch GuestLinksConfig -testObject_LockableFeaturePatch_team_18 = withStatus (Just FeatureStatusEnabled) Nothing Nothing +testObject_LockableFeaturePatch_team_18 = LockableFeaturePatch (Just FeatureStatusEnabled) Nothing Nothing testObject_LockableFeaturePatch_team_19 :: LockableFeaturePatch SelfDeletingMessagesConfig -testObject_LockableFeaturePatch_team_19 = withStatus Nothing (Just LockStatusUnlocked) Nothing - -withStatus :: Maybe FeatureStatus -> Maybe LockStatus -> Maybe cfg -> LockableFeaturePatch cfg -withStatus fs ls cfg = withStatus' fs ls cfg (Just FeatureTTLUnlimited) +testObject_LockableFeaturePatch_team_19 = LockableFeaturePatch Nothing (Just LockStatusUnlocked) Nothing diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 2bff95f36af..6a5fc4dec4c 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -804,7 +804,7 @@ guardSecondFactorDisabled :: Maybe UserId -> ExceptT HttpError (AppT r) () guardSecondFactorDisabled mbUserId = do - enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . Feature.status . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId + enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . (.status) . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId when enabled $ (throwStd (errorToWai @'E.AccessDenied)) minRsaKeySize :: Int diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index c2d349a2fc9..152ec6245ac 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -134,7 +134,7 @@ verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId - pure $ fromMaybe (Public.status (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled + pure $ fromMaybe ((.status) (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index b23d06c2005..0633bfbd7b4 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -98,15 +100,15 @@ patchFeatureStatusInternal tid patch = do let newFeatureStatus = applyPatch currentFeatureStatus -- setting the config can fail, so we need to do it first void $ setConfigForTeam @cfg tid (forgetLock newFeatureStatus) - when (isJust $ wspLockStatus patch) $ void $ updateLockStatus @cfg tid newFeatureStatus.lockStatus + when (isJust $ patch.lockStatus) $ void $ updateLockStatus @cfg tid newFeatureStatus.lockStatus getFeatureStatus @cfg DontDoAuth tid where applyPatch :: LockableFeature cfg -> LockableFeature cfg applyPatch current = current - { status = fromMaybe current.status (wspStatus patch), - lockStatus = fromMaybe current.lockStatus (wspLockStatus patch), - config = fromMaybe current.config (wspConfig patch) + { status = fromMaybe current.status patch.status, + lockStatus = fromMaybe current.lockStatus patch.lockStatus, + config = fromMaybe current.config patch.config } setFeatureStatus :: diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f7df98c8f52..e9e1957b1ab 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} @@ -1530,7 +1531,7 @@ getGuestLinksStatusFromForeignTeamConv = do let checkGuestLinksStatus u c s = getGuestLinkStatus galley u c !!! do const 200 === statusCode - const s === (Public.status . (responseJsonUnsafe @(Public.LockableFeature Public.GuestLinksConfig))) + const s === ((.status) . (responseJsonUnsafe @(Public.LockableFeature Public.GuestLinksConfig))) let checkGetGuestLinksStatus s u c = getGuestLinkStatus galley u c !!! do const s === statusCode diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 4704ce94f14..611b366ca08 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -350,8 +350,8 @@ mkFeaturePutRouteTrivialConfigWithTTL tid status = mkFeaturePutRouteTrivialConfi mkFeaturePutRouteTrivialConfig :: forall cfg. (MkFeaturePutConstraints cfg) => TeamId -> FeatureStatus -> Maybe FeatureTTLDays -> Handler NoContent -mkFeaturePutRouteTrivialConfig tid status (fmap convertFeatureTTLDaysToSeconds -> ttl) = do - let patch = wsPatch (Just status) Nothing Nothing ttl +mkFeaturePutRouteTrivialConfig tid status _ = do + let patch = LockableFeaturePatch (Just status) Nothing Nothing NoContent <$ Intra.patchTeamFeatureFlag @cfg tid patch getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 0a3670d5c0a..14e2c62e1fc 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -532,7 +532,6 @@ setTeamFeatureFlag :: Handler () setTeamFeatureFlag tid status = do info $ msg "Setting team feature status" - checkDaysLimit (wssTTL status) galleyRpc $ method PUT . Bilge.paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] @@ -549,7 +548,6 @@ patchTeamFeatureFlag :: Handler () patchTeamFeatureFlag tid patch = do info $ msg "Patching team feature status" - for_ (wspTTL patch) $ \ttl -> checkDaysLimit ttl galleyRpc $ method PATCH . Bilge.paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @cfg] @@ -566,26 +564,6 @@ galleyRpc req = do 403 -> throwE (mkError status403 "bad-upstream" "config cannot be changed") _ -> throwE (mkError status502 "bad-upstream" (errorMessage resp)) -checkDaysLimit :: FeatureTTL -> Handler () -checkDaysLimit = \case - FeatureTTLUnlimited -> pure () - FeatureTTLSeconds ((`div` (60 * 60 * 24)) -> days) -> do - unless (days <= daysLimit) $ do - throwE - ( mkError - status400 - "bad-data" - ( LT.pack $ - "ttl limit is " - <> show daysLimit - <> " days; I got " - <> show days - <> "." - ) - ) - where - daysLimit = 2000 - setTeamFeatureLockStatus :: forall cfg. ( KnownSymbol (Public.FeatureSymbol cfg) diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 645d853bcbc..1ebc6a80dcd 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedRecordDot #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- This file is part of the Wire Server implementation. -- From b8822a2011986a7d42d6cbecc2b10187c495d0ad Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 09:32:02 +0200 Subject: [PATCH 04/34] Remove FeatureLockBase --- libs/wire-api/src/Wire/API/Team/Feature.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 1fccf9ef1f3..9e2e22cba56 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -27,7 +27,6 @@ module Wire.API.Team.Feature featureName, featureNameBS, LockStatus (..), - LockableFeatureBase (..), DbFeature (..), DbFeatureWithLock (..), dbFeatureStatus, @@ -37,8 +36,6 @@ module Wire.API.Team.Feature LockableFeature (..), defUnlockedFeature, defLockedFeature, - setConfig', - setTTL, LockableFeaturePatch (..), Feature (..), forgetLock, @@ -222,23 +219,6 @@ featureName = T.pack $ symbolVal (Proxy @(FeatureSymbol cfg)) featureNameBS :: forall cfg. (KnownSymbol (FeatureSymbol cfg)) => ByteString featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg)) ----------------------------------------------------------------------- --- LockableFeatureBase - -data LockableFeatureBase (m :: Type -> Type) (cfg :: Type) = LockableFeatureBase - { wsbStatus :: m FeatureStatus, - wsbLockStatus :: m LockStatus, - wsbConfig :: m cfg, - wsbTTL :: m FeatureTTL - } - deriving stock (Generic, Typeable, Functor) - -setConfig' :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => cfg -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg -setConfig' c (LockableFeatureBase s ls _ ttl) = LockableFeatureBase s ls (pure c) ttl - -setTTL :: forall (m :: Type -> Type) (cfg :: Type). (Applicative m) => FeatureTTL -> LockableFeatureBase m cfg -> LockableFeatureBase m cfg -setTTL ttl (LockableFeatureBase s ls c _) = LockableFeatureBase s ls c (pure ttl) - -------------------------------------------------------------------------------- -- DbFeature From 3de1a1f34490dcd05e28a433f9700e5b3a2ca0c4 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 10:22:45 +0200 Subject: [PATCH 05/34] Cleanup Feature --- libs/wire-api/src/Wire/API/Team/Feature.hs | 30 +++--- .../Wire/API/Golden/Generated/Feature_team.hs | 34 +++--- services/brig/src/Brig/Data/User.hs | 7 +- .../brig/test/integration/API/Provider.hs | 2 +- .../brig/test/integration/API/Team/Util.hs | 6 +- .../brig/test/integration/API/User/Util.hs | 2 +- .../galley/src/Galley/API/LegalHold/Team.hs | 3 +- .../galley/src/Galley/API/Teams/Features.hs | 52 ++++----- .../src/Galley/API/Teams/Features/Get.hs | 4 +- .../Cassandra/GetAllTeamFeatureConfigs.hs | 3 +- .../src/Galley/Cassandra/TeamFeatures.hs | 102 +++++++++--------- services/galley/test/integration/API.hs | 12 +-- services/galley/test/integration/API/Teams.hs | 16 ++- .../API/Teams/LegalHold/DisabledByDefault.hs | 25 ++--- .../integration/API/Teams/LegalHold/Util.hs | 2 +- .../test/integration/API/Util/TeamFeature.hs | 2 +- .../Test/Spar/Scim/AuthSpec.hs | 2 +- services/spar/test-integration/Util/Core.hs | 2 +- services/spar/test-integration/Util/Email.hs | 2 +- 19 files changed, 146 insertions(+), 162 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 9e2e22cba56..c3302ffc00a 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -30,7 +30,6 @@ module Wire.API.Team.Feature DbFeature (..), DbFeatureWithLock (..), dbFeatureStatus, - dbFeatureTTL, dbFeatureConfig, dbFeatureModConfig, LockableFeature (..), @@ -233,16 +232,13 @@ instance Monoid (DbFeature cfg) where mempty = DbFeature id dbFeatureStatus :: FeatureStatus -> DbFeature cfg -dbFeatureStatus s = DbFeature $ \w -> w {wssStatus = s} - -dbFeatureTTL :: FeatureTTL -> DbFeature cfg -dbFeatureTTL ttl = DbFeature $ \w -> w {wssTTL = ttl} +dbFeatureStatus s = DbFeature $ \w -> w {status = s} dbFeatureConfig :: cfg -> DbFeature cfg -dbFeatureConfig c = DbFeature $ \w -> w {wssConfig = c} +dbFeatureConfig c = DbFeature $ \w -> w {config = c} dbFeatureModConfig :: (cfg -> cfg) -> DbFeature cfg -dbFeatureModConfig f = DbFeature $ \w -> w {wssConfig = f (wssConfig w)} +dbFeatureModConfig f = DbFeature $ \w -> w {config = f w.config} data DbFeatureWithLock cfg = DbFeatureWithLock { lockStatus :: Maybe LockStatus, @@ -349,21 +345,20 @@ instance (Arbitrary cfg, IsFeatureConfig cfg) => Arbitrary (LockableFeaturePatch -- Feature data Feature (cfg :: Type) = Feature - { wssStatus :: FeatureStatus, - wssConfig :: cfg, - wssTTL :: FeatureTTL + { status :: FeatureStatus, + config :: cfg } deriving stock (Eq, Show, Generic, Typeable, Functor) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema (Feature cfg)) instance (Arbitrary cfg) => Arbitrary (Feature cfg) where - arbitrary = Feature <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = Feature <$> arbitrary <*> arbitrary forgetLock :: LockableFeature a -> Feature a -forgetLock ws = Feature ws.status ws.config FeatureTTLUnlimited +forgetLock ws = Feature ws.status ws.config withLockStatus :: LockStatus -> Feature a -> LockableFeature a -withLockStatus ls (Feature s c _ttl) = LockableFeature s ls c +withLockStatus ls (Feature s c) = LockableFeature s ls c withUnlocked :: Feature a -> LockableFeature a withUnlocked = withLockStatus LockStatusUnlocked @@ -375,9 +370,12 @@ instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (Feature cfg) where schema = object name $ Feature - <$> wssStatus .= field "status" schema - <*> wssConfig .= objectSchema @cfg - <*> wssTTL .= (fromMaybe FeatureTTLUnlimited <$> optField "ttl" schema) + <$> (.status) .= field "status" schema + <*> (.config) .= objectSchema @cfg + <* const FeatureTTLUnlimited + .= optField + "ttl" + (schema :: ValueSchema NamedSwaggerDoc FeatureTTL) where inner = schema @cfg name = fromMaybe "" (getName (schemaDoc inner)) <> ".Feature" diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs index fe0e1ad6d33..540fa355c3f 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Feature_team.hs @@ -24,52 +24,52 @@ import Imports import Wire.API.Team.Feature testObject_Feature_team_1 :: Feature AppLockConfig -testObject_Feature_team_1 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock False) (-98)) FeatureTTLUnlimited +testObject_Feature_team_1 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock False) (-98)) testObject_Feature_team_2 :: Feature AppLockConfig -testObject_Feature_team_2 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 0) FeatureTTLUnlimited +testObject_Feature_team_2 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 0) testObject_Feature_team_3 :: Feature AppLockConfig -testObject_Feature_team_3 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 111) FeatureTTLUnlimited +testObject_Feature_team_3 = Feature FeatureStatusEnabled (AppLockConfig (EnforceAppLock True) 111) testObject_Feature_team_4 :: Feature SelfDeletingMessagesConfig -testObject_Feature_team_4 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig (-97)) FeatureTTLUnlimited +testObject_Feature_team_4 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig (-97)) testObject_Feature_team_5 :: Feature SelfDeletingMessagesConfig -testObject_Feature_team_5 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 0) FeatureTTLUnlimited +testObject_Feature_team_5 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 0) testObject_Feature_team_6 :: Feature SelfDeletingMessagesConfig -testObject_Feature_team_6 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 77) FeatureTTLUnlimited +testObject_Feature_team_6 = Feature FeatureStatusEnabled (SelfDeletingMessagesConfig 77) testObject_Feature_team_7 :: Feature ClassifiedDomainsConfig -testObject_Feature_team_7 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig []) FeatureTTLUnlimited +testObject_Feature_team_7 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig []) testObject_Feature_team_8 :: Feature ClassifiedDomainsConfig -testObject_Feature_team_8 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) FeatureTTLUnlimited +testObject_Feature_team_8 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "example.com", Domain "test.foobar"]) testObject_Feature_team_9 :: Feature ClassifiedDomainsConfig -testObject_Feature_team_9 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "test.foobar"]) FeatureTTLUnlimited +testObject_Feature_team_9 = Feature FeatureStatusEnabled (ClassifiedDomainsConfig [Domain "test.foobar"]) testObject_Feature_team_10 :: Feature SSOConfig -testObject_Feature_team_10 = Feature FeatureStatusDisabled SSOConfig FeatureTTLUnlimited +testObject_Feature_team_10 = Feature FeatureStatusDisabled SSOConfig testObject_Feature_team_11 :: Feature SearchVisibilityAvailableConfig -testObject_Feature_team_11 = Feature FeatureStatusEnabled SearchVisibilityAvailableConfig FeatureTTLUnlimited +testObject_Feature_team_11 = Feature FeatureStatusEnabled SearchVisibilityAvailableConfig testObject_Feature_team_12 :: Feature ValidateSAMLEmailsConfig -testObject_Feature_team_12 = Feature FeatureStatusDisabled ValidateSAMLEmailsConfig FeatureTTLUnlimited +testObject_Feature_team_12 = Feature FeatureStatusDisabled ValidateSAMLEmailsConfig testObject_Feature_team_13 :: Feature DigitalSignaturesConfig -testObject_Feature_team_13 = Feature FeatureStatusEnabled DigitalSignaturesConfig FeatureTTLUnlimited +testObject_Feature_team_13 = Feature FeatureStatusEnabled DigitalSignaturesConfig testObject_Feature_team_14 :: Feature ConferenceCallingConfig -testObject_Feature_team_14 = Feature FeatureStatusDisabled (ConferenceCallingConfig One2OneCallsSft) FeatureTTLUnlimited +testObject_Feature_team_14 = Feature FeatureStatusDisabled (ConferenceCallingConfig One2OneCallsSft) testObject_Feature_team_15 :: Feature GuestLinksConfig -testObject_Feature_team_15 = Feature FeatureStatusEnabled GuestLinksConfig FeatureTTLUnlimited +testObject_Feature_team_15 = Feature FeatureStatusEnabled GuestLinksConfig testObject_Feature_team_16 :: Feature SndFactorPasswordChallengeConfig -testObject_Feature_team_16 = Feature FeatureStatusDisabled SndFactorPasswordChallengeConfig FeatureTTLUnlimited +testObject_Feature_team_16 = Feature FeatureStatusDisabled SndFactorPasswordChallengeConfig testObject_Feature_team_17 :: Feature SearchVisibilityInboundConfig -testObject_Feature_team_17 = Feature FeatureStatusEnabled SearchVisibilityInboundConfig FeatureTTLUnlimited +testObject_Feature_team_17 = Feature FeatureStatusEnabled SearchVisibilityInboundConfig diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index df384839c08..6b95fa2ebdd 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-ambiguous-fields #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. -- @@ -301,7 +302,7 @@ updateRichInfo u ri = retry x5 $ write userRichInfoUpdate (params LocalQuorum (r updateFeatureConferenceCalling :: (MonadClient m) => UserId -> Maybe (ApiFt.Feature ApiFt.ConferenceCallingConfig) -> m (Maybe (ApiFt.Feature ApiFt.ConferenceCallingConfig)) updateFeatureConferenceCalling uid mbStatus = do - let flag = ApiFt.wssStatus <$> mbStatus + let flag = (.status) <$> mbStatus retry x5 $ write update (params LocalQuorum (flag, uid)) pure mbStatus where @@ -442,7 +443,7 @@ lookupFeatureConferenceCalling uid = do mStatusValue <- (>>= runIdentity) <$> retry x1 q case mStatusValue of Nothing -> pure Nothing - Just status -> pure $ Just $ ApiFt.defFeatureStatusNoLock {ApiFt.wssStatus = status} + Just status -> pure $ Just $ ApiFt.defFeatureStatusNoLock {ApiFt.status = status} where select :: PrepQuery R (Identity UserId) (Identity (Maybe ApiFt.FeatureStatus)) select = fromString "select feature_conference_calling from user where id = ?" diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index cde489da5b8..f803d6a988a 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1580,7 +1580,7 @@ enabled2ndFaForTeamInternal galley tid = do ( galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson - . Bilge.json (Public.Feature Public.FeatureStatusEnabled Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited) + . Bilge.json (Public.Feature Public.FeatureStatusEnabled Public.SndFactorPasswordChallengeConfig) ) !!! const 200 === statusCode diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 202aa228f1e..9a862fba44a 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -266,7 +266,7 @@ putLegalHoldEnabled tid enabled g = do g . paths ["i", "teams", toByteString' tid, "features", "legalhold"] . contentJson - . lbytes (encode (Public.Feature enabled Public.LegalholdConfig Public.FeatureTTLUnlimited)) + . lbytes (encode (Public.Feature enabled Public.LegalholdConfig)) . expect2xx putLHWhitelistTeam :: (HasCallStack) => Galley -> TeamId -> Http ResponseLBS @@ -436,7 +436,7 @@ setTeamTeamSearchVisibilityAvailable galley tid status = ( galley . paths ["i/teams", toByteString' tid, "features/searchVisibility"] . contentJson - . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) + . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityAvailableConfig) ) !!! do const 200 === statusCode @@ -458,7 +458,7 @@ setTeamSearchVisibilityInboundAvailable galley tid status = ( galley . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SearchVisibilityInboundConfig] . contentJson - . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityInboundConfig Public.FeatureTTLUnlimited) + . body (RequestBodyLBS . encode $ Public.Feature status Public.SearchVisibilityInboundConfig) ) !!! do const 200 === statusCode diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index b52f8ae8659..8a1c1004ad9 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -441,7 +441,7 @@ generateVerificationCode' brig req = do setTeamSndFactorPasswordChallenge :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Galley -> TeamId -> Public.FeatureStatus -> m () setTeamSndFactorPasswordChallenge galley tid status = do - let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode setTeamFeatureLockStatus :: diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index c7052c2d8bc..792d4be0359 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -63,8 +63,7 @@ computeLegalHoldFeatureStatus tid dbFeature = getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure FeatureStatusDisabled FeatureLegalHoldDisabledByDefault -> - pure . wssStatus $ - unDbFeature dbFeature defFeatureStatusNoLock + pure (unDbFeature dbFeature defFeatureStatusNoLock).status FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do wl <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if wl then FeatureStatusEnabled else FeatureStatusDisabled diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 0633bfbd7b4..46d205b468a 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -130,7 +130,7 @@ setFeatureStatus :: TeamId -> Feature cfg -> Sem r (LockableFeature cfg) -setFeatureStatus doauth tid wsnl = do +setFeatureStatus doauth tid feat = do case doauth of DoAuth uid -> do zusrMembership <- getTeamMember tid uid @@ -138,7 +138,7 @@ setFeatureStatus doauth tid wsnl = do DontDoAuth -> assertTeamExists tid guardLockStatus . (.lockStatus) =<< getConfigForTeam @cfg tid - setConfigForTeam @cfg tid wsnl + setConfigForTeam @cfg tid feat setFeatureStatusInternal :: forall cfg r. @@ -190,8 +190,8 @@ persistAndPushEvent :: TeamId -> Feature cfg -> Sem r (LockableFeature cfg) -persistAndPushEvent tid wsnl = do - setFeatureConfig (featureSingleton @cfg) tid wsnl +persistAndPushEvent tid feat = do + setFeatureConfig (featureSingleton @cfg) tid feat fs <- getConfigForTeam @cfg tid pushFeatureConfigEvent tid (Event.mkUpdateEvent fs) pure fs @@ -264,7 +264,7 @@ class (GetFeatureConfig cfg) => SetFeatureConfig cfg where TeamId -> Feature cfg -> Sem r (LockableFeature cfg) - setConfigForTeam tid wsnl = persistAndPushEvent tid wsnl + setConfigForTeam tid feat = persistAndPushEvent tid feat instance SetFeatureConfig SSOConfig where type @@ -273,11 +273,11 @@ instance SetFeatureConfig SSOConfig where Member (Error TeamFeatureError) r ) - setConfigForTeam tid wsnl = do - case wssStatus wsnl of + setConfigForTeam tid feat = do + case feat.status of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> throw DisableSsoNotImplemented - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig SearchVisibilityAvailableConfig where type @@ -286,11 +286,11 @@ instance SetFeatureConfig SearchVisibilityAvailableConfig where Member (Input Opts) r ) - setConfigForTeam tid wsnl = do - case wssStatus wsnl of + setConfigForTeam tid feat = do + case feat.status of FeatureStatusEnabled -> pure () FeatureStatusDisabled -> SearchVisibilityData.resetSearchVisibility tid - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig ValidateSAMLEmailsConfig @@ -337,7 +337,7 @@ instance SetFeatureConfig LegalholdConfig where ) -- we're good to update the status now. - setConfigForTeam tid wsnl = do + setConfigForTeam tid feat = do -- this extra do is to encapsulate the assertions running before the actual operation. -- enabling LH for teams is only allowed in normal operation; disabled-permanently and -- whitelist-teams have no or their own way to do that, resp. @@ -350,20 +350,20 @@ instance SetFeatureConfig LegalholdConfig where FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do throw LegalHoldWhitelistedOnly - case wssStatus wsnl of + case feat.status of FeatureStatusDisabled -> LegalHold.removeSettings' @InternalPaging tid FeatureStatusEnabled -> ensureNotTooLargeToActivateLegalHold tid - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig FileSharingConfig instance SetFeatureConfig AppLockConfig where type SetConfigForTeamConstraints AppLockConfig r = Member (Error TeamFeatureError) r - setConfigForTeam tid wsnl = do - when ((applockInactivityTimeoutSecs . wssConfig $ wsnl) < 30) $ + setConfigForTeam tid feat = do + when ((applockInactivityTimeoutSecs feat.config) < 30) $ throw AppLockInactivityTimeoutTooLow - persistAndPushEvent tid wsnl + persistAndPushEvent tid feat instance SetFeatureConfig ConferenceCallingConfig @@ -375,9 +375,9 @@ instance SetFeatureConfig SndFactorPasswordChallengeConfig instance SetFeatureConfig SearchVisibilityInboundConfig where type SetConfigForTeamConstraints SearchVisibilityInboundConfig (r :: EffectRow) = (Member BrigAccess r) - setConfigForTeam tid wsnl = do - updateSearchVisibilityInbound $ toTeamStatus tid wsnl - persistAndPushEvent tid wsnl + setConfigForTeam tid feat = do + updateSearchVisibilityInbound $ toTeamStatus tid feat + persistAndPushEvent tid feat instance SetFeatureConfig MLSConfig where type SetConfigForTeamConstraints MLSConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) @@ -385,9 +385,9 @@ instance SetFeatureConfig MLSConfig where mlsMigrationConfig <- getConfigForTeam @MlsMigrationConfig tid unless ( -- default protocol needs to be included in supported protocols - mlsDefaultProtocol (wssConfig feat) `elem` mlsSupportedProtocols (wssConfig feat) + feat.config.mlsDefaultProtocol `elem` feat.config.mlsSupportedProtocols -- when MLS migration is enabled, MLS needs to be enabled as well - && (mlsMigrationConfig.status == FeatureStatusDisabled || wssStatus feat == FeatureStatusEnabled) + && (mlsMigrationConfig.status == FeatureStatusDisabled || feat.status == FeatureStatusEnabled) ) $ throw MLSProtocolMismatch persistAndPushEvent tid feat @@ -406,9 +406,9 @@ guardMlsE2EIdConfig :: TeamId -> Feature MlsE2EIdConfig -> Sem r a -guardMlsE2EIdConfig handler uid tid conf = do - when (isNothing . crlProxy . wssConfig $ conf) $ throw MLSE2EIDMissingCrlProxy - handler uid tid conf +guardMlsE2EIdConfig handler uid tid feat = do + when (isNothing feat.config.crlProxy) $ throw MLSE2EIDMissingCrlProxy + handler uid tid feat instance SetFeatureConfig MlsMigrationConfig where type SetConfigForTeamConstraints MlsMigrationConfig (r :: EffectRow) = (Member (Error TeamFeatureError) r) @@ -416,7 +416,7 @@ instance SetFeatureConfig MlsMigrationConfig where mlsConfig <- getConfigForTeam @MLSConfig tid unless ( -- when MLS migration is enabled, MLS needs to be enabled as well - wssStatus feat == FeatureStatusDisabled || mlsConfig.status == FeatureStatusEnabled + feat.status == FeatureStatusDisabled || mlsConfig.status == FeatureStatusEnabled ) $ throw MLSProtocolMismatch persistAndPushEvent tid feat diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index 2395e6d9b1a..dde71493018 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -150,7 +150,7 @@ getFeatureStatusMulti (Multi.TeamFeatureNoConfigMultiRequest tids) = do pure $ Multi.TeamFeatureNoConfigMultiResponse xs toTeamStatus :: TeamId -> Feature cfg -> Multi.TeamStatus cfg -toTeamStatus tid ws = Multi.TeamStatus tid (wssStatus ws) +toTeamStatus tid feat = Multi.TeamStatus tid feat.status getTeamAndCheckMembership :: ( Member TeamStore r, @@ -464,7 +464,7 @@ instance GetFeatureConfig ConferenceCallingConfig where withUnlocked $ (unDbFeature dbFeature) (forgetLock defFeature) - { wssStatus = FeatureStatusEnabled + { status = FeatureStatusEnabled } instance GetFeatureConfig SelfDeletingMessagesConfig where diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index c55808c7823..45497346594 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -313,9 +313,8 @@ instance MakeFeature ClassifiedDomainsConfig instance MakeFeature ConferenceCallingConfig where type FeatureRow ConferenceCallingConfig = (Maybe FeatureStatus, Maybe FeatureTTL, Maybe One2OneCalls) - mkFeature (status, ttl, sftForOneToOne) = + mkFeature (status, _, sftForOneToOne) = foldMap dbFeatureStatus status - <> foldMap dbFeatureTTL ttl <> foldMap (dbFeatureConfig . ConferenceCallingConfig) sftForOneToOne instance MakeFeature SelfDeletingMessagesConfig where diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index d46c1db12a0..26dbc0c15a5 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -119,51 +119,51 @@ getFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid = getFeature "limited_event_fanout_status" tid setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () -setFeatureConfig FeatureSingletonLegalholdConfig tid statusNoLock = setFeatureStatusC "legalhold_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonSSOConfig tid statusNoLock = setFeatureStatusC "sso_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid statusNoLock = setFeatureStatusC "validate_saml_emails" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid _statusNoLock = pure () -setFeatureConfig FeatureSingletonDigitalSignaturesConfig tid statusNoLock = setFeatureStatusC "digital_signatures" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonAppLockConfig tid status = do - let enforce = applockEnforceAppLock (wssConfig status) - timeout = applockInactivityTimeoutSecs (wssConfig status) +setFeatureConfig FeatureSingletonLegalholdConfig tid feat = setFeatureStatusC "legalhold_status" tid feat.status +setFeatureConfig FeatureSingletonSSOConfig tid feat = setFeatureStatusC "sso_status" tid feat.status +setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid feat = setFeatureStatusC "search_visibility_status" tid feat.status +setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid feat = setFeatureStatusC "validate_saml_emails" tid feat.status +setFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid _feat = pure () +setFeatureConfig FeatureSingletonDigitalSignaturesConfig tid feat = setFeatureStatusC "digital_signatures" tid feat.status +setFeatureConfig FeatureSingletonAppLockConfig tid feat = do + let enforce = applockEnforceAppLock feat.config + timeout = applockInactivityTimeoutSecs feat.config - retry x5 $ write insert (params LocalQuorum (tid, wssStatus status, enforce, timeout)) + retry x5 $ write insert (params LocalQuorum (tid, feat.status, enforce, timeout)) where insert :: PrepQuery W (TeamId, FeatureStatus, EnforceAppLock, Int32) () insert = fromString $ "insert into team_features (team_id, app_lock_status, app_lock_enforce,\ \ app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" -setFeatureConfig FeatureSingletonFileSharingConfig tid statusNoLock = setFeatureStatusC "file_sharing" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid status = do - let statusValue = wssStatus status - timeout = sdmEnforcedTimeoutSeconds . wssConfig $ status +setFeatureConfig FeatureSingletonFileSharingConfig tid feat = setFeatureStatusC "file_sharing" tid feat.status +setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid feat = do + let statusValue = feat.status + timeout = sdmEnforcedTimeoutSeconds feat.config retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) where insert :: PrepQuery W (TeamId, FeatureStatus, Int32) () insert = "insert into team_features (team_id, self_deleting_messages_status,\ \ self_deleting_messages_ttl) values (?, ?, ?)" -setFeatureConfig FeatureSingletonConferenceCallingConfig tid statusNoLock = do +setFeatureConfig FeatureSingletonConferenceCallingConfig tid feat = do retry x5 . batch $ do setType BatchLogged setConsistency LocalQuorum - addPrepQuery insertStatus (tid, statusNoLock.wssStatus) - addPrepQuery insertConfig (tid, statusNoLock.wssConfig.one2OneCalls) + addPrepQuery insertStatus (tid, feat.status) + addPrepQuery insertConfig (tid, feat.config.one2OneCalls) where insertStatus :: PrepQuery W (TeamId, FeatureStatus) () insertStatus = "insert into team_features (team_id, conference_calling_status) values (?, ?)" insertConfig :: PrepQuery W (TeamId, One2OneCalls) () insertConfig = "insert into team_features (team_id, conference_calling_one_to_one) values (?, ?)" -setFeatureConfig FeatureSingletonGuestLinksConfig tid statusNoLock = setFeatureStatusC "guest_links_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid statusNoLock = - setFeatureStatusC "snd_factor_password_challenge_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid statusNoLock = setFeatureStatusC "search_visibility_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonMLSConfig tid statusNoLock = do - let status = wssStatus statusNoLock - let MLSConfig protocolToggleUsers defaultProtocol allowedCipherSuites defaultCipherSuite supportedProtocols = wssConfig statusNoLock +setFeatureConfig FeatureSingletonGuestLinksConfig tid feat = setFeatureStatusC "guest_links_status" tid feat.status +setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid feat = + setFeatureStatusC "snd_factor_password_challenge_status" tid feat.status +setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid feat = setFeatureStatusC "search_visibility_status" tid feat.status +setFeatureConfig FeatureSingletonMLSConfig tid feat = do + let status = feat.status + let MLSConfig protocolToggleUsers defaultProtocol allowedCipherSuites defaultCipherSuite supportedProtocols = feat.config retry x5 $ write insert @@ -183,39 +183,33 @@ setFeatureConfig FeatureSingletonMLSConfig tid statusNoLock = do insert = "insert into team_features (team_id, mls_status, mls_default_protocol, \ \mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols) values (?, ?, ?, ?, ?, ?, ?)" -setFeatureConfig FeatureSingletonMlsE2EIdConfig tid status = do - let statusValue = wssStatus status - vex = verificationExpiration . wssConfig $ status - mUrl = acmeDiscoveryUrl . wssConfig $ status - mCrlProxy = crlProxy . wssConfig $ status - useProxy = useProxyOnMobile . wssConfig $ status +setFeatureConfig FeatureSingletonMlsE2EIdConfig tid feat = do + let statusValue = feat.status + vex = verificationExpiration feat.config + mUrl = acmeDiscoveryUrl feat.config + mCrlProxy = crlProxy feat.config + useProxy = useProxyOnMobile feat.config retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl, mCrlProxy, useProxy)) where insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl, Maybe HttpsUrl, Bool) () insert = "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile) values (?, ?, ?, ?, ?, ?)" -setFeatureConfig FeatureSingletonMlsMigration tid status = do - let statusValue = wssStatus status - config = wssConfig status - - retry x5 $ write insert (params LocalQuorum (tid, statusValue, config.startTime, config.finaliseRegardlessAfter)) +setFeatureConfig FeatureSingletonMlsMigration tid feat = do + retry x5 $ write insert (params LocalQuorum (tid, feat.status, feat.config.startTime, feat.config.finaliseRegardlessAfter)) where insert :: PrepQuery W (TeamId, FeatureStatus, Maybe UTCTime, Maybe UTCTime) () insert = "insert into team_features (team_id, mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after) values (?, ?, ?, ?)" -setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid statusNoLock = setFeatureStatusC "expose_invitation_urls_to_team_admin" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid statusNoLock = setFeatureStatusC "outlook_cal_integration_status" tid (wssStatus statusNoLock) -setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid status = do - let statusValue = wssStatus status - config = wssConfig status - - retry x5 $ write insert (params LocalQuorum (tid, statusValue, config.enforcedDownloadLocation)) +setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid feat = setFeatureStatusC "expose_invitation_urls_to_team_admin" tid feat.status +setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid feat = setFeatureStatusC "outlook_cal_integration_status" tid feat.status +setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid feat = do + retry x5 $ write insert (params LocalQuorum (tid, feat.status, feat.config.enforcedDownloadLocation)) where insert :: PrepQuery W (TeamId, FeatureStatus, Maybe Text) () insert = "insert into team_features (team_id, enforce_file_download_location_status, enforce_file_download_location) values (?, ?, ?)" -setFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid statusNoLock = - setFeatureStatusC "limited_event_fanout_status" tid (wssStatus statusNoLock) +setFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid feat = + setFeatureStatusC "limited_event_fanout_status" tid feat.status getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) getFeatureLockStatus FeatureSingletonFileSharingConfig tid = getLockStatusC "file_sharing_lock_status" tid @@ -231,16 +225,16 @@ getFeatureLockStatus FeatureSingletonConferenceCallingConfig tid = getLockStatus getFeatureLockStatus _ _ = pure Nothing setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockStatus -> m () -setFeatureLockStatus FeatureSingletonFileSharingConfig tid status = setLockStatusC "file_sharing_lock_status" tid status -setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid status = setLockStatusC "self_deleting_messages_lock_status" tid status -setFeatureLockStatus FeatureSingletonGuestLinksConfig tid status = setLockStatusC "guest_links_lock_status" tid status -setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid status = setLockStatusC "snd_factor_password_challenge_lock_status" tid status -setFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid status = setLockStatusC "mls_e2eid_lock_status" tid status -setFeatureLockStatus FeatureSingletonMlsMigration tid status = setLockStatusC "mls_migration_lock_status" tid status -setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid status = setLockStatusC "outlook_cal_integration_lock_status" tid status -setFeatureLockStatus FeatureSingletonMLSConfig tid status = setLockStatusC "mls_lock_status" tid status -setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid status = setLockStatusC "enforce_file_download_location_lock_status" tid status -setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid status = setLockStatusC "conference_calling" tid status +setFeatureLockStatus FeatureSingletonFileSharingConfig tid feat = setLockStatusC "file_sharing_lock_status" tid feat +setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid feat = setLockStatusC "self_deleting_messages_lock_status" tid feat +setFeatureLockStatus FeatureSingletonGuestLinksConfig tid feat = setLockStatusC "guest_links_lock_status" tid feat +setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid feat = setLockStatusC "snd_factor_password_challenge_lock_status" tid feat +setFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid feat = setLockStatusC "mls_e2eid_lock_status" tid feat +setFeatureLockStatus FeatureSingletonMlsMigration tid feat = setLockStatusC "mls_migration_lock_status" tid feat +setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid feat = setLockStatusC "outlook_cal_integration_lock_status" tid feat +setFeatureLockStatus FeatureSingletonMLSConfig tid feat = setLockStatusC "mls_lock_status" tid feat +setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid feat = setLockStatusC "enforce_file_download_location_lock_status" tid feat +setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid feat = setLockStatusC "conference_calling" tid feat setFeatureLockStatus _ _tid _status = pure () getFeature :: diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index e9e1957b1ab..16fa23d97be 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -1177,7 +1177,7 @@ testGetCodeRejectedIfGuestLinksDisabled = do convId <- createConvWithGuestLink let checkGetCode expectedStatus = getConvCode owner convId !!! const expectedStatus === statusCode let setStatus tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig) !!! do const 200 === statusCode checkGetCode 200 @@ -1193,7 +1193,7 @@ testPostCodeRejectedIfGuestLinksDisabled = do convId <- decodeConvId <$> postTeamConv teamId owner [] (Just "testConversation") [CodeAccess] (Just noGuestsAccess) Nothing let checkPostCode expectedStatus = postConvCode owner convId !!! statusCode === const expectedStatus let setStatus tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId (Public.Feature tfStatus Public.GuestLinksConfig) !!! do const 200 === statusCode checkPostCode 201 @@ -1239,7 +1239,7 @@ testJoinTeamConvGuestLinksDisabled = do postJoinCodeConv bob cCode !!! const 200 === statusCode -- disabled guest links feature - let disabled = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited + let disabled = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId disabled !!! do const 200 === statusCode @@ -1258,7 +1258,7 @@ testJoinTeamConvGuestLinksDisabled = do checkFeatureStatus Public.FeatureStatusDisabled -- after re-enabling, the old link is still valid - let enabled = Public.Feature Public.FeatureStatusEnabled Public.GuestLinksConfig Public.FeatureTTLUnlimited + let enabled = Public.Feature Public.FeatureStatusEnabled Public.GuestLinksConfig TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId enabled !!! do const 200 === statusCode getJoinCodeConv eve' (conversationKey cCode) (conversationCode cCode) !!! do @@ -1286,7 +1286,7 @@ testJoinNonTeamConvGuestLinksDisabled = do const 200 === statusCode -- for non-team conversations it still works if status is disabled for the team but not server wide - let tfStatus = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig Public.FeatureTTLUnlimited + let tfStatus = Public.Feature Public.FeatureStatusDisabled Public.GuestLinksConfig TeamFeatures.putTeamFeature @Public.GuestLinksConfig owner teamId tfStatus !!! do const 200 === statusCode @@ -1526,7 +1526,7 @@ getGuestLinksStatusFromForeignTeamConv = do localDomain <- viewFederationDomain galley <- viewGalley let setTeamStatus u tid tfStatus = - TeamFeatures.putTeamFeature @Public.GuestLinksConfig u tid (Public.Feature tfStatus Public.GuestLinksConfig Public.FeatureTTLUnlimited) !!! do + TeamFeatures.putTeamFeature @Public.GuestLinksConfig u tid (Public.Feature tfStatus Public.GuestLinksConfig) !!! 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 70971405395..72bd68fa8e5 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -398,9 +398,8 @@ testEnableSSOPerTeam = do assertTeamActivate "create team" tid let check :: (HasCallStack) => String -> Public.FeatureStatus -> TestM () check msg enabledness = do - status :: Public.Feature Public.SSOConfig <- responseJsonUnsafe <$> (getSSOEnabledInternal tid (getSSOEnabledInternal tid TestM () putSSOEnabledInternalCheckNotImplemented = do g <- viewGalley @@ -409,7 +408,7 @@ testEnableSSOPerTeam = do <$> put ( g . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (Public.Feature Public.FeatureStatusDisabled Public.SSOConfig Public.FeatureTTLUnlimited) + . json (Public.Feature Public.FeatureStatusDisabled Public.SSOConfig) ) liftIO $ do assertEqual "bad status" status403 (Wai.code waierr) @@ -427,10 +426,9 @@ testEnableTeamSearchVisibilityPerTeam = do (tid, owner, member : _) <- Util.createBindingTeamWithMembers 2 let check :: String -> Public.FeatureStatus -> TestM () check msg enabledness = do - status :: Public.Feature Public.SearchVisibilityAvailableConfig <- responseJsonUnsafe <$> (Util.getTeamFeatureInternal @Public.SearchVisibilityAvailableConfig tid (Util.getTeamFeatureInternal @Public.SearchVisibilityAvailableConfig tid Public.FeatureStatus -> TestM () setTeamSndFactorPasswordChallenge tid status = do g <- viewGalley - let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature status Public.SndFactorPasswordChallengeConfig put (g . paths ["i", "teams", toByteString' tid, "features", Public.featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode getVerificationCode :: UserId -> Public.VerificationAction -> TestM Code.Value @@ -1745,7 +1743,7 @@ getSSOEnabledInternal = Util.getTeamFeatureInternal @Public.SSOConfig putSSOEnabledInternal :: (HasCallStack) => TeamId -> Public.FeatureStatus -> TestM () putSSOEnabledInternal tid statusValue = - void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.Feature statusValue Public.SSOConfig Public.FeatureTTLUnlimited) + void $ Util.putTeamFeatureInternal @Public.SSOConfig expect2xx tid (Public.Feature statusValue Public.SSOConfig) getSearchVisibility :: (HasCallStack) => (Request -> Request) -> UserId -> TeamId -> (MonadHttp m) => m ResponseLBS getSearchVisibility g uid tid = do diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index ec8fe35daa9..923a25b92e7 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -502,14 +502,12 @@ testEnablePerTeam = do member <- randomUser addTeamMemberInternal tid member (rolePermissions RoleMember) Nothing do - status :: Public.Feature Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid do grantConsent tid member requestLegalHoldDevice owner member tid !!! const 201 === statusCode @@ -519,9 +517,8 @@ testEnablePerTeam = do liftIO $ assertEqual "User legal hold status should be enabled" UserLegalHoldEnabled status do putEnabled tid Public.FeatureStatusDisabled -- disable again - status :: Public.Feature Public.LegalholdConfig <- responseJsonUnsafe <$> (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid (getEnabled tid UserId -> TeamId -> NewLegalHoldService -> TestM ResponseLBS diff --git a/services/galley/test/integration/API/Util/TeamFeature.hs b/services/galley/test/integration/API/Util/TeamFeature.hs index 9d23db90c19..873eb4e51ea 100644 --- a/services/galley/test/integration/API/Util/TeamFeature.hs +++ b/services/galley/test/integration/API/Util/TeamFeature.hs @@ -50,7 +50,7 @@ putTeamSearchVisibilityAvailableInternal tid statusValue = @Public.SearchVisibilityAvailableConfig expect2xx tid - (Public.Feature statusValue Public.SearchVisibilityAvailableConfig Public.FeatureTTLUnlimited) + (Public.Feature statusValue Public.SearchVisibilityAvailableConfig) putTeamFeatureInternal :: forall cfg m. diff --git a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs index d071c56940b..6f7983a10b9 100644 --- a/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/AuthSpec.hs @@ -151,7 +151,7 @@ unlockFeature galley tid = setSndFactorPasswordChallengeStatus :: GalleyReq -> TeamId -> Public.FeatureStatus -> TestSpar () setSndFactorPasswordChallengeStatus galley tid status = do - let js = RequestBodyLBS $ encode $ Public.Feature @Public.SndFactorPasswordChallengeConfig status Public.SndFactorPasswordChallengeConfig Public.FeatureTTLUnlimited + let js = RequestBodyLBS $ encode $ Public.Feature @Public.SndFactorPasswordChallengeConfig status Public.SndFactorPasswordChallengeConfig call $ put (galley . paths ["i", "teams", toByteString' tid, "features", featureNameBS @Public.SndFactorPasswordChallengeConfig] . contentJson . body js) !!! const 200 === statusCode diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index def3f87d466..250ef14efd4 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -385,7 +385,7 @@ putSSOEnabledInternal gly tid enabled = do void . put $ gly . paths ["i", "teams", toByteString' tid, "features", "sso"] - . json (Feature @SSOConfig enabled SSOConfig FeatureTTLUnlimited) + . json (Feature enabled SSOConfig) . expect2xx -- | cloned from `/services/brig/test/integration/API/Team/Util.hs`. diff --git a/services/spar/test-integration/Util/Email.hs b/services/spar/test-integration/Util/Email.hs index aa39af7cdd3..3d639e0c3b9 100644 --- a/services/spar/test-integration/Util/Email.hs +++ b/services/spar/test-integration/Util/Email.hs @@ -110,6 +110,6 @@ activate brig (k, c) = setSamlEmailValidation :: (HasCallStack) => TeamId -> Feature.FeatureStatus -> TestSpar () setSamlEmailValidation tid status = do galley <- view teGalley - let req = put $ galley . paths p . json (Feature.Feature @Feature.ValidateSAMLEmailsConfig status Feature.ValidateSAMLEmailsConfig Feature.FeatureTTLUnlimited) + let req = put $ galley . paths p . json (Feature.Feature @Feature.ValidateSAMLEmailsConfig status Feature.ValidateSAMLEmailsConfig) p = ["/i/teams", toByteString' tid, "features", Feature.featureNameBS @Feature.ValidateSAMLEmailsConfig] call req !!! const 200 === statusCode From d6ec0b3bd038d7a9ec959cdb5984faae53d9a457 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 13:35:18 +0200 Subject: [PATCH 06/34] Remove unused function --- libs/wire-api/src/Wire/API/Team/Feature.hs | 17 ---- libs/wire-api/test/unit/Test/Wire/API/Run.hs | 4 +- .../test/unit/Test/Wire/API/Team/Feature.hs | 89 ------------------- libs/wire-api/wire-api.cabal | 1 - 4 files changed, 1 insertion(+), 110 deletions(-) delete mode 100644 libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index c3302ffc00a..639eeb28025 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -48,7 +48,6 @@ module Wire.API.Team.Feature EnforceAppLock (..), defFeatureStatusNoLock, genericComputeFeature, - computeFeatureConfigForTeamUser, IsFeatureConfig (..), FeatureSingleton (..), HasDeprecatedFeatureName (..), @@ -363,9 +362,6 @@ withLockStatus ls (Feature s c) = LockableFeature s ls c withUnlocked :: Feature a -> LockableFeature a withUnlocked = withLockStatus LockStatusUnlocked -withLocked :: Feature a -> LockableFeature a -withLocked = withLockStatus LockStatusLocked - instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (Feature cfg) where schema = object name $ @@ -560,19 +556,6 @@ genericComputeFeature defFeature lockStatus dbFeature = LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} LockStatusUnlocked -> withUnlocked $ unDbFeature dbFeature (forgetLock defFeature) --- | This contains the pure business logic for users from teams -computeFeatureConfigForTeamUser :: Maybe (Feature cfg) -> Maybe LockStatus -> LockableFeature cfg -> LockableFeature cfg -computeFeatureConfigForTeamUser mStatusDb mLockStatusDb defStatus = - case lockStatus of - LockStatusLocked -> - withLocked (forgetLock defStatus) - LockStatusUnlocked -> - withUnlocked $ case mStatusDb of - Nothing -> forgetLock defStatus - Just fs -> fs - where - lockStatus = fromMaybe defStatus.lockStatus mLockStatusDb - -------------------------------------------------------------------------------- -- GuestLinks feature 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 417d543e0e4..5301f44cdc9 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Run.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Run.hs @@ -37,7 +37,6 @@ 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 @@ -70,6 +69,5 @@ main = unsafePerformIO Routes.Version.Wai.tests, RawJson.tests, OAuth.tests, - Password.tests, - Team.Feature.tests + Password.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 deleted file mode 100644 index 3d65c0e6ca2..00000000000 --- a/libs/wire-api/test/unit/Test/Wire/API/Team/Feature.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# OPTIONS_GHC -Wno-ambiguous-fields #-} -{-# 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 = - LockableFeature - FeatureStatusEnabled - LockStatusLocked - ExposeInvitationURLsToTeamAdminConfig - 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 = - LockableFeature - FeatureStatusEnabled - LockStatusLocked - ExposeInvitationURLsToTeamAdminConfig - 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 = - LockableFeature - FeatureStatusEnabled - LockStatusLocked - ExposeInvitationURLsToTeamAdminConfig - let expected = defStatus {lockStatus = LockStatusUnlocked} :: LockableFeature ExposeInvitationURLsToTeamAdminConfig - let actual = computeFeatureConfigForTeamUser @ExposeInvitationURLsToTeamAdminConfig mStatusDb mLockStatusDb defStatus - actual @?= expected - -testComputeFeatureConfigForTeamWithDbStatus :: Assertion -testComputeFeatureConfigForTeamWithDbStatus = do - let mStatusDb = - Just . forgetLock $ - LockableFeature - FeatureStatusDisabled - LockStatusUnlocked - ExposeInvitationURLsToTeamAdminConfig - 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 6ca7fec5377..e875f415f6c 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -660,7 +660,6 @@ 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 From 6db8d66970b947b3bccb33a339e7f6742e14b0d6 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 14:50:50 +0200 Subject: [PATCH 07/34] Replace adhoc default methods with def --- libs/galley-types/galley-types.cabal | 1 + libs/galley-types/src/Galley/Types/Teams.hs | 25 +- libs/wire-api/src/Wire/API/Team/Feature.hs | 220 ++++++++++++------ .../Wire/UserSubsystem/InterpreterSpec.hs | 8 +- services/brig/src/Brig/Data/User.hs | 3 +- services/brig/src/Brig/Options.hs | 5 +- services/brig/src/Brig/User/Auth.hs | 3 +- services/galley/galley.cabal | 1 + .../galley/src/Galley/API/LegalHold/Team.hs | 3 +- .../src/Galley/API/Teams/Features/Get.hs | 9 +- tools/stern/stern.cabal | 1 + tools/stern/test/integration/API.hs | 13 +- 12 files changed, 197 insertions(+), 95 deletions(-) diff --git a/libs/galley-types/galley-types.cabal b/libs/galley-types/galley-types.cabal index f1fae8db830..7a07066d2e3 100644 --- a/libs/galley-types/galley-types.cabal +++ b/libs/galley-types/galley-types.cabal @@ -75,6 +75,7 @@ library , bytestring-conversion , containers >=0.5 , crypton + , data-default , errors , imports , lens >=4.12 diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index d9acf7d6b11..23300b55c27 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -64,6 +64,7 @@ import Data.Aeson import Data.Aeson.Types qualified as A import Data.ByteString (toStrict) import Data.ByteString.UTF8 qualified as UTF8 +import Data.Default import Data.Id (UserId) import Data.Schema qualified as Schema import Data.Set qualified as Set @@ -137,23 +138,23 @@ instance FromJSON FeatureFlags where <*> obj .: "legalhold" <*> obj .: "teamSearchVisibility" <*> withImplicitLockStatusOrDefault obj "appLock" - <*> (fromMaybe (ImplicitLockStatus (defFeatureStatus @ClassifiedDomainsConfig)) <$> (obj .:? "classifiedDomains")) - <*> (fromMaybe (Defaults (defFeatureStatus @FileSharingConfig)) <$> (obj .:? "fileSharing")) - <*> (fromMaybe (Defaults (defFeatureStatus @ConferenceCallingConfig)) <$> (obj .:? "conferenceCalling")) - <*> (fromMaybe (Defaults (defFeatureStatus @SelfDeletingMessagesConfig)) <$> (obj .:? "selfDeletingMessages")) - <*> (fromMaybe (Defaults (defFeatureStatus @GuestLinksConfig)) <$> (obj .:? "conversationGuestLinks")) + <*> (fromMaybe (ImplicitLockStatus def) <$> (obj .:? "classifiedDomains")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "fileSharing")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "conferenceCalling")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "selfDeletingMessages")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "conversationGuestLinks")) <*> withImplicitLockStatusOrDefault obj "validateSAMLEmails" - <*> (fromMaybe (Defaults (defFeatureStatus @SndFactorPasswordChallengeConfig)) <$> (obj .:? "sndFactorPasswordChallenge")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "sndFactorPasswordChallenge")) <*> withImplicitLockStatusOrDefault obj "searchVisibilityInbound" - <*> (fromMaybe (Defaults (defFeatureStatus @MLSConfig)) <$> (obj .:? "mls")) - <*> (fromMaybe (Defaults (defFeatureStatus @OutlookCalIntegrationConfig)) <$> (obj .:? "outlookCalIntegration")) - <*> (fromMaybe (Defaults (defFeatureStatus @MlsE2EIdConfig)) <$> (obj .:? "mlsE2EId")) - <*> (fromMaybe (Defaults (defFeatureStatus @MlsMigrationConfig)) <$> (obj .:? "mlsMigration")) - <*> (fromMaybe (Defaults (defFeatureStatus @EnforceFileDownloadLocationConfig)) <$> (obj .:? "enforceFileDownloadLocation")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "mls")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "outlookCalIntegration")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "mlsE2EId")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "mlsMigration")) + <*> (fromMaybe (Defaults def) <$> (obj .:? "enforceFileDownloadLocation")) <*> withImplicitLockStatusOrDefault obj "limitedEventFanout" where withImplicitLockStatusOrDefault :: forall cfg. (IsFeatureConfig cfg, Schema.ToSchema cfg) => Object -> Key -> A.Parser (Defaults (ImplicitLockStatus cfg)) - withImplicitLockStatusOrDefault obj fieldName = fromMaybe (Defaults (ImplicitLockStatus (defFeatureStatus @cfg))) <$> obj .:? fieldName + withImplicitLockStatusOrDefault obj fieldName = fromMaybe (Defaults (ImplicitLockStatus def)) <$> obj .:? fieldName instance FromJSON FeatureSSO where parseJSON (String "enabled-by-default") = pure FeatureSSOEnabledByDefault diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 639eeb28025..48ece001f8d 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -46,7 +46,6 @@ module Wire.API.Team.Feature FeatureTTLUnit (..), convertFeatureTTLDaysToSeconds, EnforceAppLock (..), - defFeatureStatusNoLock, genericComputeFeature, IsFeatureConfig (..), FeatureSingleton (..), @@ -172,9 +171,8 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) -- 12. Add a section to the documentation at an appropriate place -- (e.g. 'docs/src/developer/reference/config-options.md' (if applicable) or -- 'docs/src/understand/team-feature-settings.md') -class IsFeatureConfig cfg where +class (Default cfg, Default (LockableFeature cfg)) => IsFeatureConfig cfg where type FeatureSymbol cfg :: Symbol - defFeatureStatus :: LockableFeature cfg featureSingleton :: FeatureSingleton cfg objectSchema :: @@ -273,22 +271,25 @@ data LockableFeature cfg = LockableFeature deriving stock (Eq, Show) deriving (ToJSON, FromJSON, S.ToSchema) via Schema (LockableFeature cfg) +instance (Default (LockableFeature cfg)) => Default (Feature cfg) where + def = forgetLock def + -- | A feature that is disabled and locked. -defLockedFeature :: cfg -> LockableFeature cfg -defLockedFeature c = +defLockedFeature :: (Default cfg) => LockableFeature cfg +defLockedFeature = LockableFeature { status = FeatureStatusDisabled, lockStatus = LockStatusLocked, - config = c + config = def } -- | A feature that is enabled and unlocked. -defUnlockedFeature :: cfg -> LockableFeature cfg -defUnlockedFeature c = +defUnlockedFeature :: (Default cfg) => LockableFeature cfg +defUnlockedFeature = LockableFeature { status = FeatureStatusEnabled, lockStatus = LockStatusUnlocked, - config = c + config = def } instance (ToSchema cfg, IsFeatureConfig cfg) => ToSchema (LockableFeature cfg) where @@ -541,7 +542,7 @@ instance (IsFeatureConfig a, ToSchema a) => ToJSON (ImplicitLockStatus a) where toJSON (ImplicitLockStatus a) = A.toJSON $ forgetLock a instance (IsFeatureConfig a, ToSchema a) => FromJSON (ImplicitLockStatus a) where - parseJSON v = ImplicitLockStatus . withLockStatus ((defFeatureStatus @a).lockStatus) <$> A.parseJSON v + parseJSON v = ImplicitLockStatus . withLockStatus ((def @(LockableFeature a)).lockStatus) <$> A.parseJSON v -- | Convert a feature coming from the database to its public form. This can be -- overridden on a feature basis by implementing the `computeFeature` method of @@ -563,15 +564,20 @@ data GuestLinksConfig = GuestLinksConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform GuestLinksConfig) +instance Default GuestLinksConfig where + def = GuestLinksConfig + instance RenderableSymbol GuestLinksConfig where renderSymbol = "GuestLinksConfig" instance ToSchema GuestLinksConfig where schema = object "GuestLinksConfig" objectSchema +instance Default (LockableFeature GuestLinksConfig) where + def = defUnlockedFeature + instance IsFeatureConfig GuestLinksConfig where type FeatureSymbol GuestLinksConfig = "conversationGuestLinks" - defFeatureStatus = defUnlockedFeature GuestLinksConfig featureSingleton = FeatureSingletonGuestLinksConfig objectSchema = pure GuestLinksConfig @@ -583,12 +589,17 @@ data LegalholdConfig = LegalholdConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform LegalholdConfig) +instance Default LegalholdConfig where + def = LegalholdConfig + instance RenderableSymbol LegalholdConfig where renderSymbol = "LegalholdConfig" +instance Default (LockableFeature LegalholdConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig LegalholdConfig where type FeatureSymbol LegalholdConfig = "legalhold" - defFeatureStatus = (defUnlockedFeature LegalholdConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonLegalholdConfig objectSchema = pure LegalholdConfig @@ -603,12 +614,17 @@ data SSOConfig = SSOConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform SSOConfig) +instance Default SSOConfig where + def = SSOConfig + instance RenderableSymbol SSOConfig where renderSymbol = "SSOConfig" +instance Default (LockableFeature SSOConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig SSOConfig where type FeatureSymbol SSOConfig = "sso" - defFeatureStatus = (defUnlockedFeature SSOConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSSOConfig objectSchema = pure SSOConfig @@ -624,12 +640,17 @@ data SearchVisibilityAvailableConfig = SearchVisibilityAvailableConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform SearchVisibilityAvailableConfig) +instance Default SearchVisibilityAvailableConfig where + def = SearchVisibilityAvailableConfig + instance RenderableSymbol SearchVisibilityAvailableConfig where renderSymbol = "SearchVisibilityAvailableConfig" +instance Default (LockableFeature SearchVisibilityAvailableConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig SearchVisibilityAvailableConfig where type FeatureSymbol SearchVisibilityAvailableConfig = "searchVisibility" - defFeatureStatus = (defUnlockedFeature SearchVisibilityAvailableConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSearchVisibilityAvailableConfig objectSchema = pure SearchVisibilityAvailableConfig @@ -647,15 +668,20 @@ data ValidateSAMLEmailsConfig = ValidateSAMLEmailsConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform ValidateSAMLEmailsConfig) +instance Default ValidateSAMLEmailsConfig where + def = ValidateSAMLEmailsConfig + instance RenderableSymbol ValidateSAMLEmailsConfig where renderSymbol = "ValidateSAMLEmailsConfig" instance ToSchema ValidateSAMLEmailsConfig where schema = object "ValidateSAMLEmailsConfig" objectSchema +instance Default (LockableFeature ValidateSAMLEmailsConfig) where + def = defUnlockedFeature + instance IsFeatureConfig ValidateSAMLEmailsConfig where type FeatureSymbol ValidateSAMLEmailsConfig = "validateSAMLemails" - defFeatureStatus = defUnlockedFeature ValidateSAMLEmailsConfig featureSingleton = FeatureSingletonValidateSAMLEmailsConfig objectSchema = pure ValidateSAMLEmailsConfig @@ -670,12 +696,17 @@ data DigitalSignaturesConfig = DigitalSignaturesConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform DigitalSignaturesConfig) +instance Default DigitalSignaturesConfig where + def = DigitalSignaturesConfig + instance RenderableSymbol DigitalSignaturesConfig where renderSymbol = "DigitalSignaturesConfig" +instance Default (LockableFeature DigitalSignaturesConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig DigitalSignaturesConfig where type FeatureSymbol DigitalSignaturesConfig = "digitalSignatures" - defFeatureStatus = (defUnlockedFeature DigitalSignaturesConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonDigitalSignaturesConfig objectSchema = pure DigitalSignaturesConfig @@ -723,9 +754,11 @@ instance Default ConferenceCallingConfig where instance RenderableSymbol ConferenceCallingConfig where renderSymbol = "ConferenceCallingConfig" +instance Default (LockableFeature ConferenceCallingConfig) where + def = defLockedFeature {status = FeatureStatusEnabled} + instance IsFeatureConfig ConferenceCallingConfig where type FeatureSymbol ConferenceCallingConfig = "conferenceCalling" - defFeatureStatus = (defLockedFeature def) {status = FeatureStatusEnabled} featureSingleton = FeatureSingletonConferenceCallingConfig objectSchema = fromMaybe def <$> optField "config" schema @@ -745,15 +778,20 @@ data SndFactorPasswordChallengeConfig = SndFactorPasswordChallengeConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform SndFactorPasswordChallengeConfig) +instance Default SndFactorPasswordChallengeConfig where + def = SndFactorPasswordChallengeConfig + instance RenderableSymbol SndFactorPasswordChallengeConfig where renderSymbol = "SndFactorPasswordChallengeConfig" instance ToSchema SndFactorPasswordChallengeConfig where schema = object "SndFactorPasswordChallengeConfig" objectSchema +instance Default (LockableFeature SndFactorPasswordChallengeConfig) where + def = defLockedFeature + instance IsFeatureConfig SndFactorPasswordChallengeConfig where type FeatureSymbol SndFactorPasswordChallengeConfig = "sndFactorPasswordChallenge" - defFeatureStatus = defLockedFeature SndFactorPasswordChallengeConfig featureSingleton = FeatureSingletonSndFactorPasswordChallengeConfig objectSchema = pure SndFactorPasswordChallengeConfig @@ -765,12 +803,17 @@ data SearchVisibilityInboundConfig = SearchVisibilityInboundConfig deriving (Arbitrary) via (GenericUniform SearchVisibilityInboundConfig) deriving (S.ToSchema) via Schema SearchVisibilityInboundConfig +instance Default SearchVisibilityInboundConfig where + def = SearchVisibilityInboundConfig + instance RenderableSymbol SearchVisibilityInboundConfig where renderSymbol = "SearchVisibilityInboundConfig" +instance Default (LockableFeature SearchVisibilityInboundConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig SearchVisibilityInboundConfig where type FeatureSymbol SearchVisibilityInboundConfig = "searchVisibilityInbound" - defFeatureStatus = (defUnlockedFeature SearchVisibilityInboundConfig) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonSearchVisibilityInboundConfig objectSchema = pure SearchVisibilityInboundConfig @@ -789,6 +832,9 @@ data ClassifiedDomainsConfig = ClassifiedDomainsConfig deriving stock (Show, Eq, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ClassifiedDomainsConfig) +instance Default ClassifiedDomainsConfig where + def = ClassifiedDomainsConfig [] + instance RenderableSymbol ClassifiedDomainsConfig where renderSymbol = "ClassifiedDomainsConfig" @@ -800,13 +846,12 @@ instance ToSchema ClassifiedDomainsConfig where ClassifiedDomainsConfig <$> classifiedDomainsDomains .= field "domains" (array schema) +instance Default (LockableFeature ClassifiedDomainsConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig ClassifiedDomainsConfig where type FeatureSymbol ClassifiedDomainsConfig = "classifiedDomains" - defFeatureStatus = - (defUnlockedFeature (ClassifiedDomainsConfig [])) - { status = FeatureStatusDisabled - } featureSingleton = FeatureSingletonClassifiedDomainsConfig objectSchema = field "config" schema @@ -821,6 +866,9 @@ data AppLockConfig = AppLockConfig deriving (FromJSON, ToJSON, S.ToSchema) via (Schema AppLockConfig) deriving (Arbitrary) via (GenericUniform AppLockConfig) +instance Default AppLockConfig where + def = AppLockConfig (EnforceAppLock False) 60 + instance RenderableSymbol AppLockConfig where renderSymbol = "AppLockConfig" @@ -831,10 +879,12 @@ instance ToSchema AppLockConfig where <$> applockEnforceAppLock .= field "enforceAppLock" schema <*> applockInactivityTimeoutSecs .= field "inactivityTimeoutSecs" schema +instance Default (LockableFeature AppLockConfig) where + def = defUnlockedFeature + instance IsFeatureConfig AppLockConfig where type FeatureSymbol AppLockConfig = "appLock" - defFeatureStatus = defUnlockedFeature (AppLockConfig (EnforceAppLock False) 60) featureSingleton = FeatureSingletonAppLockConfig objectSchema = field "config" schema @@ -853,12 +903,17 @@ data FileSharingConfig = FileSharingConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform FileSharingConfig) +instance Default FileSharingConfig where + def = FileSharingConfig + instance RenderableSymbol FileSharingConfig where renderSymbol = "FileSharingConfig" +instance Default (LockableFeature FileSharingConfig) where + def = defUnlockedFeature + instance IsFeatureConfig FileSharingConfig where type FeatureSymbol FileSharingConfig = "fileSharing" - defFeatureStatus = defUnlockedFeature FileSharingConfig featureSingleton = FeatureSingletonFileSharingConfig objectSchema = pure FileSharingConfig @@ -875,6 +930,9 @@ newtype SelfDeletingMessagesConfig = SelfDeletingMessagesConfig deriving (FromJSON, ToJSON, S.ToSchema) via (Schema SelfDeletingMessagesConfig) deriving (Arbitrary) via (GenericUniform SelfDeletingMessagesConfig) +instance Default SelfDeletingMessagesConfig where + def = SelfDeletingMessagesConfig 0 + instance RenderableSymbol SelfDeletingMessagesConfig where renderSymbol = "SelfDeletingMessagesConfig" @@ -884,9 +942,11 @@ instance ToSchema SelfDeletingMessagesConfig where SelfDeletingMessagesConfig <$> sdmEnforcedTimeoutSeconds .= field "enforcedTimeoutSeconds" schema +instance Default (LockableFeature SelfDeletingMessagesConfig) where + def = defUnlockedFeature + instance IsFeatureConfig SelfDeletingMessagesConfig where type FeatureSymbol SelfDeletingMessagesConfig = "selfDeletingMessages" - defFeatureStatus = defUnlockedFeature (SelfDeletingMessagesConfig 0) featureSingleton = FeatureSingletonSelfDeletingMessagesConfig objectSchema = field "config" schema @@ -903,6 +963,15 @@ data MLSConfig = MLSConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform MLSConfig) +instance Default MLSConfig where + def = + MLSConfig + [] + ProtocolProteusTag + [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] + MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 + [ProtocolProteusTag, ProtocolMLSTag] + instance RenderableSymbol MLSConfig where renderSymbol = "MLSConfig" @@ -916,17 +985,11 @@ instance ToSchema MLSConfig where <*> mlsDefaultCipherSuite .= field "defaultCipherSuite" schema <*> mlsSupportedProtocols .= field "supportedProtocols" (array schema) +instance Default (LockableFeature MLSConfig) where + def = defUnlockedFeature {status = FeatureStatusDisabled} + instance IsFeatureConfig MLSConfig where type FeatureSymbol MLSConfig = "mls" - defFeatureStatus = - let config = - MLSConfig - [] - ProtocolProteusTag - [MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519] - MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 - [ProtocolProteusTag, ProtocolMLSTag] - in (defUnlockedFeature config) {status = FeatureStatusDisabled} featureSingleton = FeatureSingletonMLSConfig objectSchema = field "config" schema @@ -937,12 +1000,17 @@ data ExposeInvitationURLsToTeamAdminConfig = ExposeInvitationURLsToTeamAdminConf deriving stock (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform ExposeInvitationURLsToTeamAdminConfig) +instance Default ExposeInvitationURLsToTeamAdminConfig where + def = ExposeInvitationURLsToTeamAdminConfig + instance RenderableSymbol ExposeInvitationURLsToTeamAdminConfig where renderSymbol = "ExposeInvitationURLsToTeamAdminConfig" +instance Default (LockableFeature ExposeInvitationURLsToTeamAdminConfig) where + def = defLockedFeature + instance IsFeatureConfig ExposeInvitationURLsToTeamAdminConfig where type FeatureSymbol ExposeInvitationURLsToTeamAdminConfig = "exposeInvitationURLsToTeamAdmin" - defFeatureStatus = defLockedFeature ExposeInvitationURLsToTeamAdminConfig featureSingleton = FeatureSingletonExposeInvitationURLsToTeamAdminConfig objectSchema = pure ExposeInvitationURLsToTeamAdminConfig @@ -958,12 +1026,17 @@ data OutlookCalIntegrationConfig = OutlookCalIntegrationConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform OutlookCalIntegrationConfig) +instance Default OutlookCalIntegrationConfig where + def = OutlookCalIntegrationConfig + instance RenderableSymbol OutlookCalIntegrationConfig where renderSymbol = "OutlookCalIntegrationConfig" +instance Default (LockableFeature OutlookCalIntegrationConfig) where + def = defLockedFeature + instance IsFeatureConfig OutlookCalIntegrationConfig where type FeatureSymbol OutlookCalIntegrationConfig = "outlookCalIntegration" - defFeatureStatus = defLockedFeature OutlookCalIntegrationConfig featureSingleton = FeatureSingletonOutlookCalIntegrationConfig objectSchema = pure OutlookCalIntegrationConfig @@ -981,6 +1054,9 @@ data MlsE2EIdConfig = MlsE2EIdConfig } deriving stock (Eq, Show, Generic) +instance Default MlsE2EIdConfig where + def = MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False + instance RenderableSymbol MlsE2EIdConfig where renderSymbol = "MlsE2EIdConfig" @@ -1023,11 +1099,11 @@ instance ToSchema MlsE2EIdConfig where \this team. It is of the form \"https://acme.{backendDomain}/acme/{provisionerName}/discovery\". For example: \ \`https://acme.example.com/acme/provisioner1/discovery`." +instance Default (LockableFeature MlsE2EIdConfig) where + def = defLockedFeature + instance IsFeatureConfig MlsE2EIdConfig where type FeatureSymbol MlsE2EIdConfig = "mlsE2EId" - defFeatureStatus = - defLockedFeature $ - MlsE2EIdConfig (fromIntegral @Int (60 * 60 * 24)) Nothing Nothing False featureSingleton = FeatureSingletonMlsE2EIdConfig objectSchema = field "config" schema @@ -1040,6 +1116,9 @@ data MlsMigrationConfig = MlsMigrationConfig } deriving stock (Eq, Show, Generic) +instance Default MlsMigrationConfig where + def = MlsMigrationConfig Nothing Nothing + instance RenderableSymbol MlsMigrationConfig where renderSymbol = "MlsMigrationConfig" @@ -1060,9 +1139,11 @@ instance ToSchema MlsMigrationConfig where <$> startTime .= maybe_ (optField "startTime" utcTimeSchema) <*> finaliseRegardlessAfter .= maybe_ (optField "finaliseRegardlessAfter" utcTimeSchema) +instance Default (LockableFeature MlsMigrationConfig) where + def = defLockedFeature + instance IsFeatureConfig MlsMigrationConfig where type FeatureSymbol MlsMigrationConfig = "mlsMigration" - defFeatureStatus = defLockedFeature (MlsMigrationConfig Nothing Nothing) featureSingleton = FeatureSingletonMlsMigration objectSchema = field "config" schema @@ -1074,6 +1155,9 @@ data EnforceFileDownloadLocationConfig = EnforceFileDownloadLocationConfig } deriving stock (Eq, Show, Generic) +instance Default EnforceFileDownloadLocationConfig where + def = EnforceFileDownloadLocationConfig Nothing + instance RenderableSymbol EnforceFileDownloadLocationConfig where renderSymbol = "EnforceFileDownloadLocationConfig" @@ -1086,9 +1170,11 @@ instance ToSchema EnforceFileDownloadLocationConfig where EnforceFileDownloadLocationConfig <$> enforcedDownloadLocation .= maybe_ (optField "enforcedDownloadLocation" schema) +instance Default (LockableFeature EnforceFileDownloadLocationConfig) where + def = defLockedFeature + instance IsFeatureConfig EnforceFileDownloadLocationConfig where type FeatureSymbol EnforceFileDownloadLocationConfig = "enforceFileDownloadLocation" - defFeatureStatus = defLockedFeature (EnforceFileDownloadLocationConfig Nothing) featureSingleton = FeatureSingletonEnforceFileDownloadLocationConfig objectSchema = field "config" schema @@ -1104,12 +1190,17 @@ data LimitedEventFanoutConfig = LimitedEventFanoutConfig deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform LimitedEventFanoutConfig) +instance Default LimitedEventFanoutConfig where + def = LimitedEventFanoutConfig + instance RenderableSymbol LimitedEventFanoutConfig where renderSymbol = "LimitedEventFanoutConfig" +instance Default (LockableFeature LimitedEventFanoutConfig) where + def = defUnlockedFeature + instance IsFeatureConfig LimitedEventFanoutConfig where type FeatureSymbol LimitedEventFanoutConfig = "limitedEventFanout" - defFeatureStatus = defUnlockedFeature LimitedEventFanoutConfig featureSingleton = FeatureSingletonLimitedEventFanoutConfig objectSchema = pure LimitedEventFanoutConfig @@ -1176,9 +1267,6 @@ instance Cass.Cql FeatureStatus where toCql FeatureStatusDisabled = Cass.CqlInt 0 toCql FeatureStatusEnabled = Cass.CqlInt 1 -defFeatureStatusNoLock :: (IsFeatureConfig cfg) => Feature cfg -defFeatureStatusNoLock = forgetLock defFeatureStatus - -- FUTUREWORK: rewrite using SOP data AllFeatures f = AllFeatures { afcLegalholdStatus :: f LegalholdConfig, @@ -1208,26 +1296,26 @@ type AllFeatureConfigs = AllFeatures LockableFeature instance Default AllFeatureConfigs where def = AllFeatures - { afcLegalholdStatus = defFeatureStatus, - afcSSOStatus = defFeatureStatus, - afcTeamSearchVisibilityAvailable = defFeatureStatus, - afcSearchVisibilityInboundConfig = defFeatureStatus, - afcValidateSAMLEmails = defFeatureStatus, - afcDigitalSignatures = defFeatureStatus, - afcAppLock = defFeatureStatus, - afcFileSharing = defFeatureStatus, - afcClassifiedDomains = defFeatureStatus, - afcConferenceCalling = defFeatureStatus, - afcSelfDeletingMessages = defFeatureStatus, - afcGuestLink = defFeatureStatus, - afcSndFactorPasswordChallenge = defFeatureStatus, - afcMLS = defFeatureStatus, - afcExposeInvitationURLsToTeamAdmin = defFeatureStatus, - afcOutlookCalIntegration = defFeatureStatus, - afcMlsE2EId = defFeatureStatus, - afcMlsMigration = defFeatureStatus, - afcEnforceFileDownloadLocation = defFeatureStatus, - afcLimitedEventFanout = defFeatureStatus + { afcLegalholdStatus = def, + afcSSOStatus = def, + afcTeamSearchVisibilityAvailable = def, + afcSearchVisibilityInboundConfig = def, + afcValidateSAMLEmails = def, + afcDigitalSignatures = def, + afcAppLock = def, + afcFileSharing = def, + afcClassifiedDomains = def, + afcConferenceCalling = def, + afcSelfDeletingMessages = def, + afcGuestLink = def, + afcSndFactorPasswordChallenge = def, + afcMLS = def, + afcExposeInvitationURLsToTeamAdmin = def, + afcOutlookCalIntegration = def, + afcMlsE2EId = def, + afcMlsMigration = def, + afcEnforceFileDownloadLocation = def, + afcLimitedEventFanout = def } instance ToSchema AllFeatureConfigs where diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 249cb10f810..62ac69f5f54 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -223,7 +223,11 @@ spec = describe "UserSubsystem.Interpreter" do prop "should mark user as managed by scim if E2EId is enabled for the user and they have a handle" \storedSelf domain susbsystemConfig mlsE2EIdConfig -> let localBackend = def {users = [storedSelf]} - allFeatureConfigs = def {afcMlsE2EId = defUnlockedFeature mlsE2EIdConfig} + allFeatureConfigs = + def + { afcMlsE2EId = + LockableFeature FeatureStatusEnabled LockStatusUnlocked mlsE2EIdConfig + } SelfProfile retrievedUser = fromJust . runAllErrorsUnsafe @@ -331,7 +335,7 @@ spec = describe "UserSubsystem.Interpreter" do Nothing def { afcMlsE2EId = - defFeatureStatus + def { status = FeatureStatusEnabled } :: LockableFeature MlsE2EIdConfig diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 6b95fa2ebdd..900301853c2 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -71,6 +71,7 @@ import Cassandra hiding (Set) import Control.Error import Control.Lens hiding (from) import Data.Conduit (ConduitM) +import Data.Default import Data.Domain import Data.Handle (Handle) import Data.Id @@ -443,7 +444,7 @@ lookupFeatureConferenceCalling uid = do mStatusValue <- (>>= runIdentity) <$> retry x1 q case mStatusValue of Nothing -> pure Nothing - Just status -> pure $ Just $ ApiFt.defFeatureStatusNoLock {ApiFt.status = status} + Just status -> pure $ Just $ def {ApiFt.status = status} where select :: PrepQuery R (Identity UserId) (Identity (Maybe ApiFt.FeatureStatus)) select = fromString "select feature_conference_calling from user where id = ?" diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 371faa3565a..45c72d9b0f5 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -35,6 +35,7 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Types (typeMismatch) import Data.Char qualified as Char import Data.Code qualified as Code +import Data.Default import Data.Domain (Domain (..)) import Data.Id import Data.LanguageCodes (ISO639_1 (EN)) @@ -754,8 +755,8 @@ getAfcConferenceCallingDefNull = Lens.to (Public._unImplicitLockStatus . afcConf defAccountFeatureConfigs :: AccountFeatureConfigs defAccountFeatureConfigs = AccountFeatureConfigs - { afcConferenceCallingDefNew = Public.ImplicitLockStatus Public.defFeatureStatus, - afcConferenceCallingDefNull = Public.ImplicitLockStatus Public.defFeatureStatus + { afcConferenceCallingDefNew = Public.ImplicitLockStatus def, + afcConferenceCallingDefNull = Public.ImplicitLockStatus def } -- | Customer extensions naturally are covered by the AGPL like everything else, but use them diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index 152ec6245ac..e79955c528f 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -51,6 +51,7 @@ import Control.Error hiding (bool) import Control.Lens (to, view) import Data.ByteString.Conversion (toByteString) import Data.Code qualified as Code +import Data.Default import Data.Handle (Handle) import Data.Id import Data.List.NonEmpty qualified as NE @@ -134,7 +135,7 @@ verifyCode mbCode action uid = do (mbEmail, mbTeamId) <- getEmailAndTeamId uid featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId - pure $ fromMaybe ((.status) (Public.defFeatureStatus @Public.SndFactorPasswordChallengeConfig) == Public.FeatureStatusEnabled) mbFeatureEnabled + pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 58f9f6c9fab..622a9837161 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -304,6 +304,7 @@ library , crypton , crypton-x509 , currency-codes >=2.0 + , data-default , data-timeout , either , enclosed-exceptions >=1.0 diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index 792d4be0359..de1a37f6892 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -24,6 +24,7 @@ module Galley.API.LegalHold.Team ) where +import Data.Default import Data.Id import Data.Range import Galley.Effects @@ -63,7 +64,7 @@ computeLegalHoldFeatureStatus tid dbFeature = getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure FeatureStatusDisabled FeatureLegalHoldDisabledByDefault -> - pure (unDbFeature dbFeature defFeatureStatusNoLock).status + pure (unDbFeature dbFeature def).status FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do wl <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if wl then FeatureStatusEnabled else FeatureStatusDisabled diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index dde71493018..fbfddc5171b 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -37,6 +37,7 @@ where import Control.Error (hush) import Control.Lens import Data.Bifunctor (second) +import Data.Default import Data.Id import Data.Kind import Data.Qualified (Local, tUnqualified) @@ -85,7 +86,7 @@ class (IsFeatureConfig cfg) => GetFeatureConfig cfg where -- and/or if the feature flag is configured for the backend in 'FeatureFlags' for galley in 'Galley.Types.Teams' -- otherwise this will return the default config from wire-api default getConfigForServer :: Sem r (LockableFeature cfg) - getConfigForServer = pure defFeatureStatus + getConfigForServer = pure def getConfigForUser :: (GetConfigForUserConstraints cfg r) => @@ -381,7 +382,7 @@ instance GetFeatureConfig SSOConfig where inputs (view (settings . featureFlags . flagSSO)) <&> \case FeatureSSOEnabledByDefault -> FeatureStatusEnabled FeatureSSODisabledByDefault -> FeatureStatusDisabled - pure $ defFeatureStatus {status = status} + pure $ def {status = status} instance GetFeatureConfig SearchVisibilityAvailableConfig where getConfigForServer = do @@ -389,7 +390,7 @@ instance GetFeatureConfig SearchVisibilityAvailableConfig where inputs (view (settings . featureFlags . flagTeamSearchVisibility)) <&> \case FeatureTeamSearchVisibilityAvailableByDefault -> FeatureStatusEnabled FeatureTeamSearchVisibilityUnavailableByDefault -> FeatureStatusDisabled - pure $ defFeatureStatus {status = status} + pure $ def {status = status} instance GetFeatureConfig ValidateSAMLEmailsConfig where getConfigForServer = @@ -455,7 +456,7 @@ instance GetFeatureConfig ConferenceCallingConfig where getConfigForUser uid = do feat <- getAccountConferenceCallingConfigClient uid - pure $ withLockStatus (defFeatureStatus @ConferenceCallingConfig).lockStatus feat + pure $ withLockStatus (def @(LockableFeature ConferenceCallingConfig)).lockStatus feat computeFeature _tid defFeature lockStatus dbFeature = pure $ case fromMaybe defFeature.lockStatus lockStatus of diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 01b6639617a..ba50b7edb6b 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -251,6 +251,7 @@ executable stern-integration , bytestring-conversion , containers , cookie + , data-default , exceptions , extra >=1.3 , HsOpenSSL diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 1ebc6a80dcd..591a01a30e2 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -31,6 +31,7 @@ import Control.Lens hiding ((.=)) import Data.Aeson (ToJSON, Value) import Data.Aeson qualified as A import Data.ByteString.Conversion +import Data.Default import Data.Handle import Data.Id import Data.Range (unsafeRange) @@ -107,7 +108,7 @@ tests s = ] defConfCalling :: LockableFeature ConferenceCallingConfig -defConfCalling = defFeatureStatus {status = FeatureStatusDisabled} +defConfCalling = def {status = FeatureStatusDisabled} testRudSsoDomainRedirect :: TestM () testRudSsoDomainRedirect = do @@ -262,7 +263,7 @@ testLegalholdConfig :: TestM () testLegalholdConfig = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @LegalholdConfig tid - liftIO $ cfg @?= defFeatureStatus @LegalholdConfig + liftIO $ cfg @?= def -- Legal hold is enabled for teams via server config and cannot be changed here putFeatureStatus @LegalholdConfig tid FeatureStatusEnabled Nothing !!! const 403 === statusCode @@ -279,7 +280,7 @@ testFeatureConfig :: testFeatureConfig = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @cfg tid - liftIO $ cfg @?= defFeatureStatus @cfg + liftIO $ cfg @?= def let newStatus = if cfg.status == FeatureStatusEnabled then FeatureStatusDisabled else FeatureStatusEnabled putFeatureConfig @cfg tid cfg {status = newStatus} !!! const 200 === statusCode cfg' <- getFeatureConfig @cfg tid @@ -299,7 +300,7 @@ testGetFeatureConfig :: testGetFeatureConfig mDef = do (_, tid, _) <- createTeamWithNMembers 10 cfg <- getFeatureConfig @cfg tid - liftIO $ cfg.status @?= fromMaybe (defFeatureStatus @cfg).status mDef + liftIO $ cfg.status @?= fromMaybe (def @(Feature cfg)).status mDef testFeatureStatus :: forall cfg. @@ -311,7 +312,7 @@ testFeatureStatus :: Show cfg ) => TestM () -testFeatureStatus = testFeatureStatusOptTtl (defFeatureStatus @cfg) Nothing +testFeatureStatus = testFeatureStatusOptTtl @cfg def Nothing testFeatureStatusOptTtl :: forall cfg. @@ -349,7 +350,7 @@ testFeatureStatusWithLock = do let mTtl = Nothing -- this function can become a variant of `testFeatureStatusOptTtl` if we need one. (_, tid, _) <- createTeamWithNMembers 10 getFeatureConfig @cfg tid >>= \cfg -> liftIO $ do - cfg @?= defFeatureStatus @cfg + cfg @?= def -- if either of these two lines fails, it's probably because the default is surprising. -- in that case, make the text more flexible. cfg.lockStatus @?= LockStatusLocked From bd932f4329e49f858f44bbf5d645ae92fa688148 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 14:32:51 +0200 Subject: [PATCH 08/34] Move MakeFeature to a separate module --- services/galley/galley.cabal | 1 + .../Cassandra/GetAllTeamFeatureConfigs.hs | 158 +--------------- .../src/Galley/Cassandra/MakeFeature.hs | 172 ++++++++++++++++++ .../src/Galley/Cassandra/TeamFeatures.hs | 1 + 4 files changed, 175 insertions(+), 157 deletions(-) create mode 100644 services/galley/src/Galley/Cassandra/MakeFeature.hs diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 622a9837161..f6cad74de43 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -139,6 +139,7 @@ library Galley.Cassandra.GetAllTeamFeatureConfigs Galley.Cassandra.Instances Galley.Cassandra.LegalHold + Galley.Cassandra.MakeFeature Galley.Cassandra.Proposal Galley.Cassandra.Queries Galley.Cassandra.SearchVisibility diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 45497346594..7f7edcf1c6a 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -9,6 +9,7 @@ import Data.Misc (HttpsUrl) import Data.Time import Database.CQL.Protocol import Galley.Cassandra.Instances () +import Galley.Cassandra.MakeFeature import Imports import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite @@ -240,160 +241,3 @@ getAllFeatureConfigs tid = do \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 = ?" - -class (Tuple (FeatureRow cfg), HasRowType (FeatureRow cfg)) => MakeFeature cfg where - type FeatureRow cfg - type FeatureRow cfg = Identity (Maybe FeatureStatus) - - mkFeature :: RowType (FeatureRow cfg) -> DbFeature cfg - default mkFeature :: - (FeatureRow cfg ~ Identity (Maybe FeatureStatus)) => - RowType (FeatureRow cfg) -> - DbFeature cfg - mkFeature = foldMap dbFeatureStatus - -mkFeatureWithLock :: - (MakeFeature cfg) => - Maybe LockStatus -> - RowType (FeatureRow cfg) -> - DbFeatureWithLock cfg -mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) - --- | Used to remove the annoying Identity wrapper around single-element rows. -type family RowType a where - RowType (Identity a) = a - RowType tuple = tuple - -class HasRowType a where - fromRowType :: RowType a -> a - default fromRowType :: (RowType a ~ a) => RowType a -> a - fromRowType = id - - toRowType :: a -> RowType a - default toRowType :: (RowType a ~ a) => a -> RowType a - toRowType = id - -instance HasRowType (a, b) - -instance HasRowType (a, b, c) - -instance HasRowType (a, b, c, d) - -instance HasRowType (a, b, c, d, e) - -instance HasRowType (a, b, c, d, e, f) - -instance HasRowType (Identity a) where - fromRowType = Identity - toRowType = runIdentity - -instance MakeFeature LegalholdConfig - -instance MakeFeature SSOConfig - -instance MakeFeature SearchVisibilityAvailableConfig - -instance MakeFeature SearchVisibilityInboundConfig - -instance MakeFeature ValidateSAMLEmailsConfig - -instance MakeFeature DigitalSignaturesConfig - -instance MakeFeature AppLockConfig where - type FeatureRow AppLockConfig = (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) - - mkFeature (status, enforce, timeout) = - foldMap dbFeatureStatus status - <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) - -instance MakeFeature FileSharingConfig - -instance MakeFeature ClassifiedDomainsConfig - -instance MakeFeature ConferenceCallingConfig where - type FeatureRow ConferenceCallingConfig = (Maybe FeatureStatus, Maybe FeatureTTL, Maybe One2OneCalls) - - mkFeature (status, _, sftForOneToOne) = - foldMap dbFeatureStatus status - <> foldMap (dbFeatureConfig . ConferenceCallingConfig) sftForOneToOne - -instance MakeFeature SelfDeletingMessagesConfig where - type FeatureRow SelfDeletingMessagesConfig = (Maybe FeatureStatus, Maybe Int32) - - mkFeature (status, ttl) = - foldMap dbFeatureStatus status - <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl - -instance MakeFeature GuestLinksConfig - -instance MakeFeature SndFactorPasswordChallengeConfig - -instance MakeFeature ExposeInvitationURLsToTeamAdminConfig - -instance MakeFeature OutlookCalIntegrationConfig - -instance MakeFeature MLSConfig where - type - FeatureRow MLSConfig = - ( Maybe FeatureStatus, - Maybe ProtocolTag, - Maybe (C.Set UserId), - Maybe (C.Set CipherSuiteTag), - Maybe CipherSuiteTag, - Maybe (C.Set ProtocolTag) - ) - - mkFeature (status, defProto, toggleUsers, ciphersuites, defCiphersuite, supportedProtos) = - foldMap dbFeatureStatus status - <> foldMap - dbFeatureConfig - ( MLSConfig (foldMap C.fromSet toggleUsers) - <$> defProto - <*> pure (foldMap C.fromSet ciphersuites) - <*> defCiphersuite - <*> pure (foldMap C.fromSet supportedProtos) - ) - -instance MakeFeature MlsE2EIdConfig where - type - FeatureRow MlsE2EIdConfig = - ( Maybe FeatureStatus, - Maybe Int32, - Maybe HttpsUrl, - Maybe HttpsUrl, - Maybe Bool - ) - - mkFeature (status, gracePeriod, acmeDiscoveryUrl, crlProxy, useProxyOnMobile) = - foldMap dbFeatureStatus status - <> dbFeatureModConfig - ( \defCfg -> - defCfg - { verificationExpiration = - maybe defCfg.verificationExpiration fromIntegral gracePeriod, - acmeDiscoveryUrl = acmeDiscoveryUrl, - crlProxy = crlProxy, - useProxyOnMobile = fromMaybe defCfg.useProxyOnMobile useProxyOnMobile - } - ) - -instance MakeFeature MlsMigrationConfig where - type - FeatureRow MlsMigrationConfig = - ( Maybe FeatureStatus, - Maybe UTCTime, - Maybe UTCTime - ) - - mkFeature (status, startTime, finalizeAfter) = - foldMap dbFeatureStatus status - <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) - -instance MakeFeature EnforceFileDownloadLocationConfig where - type FeatureRow EnforceFileDownloadLocationConfig = (Maybe FeatureStatus, Maybe Text) - - mkFeature (status, location) = - foldMap dbFeatureStatus status - <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) - -instance MakeFeature LimitedEventFanoutConfig diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs new file mode 100644 index 00000000000..ace93322de9 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -0,0 +1,172 @@ +-- | Abstraction to fetch and store feature values from and to the database. +module Galley.Cassandra.MakeFeature where + +import Cassandra +import Cassandra qualified as C +import Data.Functor +import Data.Functor.Identity +import Data.Id +import Data.Misc (HttpsUrl) +import Data.Time +import Galley.Cassandra.Instances () +import Imports +import Wire.API.Conversation.Protocol (ProtocolTag) +import Wire.API.MLS.CipherSuite +import Wire.API.Team.Feature + +class (Tuple (FeatureRow cfg), HasRowType (FeatureRow cfg)) => MakeFeature cfg where + type FeatureRow cfg + type FeatureRow cfg = Identity (Maybe FeatureStatus) + + mkFeature :: RowType (FeatureRow cfg) -> DbFeature cfg + default mkFeature :: + (FeatureRow cfg ~ Identity (Maybe FeatureStatus)) => + RowType (FeatureRow cfg) -> + DbFeature cfg + mkFeature = foldMap dbFeatureStatus + +mkFeatureWithLock :: + (MakeFeature cfg) => + Maybe LockStatus -> + RowType (FeatureRow cfg) -> + DbFeatureWithLock cfg +mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) + +-- | Used to remove the annoying Identity wrapper around single-element rows. +type family RowType a where + RowType (Identity a) = a + RowType tuple = tuple + +class HasRowType a where + fromRowType :: RowType a -> a + default fromRowType :: (RowType a ~ a) => RowType a -> a + fromRowType = id + + toRowType :: a -> RowType a + default toRowType :: (RowType a ~ a) => a -> RowType a + toRowType = id + +instance HasRowType (a, b) + +instance HasRowType (a, b, c) + +instance HasRowType (a, b, c, d) + +instance HasRowType (a, b, c, d, e) + +instance HasRowType (a, b, c, d, e, f) + +instance HasRowType (Identity a) where + fromRowType = Identity + toRowType = runIdentity + +instance MakeFeature LegalholdConfig + +instance MakeFeature SSOConfig + +instance MakeFeature SearchVisibilityAvailableConfig + +instance MakeFeature SearchVisibilityInboundConfig + +instance MakeFeature ValidateSAMLEmailsConfig + +instance MakeFeature DigitalSignaturesConfig + +instance MakeFeature AppLockConfig where + type FeatureRow AppLockConfig = (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) + + mkFeature (status, enforce, timeout) = + foldMap dbFeatureStatus status + <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) + +instance MakeFeature FileSharingConfig + +instance MakeFeature ClassifiedDomainsConfig + +instance MakeFeature ConferenceCallingConfig where + type FeatureRow ConferenceCallingConfig = (Maybe FeatureStatus, Maybe FeatureTTL, Maybe One2OneCalls) + + mkFeature (status, _, sftForOneToOne) = + foldMap dbFeatureStatus status + <> foldMap (dbFeatureConfig . ConferenceCallingConfig) sftForOneToOne + +instance MakeFeature SelfDeletingMessagesConfig where + type FeatureRow SelfDeletingMessagesConfig = (Maybe FeatureStatus, Maybe Int32) + + mkFeature (status, ttl) = + foldMap dbFeatureStatus status + <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl + +instance MakeFeature GuestLinksConfig + +instance MakeFeature SndFactorPasswordChallengeConfig + +instance MakeFeature ExposeInvitationURLsToTeamAdminConfig + +instance MakeFeature OutlookCalIntegrationConfig + +instance MakeFeature MLSConfig where + type + FeatureRow MLSConfig = + ( Maybe FeatureStatus, + Maybe ProtocolTag, + Maybe (C.Set UserId), + Maybe (C.Set CipherSuiteTag), + Maybe CipherSuiteTag, + Maybe (C.Set ProtocolTag) + ) + + mkFeature (status, defProto, toggleUsers, ciphersuites, defCiphersuite, supportedProtos) = + foldMap dbFeatureStatus status + <> foldMap + dbFeatureConfig + ( MLSConfig (foldMap C.fromSet toggleUsers) + <$> defProto + <*> pure (foldMap C.fromSet ciphersuites) + <*> defCiphersuite + <*> pure (foldMap C.fromSet supportedProtos) + ) + +instance MakeFeature MlsE2EIdConfig where + type + FeatureRow MlsE2EIdConfig = + ( Maybe FeatureStatus, + Maybe Int32, + Maybe HttpsUrl, + Maybe HttpsUrl, + Maybe Bool + ) + + mkFeature (status, gracePeriod, acmeDiscoveryUrl, crlProxy, useProxyOnMobile) = + foldMap dbFeatureStatus status + <> dbFeatureModConfig + ( \defCfg -> + defCfg + { verificationExpiration = + maybe defCfg.verificationExpiration fromIntegral gracePeriod, + acmeDiscoveryUrl = acmeDiscoveryUrl, + crlProxy = crlProxy, + useProxyOnMobile = fromMaybe defCfg.useProxyOnMobile useProxyOnMobile + } + ) + +instance MakeFeature MlsMigrationConfig where + type + FeatureRow MlsMigrationConfig = + ( Maybe FeatureStatus, + Maybe UTCTime, + Maybe UTCTime + ) + + mkFeature (status, startTime, finalizeAfter) = + foldMap dbFeatureStatus status + <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) + +instance MakeFeature EnforceFileDownloadLocationConfig where + type FeatureRow EnforceFileDownloadLocationConfig = (Maybe FeatureStatus, Maybe Text) + + mkFeature (status, location) = + foldMap dbFeatureStatus status + <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) + +instance MakeFeature LimitedEventFanoutConfig diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 26dbc0c15a5..ccdd9fc35e5 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -30,6 +30,7 @@ import Data.Time import Galley.API.Teams.Features.Get import Galley.Cassandra.GetAllTeamFeatureConfigs import Galley.Cassandra.Instances () +import Galley.Cassandra.MakeFeature import Galley.Cassandra.Store import Galley.Cassandra.Util import Galley.Effects.TeamFeatureStore qualified as TFS From f9fa49f2596b34c883c3da4f312ec724cf1af999 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 15:08:04 +0200 Subject: [PATCH 09/34] Create StoredFeature type class --- services/galley/galley.cabal | 1 + .../src/Galley/Cassandra/MakeFeature.hs | 84 ++++++++++++++++++- .../src/Galley/Cassandra/TeamFeatures.hs | 84 +++++-------------- 3 files changed, 104 insertions(+), 65 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index f6cad74de43..7926b940906 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -343,6 +343,7 @@ library , servant-client , servant-server , singletons + , singletons-th , split >=0.2 , ssl-util >=0.1 , stm >=2.4 diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index ace93322de9..7e4fc59ccc5 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -14,6 +14,9 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature +class StoredFeature cfg where + featureColumns :: String + class (Tuple (FeatureRow cfg), HasRowType (FeatureRow cfg)) => MakeFeature cfg where type FeatureRow cfg type FeatureRow cfg = Identity (Maybe FeatureStatus) @@ -62,16 +65,34 @@ instance HasRowType (Identity a) where instance MakeFeature LegalholdConfig +instance StoredFeature LegalholdConfig where + featureColumns = "legalhold_status" + instance MakeFeature SSOConfig +instance StoredFeature SSOConfig where + featureColumns = "sso_status" + instance MakeFeature SearchVisibilityAvailableConfig +instance StoredFeature SearchVisibilityAvailableConfig where + featureColumns = "search_visibility_status" + instance MakeFeature SearchVisibilityInboundConfig +instance StoredFeature SearchVisibilityInboundConfig where + featureColumns = "search_visibility_status" + instance MakeFeature ValidateSAMLEmailsConfig +instance StoredFeature ValidateSAMLEmailsConfig where + featureColumns = "validate_saml_emails" + instance MakeFeature DigitalSignaturesConfig +instance StoredFeature DigitalSignaturesConfig where + featureColumns = "digital_signatures" + instance MakeFeature AppLockConfig where type FeatureRow AppLockConfig = (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) @@ -79,10 +100,16 @@ instance MakeFeature AppLockConfig where foldMap dbFeatureStatus status <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) -instance MakeFeature FileSharingConfig +instance StoredFeature AppLockConfig where + featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" instance MakeFeature ClassifiedDomainsConfig +instance MakeFeature FileSharingConfig + +instance StoredFeature FileSharingConfig where + featureColumns = "file_sharing" + instance MakeFeature ConferenceCallingConfig where type FeatureRow ConferenceCallingConfig = (Maybe FeatureStatus, Maybe FeatureTTL, Maybe One2OneCalls) @@ -90,6 +117,9 @@ instance MakeFeature ConferenceCallingConfig where foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . ConferenceCallingConfig) sftForOneToOne +instance StoredFeature ConferenceCallingConfig where + featureColumns = "conference_calling_status, ttl(conference_calling_status), conference_calling_one_to_one" + instance MakeFeature SelfDeletingMessagesConfig where type FeatureRow SelfDeletingMessagesConfig = (Maybe FeatureStatus, Maybe Int32) @@ -97,14 +127,29 @@ instance MakeFeature SelfDeletingMessagesConfig where foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl +instance StoredFeature SelfDeletingMessagesConfig where + featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" + instance MakeFeature GuestLinksConfig +instance StoredFeature GuestLinksConfig where + featureColumns = "guest_links_status" + instance MakeFeature SndFactorPasswordChallengeConfig +instance StoredFeature SndFactorPasswordChallengeConfig where + featureColumns = "snd_factor_password_challenge_status" + instance MakeFeature ExposeInvitationURLsToTeamAdminConfig +instance StoredFeature ExposeInvitationURLsToTeamAdminConfig where + featureColumns = "expose_invitation_urls_to_team_admin" + instance MakeFeature OutlookCalIntegrationConfig +instance StoredFeature OutlookCalIntegrationConfig where + featureColumns = "outlook_cal_integration_status" + instance MakeFeature MLSConfig where type FeatureRow MLSConfig = @@ -127,6 +172,11 @@ instance MakeFeature MLSConfig where <*> pure (foldMap C.fromSet supportedProtos) ) +instance StoredFeature MLSConfig where + featureColumns = + "mls_status, mls_default_protocol, mls_protocol_toggle_users, \ + \mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" + instance MakeFeature MlsE2EIdConfig where type FeatureRow MlsE2EIdConfig = @@ -150,6 +200,11 @@ instance MakeFeature MlsE2EIdConfig where } ) +instance StoredFeature MlsE2EIdConfig where + featureColumns = + "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, \ + \mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" + instance MakeFeature MlsMigrationConfig where type FeatureRow MlsMigrationConfig = @@ -162,6 +217,11 @@ instance MakeFeature MlsMigrationConfig where foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) +instance StoredFeature MlsMigrationConfig where + featureColumns = + "mls_migration_status, mls_migration_start_time, \ + \mls_migration_finalise_regardless_after" + instance MakeFeature EnforceFileDownloadLocationConfig where type FeatureRow EnforceFileDownloadLocationConfig = (Maybe FeatureStatus, Maybe Text) @@ -169,4 +229,26 @@ instance MakeFeature EnforceFileDownloadLocationConfig where foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) +instance StoredFeature EnforceFileDownloadLocationConfig where + featureColumns = "enforce_file_download_location_status, enforce_file_download_location" + instance MakeFeature LimitedEventFanoutConfig + +instance StoredFeature LimitedEventFanoutConfig where + featureColumns = "limited_event_fanout_status" + +getFeature :: + forall cfg m. + (MonadClient m, MakeFeature cfg, StoredFeature cfg) => + TeamId -> + m (DbFeature cfg) +getFeature tid = do + row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure $ foldMap (mkFeature . toRowType) row + where + select :: PrepQuery R (Identity TeamId) (FeatureRow cfg) + select = + fromString $ + "select " + <> featureColumns @cfg + <> " 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 ccdd9fc35e5..2ffcad3b96a 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -71,53 +71,26 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case embedClient $ getAllFeatureConfigs tid getFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (DbFeature cfg) -getFeatureConfig FeatureSingletonLegalholdConfig tid = getFeature "legalhold_status" tid -getFeatureConfig FeatureSingletonSSOConfig tid = getFeature "sso_status" tid -getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid = getFeature "search_visibility_status" tid -getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid = getFeature "validate_saml_emails" tid -getFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid = pure mempty -getFeatureConfig FeatureSingletonDigitalSignaturesConfig tid = getFeature "digital_signatures" tid -getFeatureConfig FeatureSingletonAppLockConfig tid = - getFeature - "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" - tid -getFeatureConfig FeatureSingletonFileSharingConfig tid = getFeature "file_sharing" tid -getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid = - getFeature - "self_deleting_messages_status, self_deleting_messages_ttl" - tid -getFeatureConfig FeatureSingletonConferenceCallingConfig tid = - getFeature - "conference_calling_status, ttl(conference_calling_status), conference_calling_one_to_one" - tid -getFeatureConfig FeatureSingletonGuestLinksConfig tid = getFeature "guest_links_status" tid -getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid = getFeature "snd_factor_password_challenge_status" tid -getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid = getFeature "search_visibility_status" tid -getFeatureConfig FeatureSingletonMLSConfig tid = - getFeature - "mls_status, mls_default_protocol, mls_protocol_toggle_users, \ - \mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" - tid -getFeatureConfig FeatureSingletonMlsE2EIdConfig tid = - getFeature - "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, \ - \mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" - tid -getFeatureConfig FeatureSingletonMlsMigration tid = - getFeature - "mls_migration_status, mls_migration_start_time, \ - \mls_migration_finalise_regardless_after" - tid -getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid = - getFeature "expose_invitation_urls_to_team_admin" tid -getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid = - getFeature "outlook_cal_integration_status" tid -getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid = - getFeature - "enforce_file_download_location_status, enforce_file_download_location" - tid -getFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid = - getFeature "limited_event_fanout_status" tid +getFeatureConfig FeatureSingletonLegalholdConfig = getFeature +getFeatureConfig FeatureSingletonSSOConfig = getFeature +getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = getFeature +getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = getFeature +getFeatureConfig FeatureSingletonClassifiedDomainsConfig = const (pure mempty) +getFeatureConfig FeatureSingletonDigitalSignaturesConfig = getFeature +getFeatureConfig FeatureSingletonAppLockConfig = getFeature +getFeatureConfig FeatureSingletonFileSharingConfig = getFeature +getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = getFeature +getFeatureConfig FeatureSingletonConferenceCallingConfig = getFeature +getFeatureConfig FeatureSingletonGuestLinksConfig = getFeature +getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = getFeature +getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = getFeature +getFeatureConfig FeatureSingletonMLSConfig = getFeature +getFeatureConfig FeatureSingletonMlsE2EIdConfig = getFeature +getFeatureConfig FeatureSingletonMlsMigration = getFeature +getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = getFeature +getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = getFeature +getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = getFeature +getFeatureConfig FeatureSingletonLimitedEventFanoutConfig = getFeature setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () setFeatureConfig FeatureSingletonLegalholdConfig tid feat = setFeatureStatusC "legalhold_status" tid feat.status @@ -238,23 +211,6 @@ setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid feat setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid feat = setLockStatusC "conference_calling" tid feat setFeatureLockStatus _ _tid _status = pure () -getFeature :: - forall m cfg. - (MonadClient m, MakeFeature cfg) => - String -> - TeamId -> - m (DbFeature cfg) -getFeature columns tid = do - row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (mkFeature . toRowType) row - where - select :: PrepQuery R (Identity TeamId) (FeatureRow cfg) - select = - fromString $ - "select " - <> columns - <> " from team_features where team_id = ?" - setFeatureStatusC :: forall m. (MonadClient m) => From 05a54ba66b65fc4a2879435e5e5ad4ca0fe96737 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 2 Aug 2024 16:36:18 +0200 Subject: [PATCH 10/34] Abstract setFeature --- services/galley/galley.cabal | 4 +- .../Cassandra/GetAllTeamFeatureConfigs.hs | 76 ++--- .../src/Galley/Cassandra/MakeFeature.hs | 276 ++++++++++++------ .../src/Galley/Cassandra/TeamFeatures.hs | 131 ++------- 4 files changed, 256 insertions(+), 231 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 7926b940906..0989055f875 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -314,6 +314,7 @@ library , extended , extra >=1.3 , galley-types >=0.65.0 + , generics-sop , gundeck-types >=1.35.2 , hex , HsOpenSSL >=0.11 @@ -343,7 +344,8 @@ library , servant-client , servant-server , singletons - , singletons-th + , singletons-base + , sop-core , split >=0.2 , ssl-util >=0.1 , stm >=2.4 diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 7f7edcf1c6a..b261d2fdaa7 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -6,6 +6,7 @@ import Cassandra import Cassandra qualified as C import Data.Id import Data.Misc (HttpsUrl) +import Data.SOP import Data.Time import Database.CQL.Protocol import Galley.Cassandra.Instances () @@ -137,71 +138,76 @@ emptyRow = allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeatureWithLock allFeatureConfigsFromRow row = AllFeatures - { afcLegalholdStatus = mkFeatureWithLock Nothing row.legalhold, - afcSSOStatus = mkFeatureWithLock Nothing row.sso, - afcTeamSearchVisibilityAvailable = mkFeatureWithLock Nothing row.searchVisibility, - afcSearchVisibilityInboundConfig = mkFeatureWithLock Nothing row.searchVisibility, - afcValidateSAMLEmails = mkFeatureWithLock Nothing row.validateSamlEmails, - afcDigitalSignatures = mkFeatureWithLock Nothing row.digitalSignatures, + { afcLegalholdStatus = mkFeatureWithLock Nothing (I row.legalhold :* Nil), + afcSSOStatus = mkFeatureWithLock Nothing (I row.sso :* Nil), + afcTeamSearchVisibilityAvailable = mkFeatureWithLock Nothing (I row.searchVisibility :* Nil), + afcSearchVisibilityInboundConfig = mkFeatureWithLock Nothing (I row.searchVisibility :* Nil), + afcValidateSAMLEmails = mkFeatureWithLock Nothing (I row.validateSamlEmails :* Nil), + afcDigitalSignatures = mkFeatureWithLock Nothing (I row.digitalSignatures :* Nil), afcAppLock = mkFeatureWithLock Nothing - (row.appLock, row.appLockEnforce, row.appLockInactivityTimeoutSecs), - afcFileSharing = mkFeatureWithLock row.fileSharingLock row.fileSharing, - afcClassifiedDomains = mkFeatureWithLock Nothing Nothing, + (I row.appLock :* I row.appLockEnforce :* I row.appLockInactivityTimeoutSecs :* Nil), + afcFileSharing = mkFeatureWithLock row.fileSharingLock (I row.fileSharing :* Nil), + afcClassifiedDomains = mkFeatureWithLock Nothing (I Nothing :* Nil), afcConferenceCalling = mkFeatureWithLock row.conferenceCallingLock - ( row.conferenceCalling, - row.conferenceCallingTtl, - row.conferenceCallingOne2One + ( I row.conferenceCalling + :* I row.conferenceCallingOne2One + :* Nil ), afcSelfDeletingMessages = mkFeatureWithLock row.selfDeletingMessagesLock - ( row.selfDeletingMessages, - row.selfDeletingMessagesTtl + ( I row.selfDeletingMessages + :* I row.selfDeletingMessagesTtl + :* Nil ), - afcGuestLink = mkFeatureWithLock row.guestLinksLock row.guestLinks, - afcSndFactorPasswordChallenge = mkFeatureWithLock row.sndFactorLock row.sndFactor, + afcGuestLink = mkFeatureWithLock row.guestLinksLock (I row.guestLinks :* Nil), + afcSndFactorPasswordChallenge = mkFeatureWithLock row.sndFactorLock (I row.sndFactor :* Nil), afcMLS = mkFeatureWithLock row.mlsLock - ( row.mls, - row.mlsDefaultProtocol, - row.mlsToggleUsers, - row.mlsAllowedCipherSuites, - row.mlsDefaultCipherSuite, - row.mlsSupportedProtocols + ( I row.mls + :* I row.mlsDefaultProtocol + :* I row.mlsToggleUsers + :* I row.mlsAllowedCipherSuites + :* I row.mlsDefaultCipherSuite + :* I row.mlsSupportedProtocols + :* Nil ), - afcExposeInvitationURLsToTeamAdmin = mkFeatureWithLock Nothing row.exposeInvitationUrls, + afcExposeInvitationURLsToTeamAdmin = mkFeatureWithLock Nothing (I row.exposeInvitationUrls :* Nil), afcOutlookCalIntegration = mkFeatureWithLock row.outlookCalIntegrationLock - row.outlookCalIntegration, + (I row.outlookCalIntegration :* Nil), afcMlsE2EId = mkFeatureWithLock row.mlsE2eidLock - ( row.mlsE2eid, - row.mlsE2eidGracePeriod, - row.mlsE2eidAcmeDiscoverUrl, - row.mlsE2eidMaybeCrlProxy, - row.mlsE2eidMaybeUseProxyOnMobile + ( I row.mlsE2eid + :* I row.mlsE2eidGracePeriod + :* I row.mlsE2eidAcmeDiscoverUrl + :* I row.mlsE2eidMaybeCrlProxy + :* I row.mlsE2eidMaybeUseProxyOnMobile + :* Nil ), afcMlsMigration = mkFeatureWithLock row.mlsMigrationLock - ( row.mlsMigration, - row.mlsMigrationStartTime, - row.mlsMigrationFinalizeRegardlessAfter + ( I row.mlsMigration + :* I row.mlsMigrationStartTime + :* I row.mlsMigrationFinalizeRegardlessAfter + :* Nil ), afcEnforceFileDownloadLocation = mkFeatureWithLock row.enforceDownloadLocationLock - ( row.enforceDownloadLocation, - row.enforceDownloadLocation_Location + ( I row.enforceDownloadLocation + :* I row.enforceDownloadLocation_Location + :* Nil ), - afcLimitedEventFanout = mkFeatureWithLock Nothing row.limitEventFanout + afcLimitedEventFanout = mkFeatureWithLock Nothing (I row.limitEventFanout :* Nil) } getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeatureWithLock) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 7e4fc59ccc5..c857921410b 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | Abstraction to fetch and store feature values from and to the database. module Galley.Cassandra.MakeFeature where @@ -6,10 +8,15 @@ import Cassandra qualified as C import Data.Functor import Data.Functor.Identity import Data.Id +import Data.Kind +import Data.List.Singletons import Data.Misc (HttpsUrl) +import Data.Singletons import Data.Time +import GHC.TypeNats import Galley.Cassandra.Instances () -import Imports +import Generics.SOP +import Imports hiding (Generic) import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature @@ -17,52 +24,33 @@ import Wire.API.Team.Feature class StoredFeature cfg where featureColumns :: String -class (Tuple (FeatureRow cfg), HasRowType (FeatureRow cfg)) => MakeFeature cfg where - type FeatureRow cfg - type FeatureRow cfg = Identity (Maybe FeatureStatus) +class MakeFeature cfg where + type FeatureReadRow cfg :: [Type] + type FeatureReadRow cfg = '[Maybe FeatureStatus] + type FeatureWriteRow cfg :: [Type] + type FeatureWriteRow cfg = '[FeatureStatus] - mkFeature :: RowType (FeatureRow cfg) -> DbFeature cfg + mkFeature :: NP I (FeatureReadRow cfg) -> DbFeature cfg default mkFeature :: - (FeatureRow cfg ~ Identity (Maybe FeatureStatus)) => - RowType (FeatureRow cfg) -> + (FeatureReadRow cfg ~ '[Maybe FeatureStatus]) => + NP I (FeatureReadRow cfg) -> DbFeature cfg - mkFeature = foldMap dbFeatureStatus + mkFeature = foldMap dbFeatureStatus . unI . hd + + unmkFeature :: Feature cfg -> NP I (FeatureWriteRow cfg) + default unmkFeature :: + (FeatureWriteRow cfg ~ '[FeatureStatus]) => + Feature cfg -> + NP I (FeatureWriteRow cfg) + unmkFeature feat = I feat.status :* Nil mkFeatureWithLock :: (MakeFeature cfg) => Maybe LockStatus -> - RowType (FeatureRow cfg) -> + NP I (FeatureReadRow cfg) -> DbFeatureWithLock cfg mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) --- | Used to remove the annoying Identity wrapper around single-element rows. -type family RowType a where - RowType (Identity a) = a - RowType tuple = tuple - -class HasRowType a where - fromRowType :: RowType a -> a - default fromRowType :: (RowType a ~ a) => RowType a -> a - fromRowType = id - - toRowType :: a -> RowType a - default toRowType :: (RowType a ~ a) => a -> RowType a - toRowType = id - -instance HasRowType (a, b) - -instance HasRowType (a, b, c) - -instance HasRowType (a, b, c, d) - -instance HasRowType (a, b, c, d, e) - -instance HasRowType (a, b, c, d, e, f) - -instance HasRowType (Identity a) where - fromRowType = Identity - toRowType = runIdentity - instance MakeFeature LegalholdConfig instance StoredFeature LegalholdConfig where @@ -94,12 +82,19 @@ instance StoredFeature DigitalSignaturesConfig where featureColumns = "digital_signatures" instance MakeFeature AppLockConfig where - type FeatureRow AppLockConfig = (Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32) + type FeatureReadRow AppLockConfig = '[Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32] + type FeatureWriteRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] - mkFeature (status, enforce, timeout) = + mkFeature (I status :* I enforce :* I timeout :* Nil) = foldMap dbFeatureStatus status <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) + unmkFeature feat = + I feat.status + :* I feat.config.applockEnforceAppLock + :* I feat.config.applockInactivityTimeoutSecs + :* Nil + instance StoredFeature AppLockConfig where featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" @@ -111,22 +106,34 @@ instance StoredFeature FileSharingConfig where featureColumns = "file_sharing" instance MakeFeature ConferenceCallingConfig where - type FeatureRow ConferenceCallingConfig = (Maybe FeatureStatus, Maybe FeatureTTL, Maybe One2OneCalls) + type FeatureReadRow ConferenceCallingConfig = '[Maybe FeatureStatus, Maybe One2OneCalls] + type FeatureWriteRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] - mkFeature (status, _, sftForOneToOne) = + mkFeature (I status :* I calls :* Nil) = foldMap dbFeatureStatus status - <> foldMap (dbFeatureConfig . ConferenceCallingConfig) sftForOneToOne + <> foldMap (dbFeatureConfig . ConferenceCallingConfig) calls + + unmkFeature feat = + I feat.status + :* I feat.config.one2OneCalls + :* Nil instance StoredFeature ConferenceCallingConfig where - featureColumns = "conference_calling_status, ttl(conference_calling_status), conference_calling_one_to_one" + featureColumns = "conference_calling_status, conference_calling_one_to_one" instance MakeFeature SelfDeletingMessagesConfig where - type FeatureRow SelfDeletingMessagesConfig = (Maybe FeatureStatus, Maybe Int32) + type FeatureReadRow SelfDeletingMessagesConfig = '[Maybe FeatureStatus, Maybe Int32] + type FeatureWriteRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] - mkFeature (status, ttl) = + mkFeature (I status :* I ttl :* Nil) = foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl + unmkFeature feat = + I feat.status + :* I feat.config.sdmEnforcedTimeoutSeconds + :* Nil + instance StoredFeature SelfDeletingMessagesConfig where featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" @@ -152,16 +159,26 @@ instance StoredFeature OutlookCalIntegrationConfig where instance MakeFeature MLSConfig where type - FeatureRow MLSConfig = - ( Maybe FeatureStatus, - Maybe ProtocolTag, - Maybe (C.Set UserId), - Maybe (C.Set CipherSuiteTag), - Maybe CipherSuiteTag, - Maybe (C.Set ProtocolTag) - ) - - mkFeature (status, defProto, toggleUsers, ciphersuites, defCiphersuite, supportedProtos) = + FeatureReadRow MLSConfig = + '[ Maybe FeatureStatus, + Maybe ProtocolTag, + Maybe (C.Set UserId), + Maybe (C.Set CipherSuiteTag), + Maybe CipherSuiteTag, + Maybe (C.Set ProtocolTag) + ] + + type + FeatureWriteRow MLSConfig = + '[ FeatureStatus, + ProtocolTag, + (C.Set UserId), + (C.Set CipherSuiteTag), + CipherSuiteTag, + (C.Set ProtocolTag) + ] + + mkFeature (I status :* I defProto :* I toggleUsers :* I ciphersuites :* I defCiphersuite :* I supportedProtos :* Nil) = foldMap dbFeatureStatus status <> foldMap dbFeatureConfig @@ -172,22 +189,39 @@ instance MakeFeature MLSConfig where <*> pure (foldMap C.fromSet supportedProtos) ) + unmkFeature feat = + I feat.status + :* I feat.config.mlsDefaultProtocol + :* I (C.Set feat.config.mlsProtocolToggleUsers) + :* I (C.Set feat.config.mlsAllowedCipherSuites) + :* I feat.config.mlsDefaultCipherSuite + :* I (C.Set feat.config.mlsSupportedProtocols) + :* Nil + instance StoredFeature MLSConfig where featureColumns = - "mls_status, mls_default_protocol, mls_protocol_toggle_users, \ - \mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" + "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" instance MakeFeature MlsE2EIdConfig where type - FeatureRow MlsE2EIdConfig = - ( Maybe FeatureStatus, - Maybe Int32, - Maybe HttpsUrl, - Maybe HttpsUrl, - Maybe Bool - ) - - mkFeature (status, gracePeriod, acmeDiscoveryUrl, crlProxy, useProxyOnMobile) = + FeatureReadRow MlsE2EIdConfig = + '[ Maybe FeatureStatus, + Maybe Int32, + Maybe HttpsUrl, + Maybe HttpsUrl, + Maybe Bool + ] + + type + FeatureWriteRow MlsE2EIdConfig = + '[ FeatureStatus, + Int32, + Maybe HttpsUrl, + Maybe HttpsUrl, + Bool + ] + + mkFeature (I status :* I gracePeriod :* I acmeDiscoveryUrl :* I crlProxy :* I useProxyOnMobile :* Nil) = foldMap dbFeatureStatus status <> dbFeatureModConfig ( \defCfg -> @@ -200,34 +234,52 @@ instance MakeFeature MlsE2EIdConfig where } ) + unmkFeature feat = + I feat.status + :* I (truncate feat.config.verificationExpiration) + :* I feat.config.acmeDiscoveryUrl + :* I feat.config.crlProxy + :* I feat.config.useProxyOnMobile + :* Nil + instance StoredFeature MlsE2EIdConfig where featureColumns = - "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, \ - \mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" + "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" instance MakeFeature MlsMigrationConfig where type - FeatureRow MlsMigrationConfig = - ( Maybe FeatureStatus, - Maybe UTCTime, - Maybe UTCTime - ) + FeatureReadRow MlsMigrationConfig = + '[ Maybe FeatureStatus, + Maybe UTCTime, + Maybe UTCTime + ] - mkFeature (status, startTime, finalizeAfter) = + type + FeatureWriteRow MlsMigrationConfig = + '[FeatureStatus, Maybe UTCTime, Maybe UTCTime] + + mkFeature (I status :* I startTime :* I finalizeAfter :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) + unmkFeature feat = + I feat.status + :* I feat.config.startTime + :* I feat.config.finaliseRegardlessAfter + :* Nil + instance StoredFeature MlsMigrationConfig where featureColumns = - "mls_migration_status, mls_migration_start_time, \ - \mls_migration_finalise_regardless_after" + "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" instance MakeFeature EnforceFileDownloadLocationConfig where - type FeatureRow EnforceFileDownloadLocationConfig = (Maybe FeatureStatus, Maybe Text) + type FeatureReadRow EnforceFileDownloadLocationConfig = '[Maybe FeatureStatus, Maybe Text] + type FeatureWriteRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Maybe Text] - mkFeature (status, location) = + mkFeature (I status :* I location :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) + unmkFeature feat = I feat.status :* I feat.config.enforcedDownloadLocation :* Nil instance StoredFeature EnforceFileDownloadLocationConfig where featureColumns = "enforce_file_download_location_status, enforce_file_download_location" @@ -239,16 +291,72 @@ instance StoredFeature LimitedEventFanoutConfig where getFeature :: forall cfg m. - (MonadClient m, MakeFeature cfg, StoredFeature cfg) => + ( MonadClient m, + MakeFeature cfg, + StoredFeature cfg, + AsTuple (FeatureReadRow cfg), + Tuple (TupleP (FeatureReadRow cfg)) + ) => TeamId -> m (DbFeature cfg) getFeature tid = do row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (mkFeature . toRowType) row + pure $ foldMap (mkFeature . fromTuple) row + where + selectQ = + "select " + <> featureColumns @cfg + <> " from team_features where team_id = ?" + select :: PrepQuery R (Identity TeamId) (TupleP (FeatureReadRow cfg)) + select = fromString selectQ + +setFeature :: + forall cfg m. + ( MonadClient m, + MakeFeature cfg, + StoredFeature cfg, + AsTuple (TeamId ': FeatureWriteRow cfg), + Tuple (TupleP (TeamId ': FeatureWriteRow cfg)), + KnownNat (Length (TeamId ': FeatureWriteRow cfg)) + ) => + TeamId -> + Feature cfg -> + m () +setFeature tid feat = do + retry x5 $ write insert (params LocalQuorum (toTuple (I tid :* unmkFeature feat))) where - select :: PrepQuery R (Identity TeamId) (FeatureRow cfg) - select = + n :: Int + n = fromIntegral (demote @(Length (TeamId ': FeatureWriteRow cfg))) + + insert :: PrepQuery W (TupleP (TeamId ': FeatureWriteRow cfg)) () + insert = fromString $ - "select " + "insert into team_features (team_id, " <> featureColumns @cfg - <> " from team_features where team_id = ?" + <> ") values (" + <> intercalate "," (replicate n "?") + <> ")" + +type AsTuple xs = (Code (TupleP xs) ~ '[xs], Generic (TupleP xs)) + +toTuple :: (AsTuple xs) => NP I xs -> TupleP xs +toTuple = to . SOP . Z + +fromTuple :: (AsTuple xs) => TupleP xs -> NP I xs +fromTuple = unZ . unSOP . from + +-- | This could be replaced in principle by a type class as follows: +-- @@ +-- class TupleP xs t +-- instance (Code t ~ '[xs], Generic t) => TupleP xs t +-- @@ +-- but then we wouldn't have the functional dependency xs -> t, which is needed +-- to keep inference sane. +type family TupleP (xs :: [Type]) where + TupleP '[a] = Identity a + TupleP [a, b] = (a, b) + TupleP [a, b, c] = (a, b, c) + TupleP [a, b, c, d] = (a, b, c, d) + TupleP [a, b, c, d, e] = (a, b, c, d, e) + TupleP [a, b, c, d, e, f] = (a, b, c, d, e, f) + TupleP [a, b, c, d, e, f, g] = (a, b, c, d, e, f, g) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 2ffcad3b96a..adc11a33c75 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -23,10 +23,7 @@ module Galley.Cassandra.TeamFeatures where import Cassandra -import Cassandra qualified as C import Data.Id -import Data.Misc (HttpsUrl) -import Data.Time import Galley.API.Teams.Features.Get import Galley.Cassandra.GetAllTeamFeatureConfigs import Galley.Cassandra.Instances () @@ -39,8 +36,6 @@ import Polysemy import Polysemy.Input import Polysemy.TinyLog import UnliftIO.Async (pooledMapConcurrentlyN) -import Wire.API.Conversation.Protocol (ProtocolTag) -import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature interpretTeamFeatureStoreToCassandra :: @@ -93,97 +88,26 @@ getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = getFeature getFeatureConfig FeatureSingletonLimitedEventFanoutConfig = getFeature setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () -setFeatureConfig FeatureSingletonLegalholdConfig tid feat = setFeatureStatusC "legalhold_status" tid feat.status -setFeatureConfig FeatureSingletonSSOConfig tid feat = setFeatureStatusC "sso_status" tid feat.status -setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig tid feat = setFeatureStatusC "search_visibility_status" tid feat.status -setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig tid feat = setFeatureStatusC "validate_saml_emails" tid feat.status -setFeatureConfig FeatureSingletonClassifiedDomainsConfig _tid _feat = pure () -setFeatureConfig FeatureSingletonDigitalSignaturesConfig tid feat = setFeatureStatusC "digital_signatures" tid feat.status -setFeatureConfig FeatureSingletonAppLockConfig tid feat = do - let enforce = applockEnforceAppLock feat.config - timeout = applockInactivityTimeoutSecs feat.config - - retry x5 $ write insert (params LocalQuorum (tid, feat.status, enforce, timeout)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, EnforceAppLock, Int32) () - insert = - fromString $ - "insert into team_features (team_id, app_lock_status, app_lock_enforce,\ - \ app_lock_inactivity_timeout_secs) values (?, ?, ?, ?)" -setFeatureConfig FeatureSingletonFileSharingConfig tid feat = setFeatureStatusC "file_sharing" tid feat.status -setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig tid feat = do - let statusValue = feat.status - timeout = sdmEnforcedTimeoutSeconds feat.config - retry x5 $ write insert (params LocalQuorum (tid, statusValue, timeout)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32) () - insert = - "insert into team_features (team_id, self_deleting_messages_status,\ - \ self_deleting_messages_ttl) values (?, ?, ?)" -setFeatureConfig FeatureSingletonConferenceCallingConfig tid feat = do - retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery insertStatus (tid, feat.status) - addPrepQuery insertConfig (tid, feat.config.one2OneCalls) - where - insertStatus :: PrepQuery W (TeamId, FeatureStatus) () - insertStatus = "insert into team_features (team_id, conference_calling_status) values (?, ?)" - insertConfig :: PrepQuery W (TeamId, One2OneCalls) () - insertConfig = "insert into team_features (team_id, conference_calling_one_to_one) values (?, ?)" -setFeatureConfig FeatureSingletonGuestLinksConfig tid feat = setFeatureStatusC "guest_links_status" tid feat.status -setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig tid feat = - setFeatureStatusC "snd_factor_password_challenge_status" tid feat.status -setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig tid feat = setFeatureStatusC "search_visibility_status" tid feat.status -setFeatureConfig FeatureSingletonMLSConfig tid feat = do - let status = feat.status - let MLSConfig protocolToggleUsers defaultProtocol allowedCipherSuites defaultCipherSuite supportedProtocols = feat.config - retry x5 $ - write - insert - ( params - LocalQuorum - ( tid, - status, - defaultProtocol, - C.Set protocolToggleUsers, - C.Set allowedCipherSuites, - defaultCipherSuite, - C.Set supportedProtocols - ) - ) - where - insert :: PrepQuery W (TeamId, FeatureStatus, ProtocolTag, C.Set UserId, C.Set CipherSuiteTag, CipherSuiteTag, C.Set ProtocolTag) () - insert = - "insert into team_features (team_id, mls_status, mls_default_protocol, \ - \mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols) values (?, ?, ?, ?, ?, ?, ?)" -setFeatureConfig FeatureSingletonMlsE2EIdConfig tid feat = do - let statusValue = feat.status - vex = verificationExpiration feat.config - mUrl = acmeDiscoveryUrl feat.config - mCrlProxy = crlProxy feat.config - useProxy = useProxyOnMobile feat.config - retry x5 $ write insert (params LocalQuorum (tid, statusValue, truncate vex, mUrl, mCrlProxy, useProxy)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Int32, Maybe HttpsUrl, Maybe HttpsUrl, Bool) () - insert = - "insert into team_features (team_id, mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile) values (?, ?, ?, ?, ?, ?)" -setFeatureConfig FeatureSingletonMlsMigration tid feat = do - retry x5 $ write insert (params LocalQuorum (tid, feat.status, feat.config.startTime, feat.config.finaliseRegardlessAfter)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Maybe UTCTime, Maybe UTCTime) () - insert = - "insert into team_features (team_id, mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after) values (?, ?, ?, ?)" -setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig tid feat = setFeatureStatusC "expose_invitation_urls_to_team_admin" tid feat.status -setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig tid feat = setFeatureStatusC "outlook_cal_integration_status" tid feat.status -setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig tid feat = do - retry x5 $ write insert (params LocalQuorum (tid, feat.status, feat.config.enforcedDownloadLocation)) - where - insert :: PrepQuery W (TeamId, FeatureStatus, Maybe Text) () - insert = - "insert into team_features (team_id, enforce_file_download_location_status, enforce_file_download_location) values (?, ?, ?)" -setFeatureConfig FeatureSingletonLimitedEventFanoutConfig tid feat = - setFeatureStatusC "limited_event_fanout_status" tid feat.status +setFeatureConfig FeatureSingletonLegalholdConfig = setFeature +setFeatureConfig FeatureSingletonSSOConfig = setFeature +setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = setFeature +setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = setFeature +setFeatureConfig FeatureSingletonClassifiedDomainsConfig = \_ _ -> pure () +setFeatureConfig FeatureSingletonDigitalSignaturesConfig = setFeature +setFeatureConfig FeatureSingletonAppLockConfig = setFeature +setFeatureConfig FeatureSingletonFileSharingConfig = setFeature +setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = setFeature +setFeatureConfig FeatureSingletonConferenceCallingConfig = setFeature +setFeatureConfig FeatureSingletonGuestLinksConfig = setFeature +setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = setFeature +setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = setFeature +setFeatureConfig FeatureSingletonMLSConfig = setFeature +setFeatureConfig FeatureSingletonMlsE2EIdConfig = setFeature +setFeatureConfig FeatureSingletonMlsMigration = setFeature +setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = setFeature +setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = setFeature +setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = setFeature +setFeatureConfig FeatureSingletonLimitedEventFanoutConfig = setFeature getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) getFeatureLockStatus FeatureSingletonFileSharingConfig tid = getLockStatusC "file_sharing_lock_status" tid @@ -211,21 +135,6 @@ setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid feat setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid feat = setLockStatusC "conference_calling" tid feat setFeatureLockStatus _ _tid _status = pure () -setFeatureStatusC :: - forall m. - (MonadClient m) => - String -> - TeamId -> - FeatureStatus -> - m () -setFeatureStatusC statusCol tid status = do - retry x5 $ write insert (params LocalQuorum (tid, status)) - where - insert :: PrepQuery W (TeamId, FeatureStatus) () - insert = - fromString $ - "insert into team_features (team_id, " <> statusCol <> ") values (?, ?)" - getLockStatusC :: forall m. (MonadClient m) => From bb9ddd10aac37c7a9a95d73f112e1f0d003ea791 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 5 Aug 2024 15:21:51 +0200 Subject: [PATCH 11/34] Remove StoredFeature type class --- .../src/Galley/Cassandra/MakeFeature.hs | 94 ++++++------------- 1 file changed, 28 insertions(+), 66 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index c857921410b..eed8254d062 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -21,15 +21,14 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature -class StoredFeature cfg where - featureColumns :: String - class MakeFeature cfg where type FeatureReadRow cfg :: [Type] type FeatureReadRow cfg = '[Maybe FeatureStatus] type FeatureWriteRow cfg :: [Type] type FeatureWriteRow cfg = '[FeatureStatus] + featureColumns :: String + mkFeature :: NP I (FeatureReadRow cfg) -> DbFeature cfg default mkFeature :: (FeatureReadRow cfg ~ '[Maybe FeatureStatus]) => @@ -51,39 +50,28 @@ mkFeatureWithLock :: DbFeatureWithLock cfg mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) -instance MakeFeature LegalholdConfig - -instance StoredFeature LegalholdConfig where +instance MakeFeature LegalholdConfig where featureColumns = "legalhold_status" -instance MakeFeature SSOConfig - -instance StoredFeature SSOConfig where +instance MakeFeature SSOConfig where featureColumns = "sso_status" -instance MakeFeature SearchVisibilityAvailableConfig - -instance StoredFeature SearchVisibilityAvailableConfig where +instance MakeFeature SearchVisibilityAvailableConfig where featureColumns = "search_visibility_status" -instance MakeFeature SearchVisibilityInboundConfig - -instance StoredFeature SearchVisibilityInboundConfig where +instance MakeFeature SearchVisibilityInboundConfig where featureColumns = "search_visibility_status" -instance MakeFeature ValidateSAMLEmailsConfig - -instance StoredFeature ValidateSAMLEmailsConfig where +instance MakeFeature ValidateSAMLEmailsConfig where featureColumns = "validate_saml_emails" -instance MakeFeature DigitalSignaturesConfig - -instance StoredFeature DigitalSignaturesConfig where +instance MakeFeature DigitalSignaturesConfig where featureColumns = "digital_signatures" instance MakeFeature AppLockConfig where type FeatureReadRow AppLockConfig = '[Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32] type FeatureWriteRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] + featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" mkFeature (I status :* I enforce :* I timeout :* Nil) = foldMap dbFeatureStatus status @@ -95,19 +83,16 @@ instance MakeFeature AppLockConfig where :* I feat.config.applockInactivityTimeoutSecs :* Nil -instance StoredFeature AppLockConfig where - featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" +instance MakeFeature ClassifiedDomainsConfig where + featureColumns = "" -instance MakeFeature ClassifiedDomainsConfig - -instance MakeFeature FileSharingConfig - -instance StoredFeature FileSharingConfig where +instance MakeFeature FileSharingConfig where featureColumns = "file_sharing" instance MakeFeature ConferenceCallingConfig where type FeatureReadRow ConferenceCallingConfig = '[Maybe FeatureStatus, Maybe One2OneCalls] type FeatureWriteRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] + featureColumns = "conference_calling_status, conference_calling_one_to_one" mkFeature (I status :* I calls :* Nil) = foldMap dbFeatureStatus status @@ -118,12 +103,10 @@ instance MakeFeature ConferenceCallingConfig where :* I feat.config.one2OneCalls :* Nil -instance StoredFeature ConferenceCallingConfig where - featureColumns = "conference_calling_status, conference_calling_one_to_one" - instance MakeFeature SelfDeletingMessagesConfig where type FeatureReadRow SelfDeletingMessagesConfig = '[Maybe FeatureStatus, Maybe Int32] type FeatureWriteRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] + featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" mkFeature (I status :* I ttl :* Nil) = foldMap dbFeatureStatus status @@ -134,27 +117,16 @@ instance MakeFeature SelfDeletingMessagesConfig where :* I feat.config.sdmEnforcedTimeoutSeconds :* Nil -instance StoredFeature SelfDeletingMessagesConfig where - featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" - -instance MakeFeature GuestLinksConfig - -instance StoredFeature GuestLinksConfig where +instance MakeFeature GuestLinksConfig where featureColumns = "guest_links_status" -instance MakeFeature SndFactorPasswordChallengeConfig - -instance StoredFeature SndFactorPasswordChallengeConfig where +instance MakeFeature SndFactorPasswordChallengeConfig where featureColumns = "snd_factor_password_challenge_status" -instance MakeFeature ExposeInvitationURLsToTeamAdminConfig - -instance StoredFeature ExposeInvitationURLsToTeamAdminConfig where +instance MakeFeature ExposeInvitationURLsToTeamAdminConfig where featureColumns = "expose_invitation_urls_to_team_admin" -instance MakeFeature OutlookCalIntegrationConfig - -instance StoredFeature OutlookCalIntegrationConfig where +instance MakeFeature OutlookCalIntegrationConfig where featureColumns = "outlook_cal_integration_status" instance MakeFeature MLSConfig where @@ -177,6 +149,8 @@ instance MakeFeature MLSConfig where CipherSuiteTag, (C.Set ProtocolTag) ] + featureColumns = + "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" mkFeature (I status :* I defProto :* I toggleUsers :* I ciphersuites :* I defCiphersuite :* I supportedProtos :* Nil) = foldMap dbFeatureStatus status @@ -198,10 +172,6 @@ instance MakeFeature MLSConfig where :* I (C.Set feat.config.mlsSupportedProtocols) :* Nil -instance StoredFeature MLSConfig where - featureColumns = - "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" - instance MakeFeature MlsE2EIdConfig where type FeatureReadRow MlsE2EIdConfig = @@ -220,6 +190,8 @@ instance MakeFeature MlsE2EIdConfig where Maybe HttpsUrl, Bool ] + featureColumns = + "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" mkFeature (I status :* I gracePeriod :* I acmeDiscoveryUrl :* I crlProxy :* I useProxyOnMobile :* Nil) = foldMap dbFeatureStatus status @@ -242,10 +214,6 @@ instance MakeFeature MlsE2EIdConfig where :* I feat.config.useProxyOnMobile :* Nil -instance StoredFeature MlsE2EIdConfig where - featureColumns = - "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" - instance MakeFeature MlsMigrationConfig where type FeatureReadRow MlsMigrationConfig = @@ -258,6 +226,9 @@ instance MakeFeature MlsMigrationConfig where FeatureWriteRow MlsMigrationConfig = '[FeatureStatus, Maybe UTCTime, Maybe UTCTime] + featureColumns = + "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" + mkFeature (I status :* I startTime :* I finalizeAfter :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) @@ -268,32 +239,24 @@ instance MakeFeature MlsMigrationConfig where :* I feat.config.finaliseRegardlessAfter :* Nil -instance StoredFeature MlsMigrationConfig where - featureColumns = - "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" - instance MakeFeature EnforceFileDownloadLocationConfig where type FeatureReadRow EnforceFileDownloadLocationConfig = '[Maybe FeatureStatus, Maybe Text] type FeatureWriteRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Maybe Text] + featureColumns = "enforce_file_download_location_status, enforce_file_download_location" + mkFeature (I status :* I location :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) unmkFeature feat = I feat.status :* I feat.config.enforcedDownloadLocation :* Nil -instance StoredFeature EnforceFileDownloadLocationConfig where - featureColumns = "enforce_file_download_location_status, enforce_file_download_location" - -instance MakeFeature LimitedEventFanoutConfig - -instance StoredFeature LimitedEventFanoutConfig where +instance MakeFeature LimitedEventFanoutConfig where featureColumns = "limited_event_fanout_status" getFeature :: forall cfg m. ( MonadClient m, MakeFeature cfg, - StoredFeature cfg, AsTuple (FeatureReadRow cfg), Tuple (TupleP (FeatureReadRow cfg)) ) => @@ -314,7 +277,6 @@ setFeature :: forall cfg m. ( MonadClient m, MakeFeature cfg, - StoredFeature cfg, AsTuple (TeamId ': FeatureWriteRow cfg), Tuple (TupleP (TeamId ': FeatureWriteRow cfg)), KnownNat (Length (TeamId ': FeatureWriteRow cfg)) From 41fd3e00aa0a8a952173218bebd0d3021ff7c484 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 5 Aug 2024 16:52:58 +0200 Subject: [PATCH 12/34] Unify FeatureReadRow and FeatureWriteRow --- .../Cassandra/GetAllTeamFeatureConfigs.hs | 68 +++--- .../src/Galley/Cassandra/MakeFeature.hs | 231 +++++++++--------- 2 files changed, 143 insertions(+), 156 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index b261d2fdaa7..d146451b915 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -138,76 +138,76 @@ emptyRow = allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeatureWithLock allFeatureConfigsFromRow row = AllFeatures - { afcLegalholdStatus = mkFeatureWithLock Nothing (I row.legalhold :* Nil), - afcSSOStatus = mkFeatureWithLock Nothing (I row.sso :* Nil), - afcTeamSearchVisibilityAvailable = mkFeatureWithLock Nothing (I row.searchVisibility :* Nil), - afcSearchVisibilityInboundConfig = mkFeatureWithLock Nothing (I row.searchVisibility :* Nil), - afcValidateSAMLEmails = mkFeatureWithLock Nothing (I row.validateSamlEmails :* Nil), - afcDigitalSignatures = mkFeatureWithLock Nothing (I row.digitalSignatures :* Nil), + { afcLegalholdStatus = mkFeatureWithLock Nothing (row.legalhold :* Nil), + afcSSOStatus = mkFeatureWithLock Nothing (row.sso :* Nil), + afcTeamSearchVisibilityAvailable = mkFeatureWithLock Nothing (row.searchVisibility :* Nil), + afcSearchVisibilityInboundConfig = mkFeatureWithLock Nothing (row.searchVisibility :* Nil), + afcValidateSAMLEmails = mkFeatureWithLock Nothing (row.validateSamlEmails :* Nil), + afcDigitalSignatures = mkFeatureWithLock Nothing (row.digitalSignatures :* Nil), afcAppLock = mkFeatureWithLock Nothing - (I row.appLock :* I row.appLockEnforce :* I row.appLockInactivityTimeoutSecs :* Nil), - afcFileSharing = mkFeatureWithLock row.fileSharingLock (I row.fileSharing :* Nil), - afcClassifiedDomains = mkFeatureWithLock Nothing (I Nothing :* Nil), + (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil), + afcFileSharing = mkFeatureWithLock row.fileSharingLock (row.fileSharing :* Nil), + afcClassifiedDomains = mkFeatureWithLock Nothing (Nothing :* Nil), afcConferenceCalling = mkFeatureWithLock row.conferenceCallingLock - ( I row.conferenceCalling - :* I row.conferenceCallingOne2One + ( row.conferenceCalling + :* row.conferenceCallingOne2One :* Nil ), afcSelfDeletingMessages = mkFeatureWithLock row.selfDeletingMessagesLock - ( I row.selfDeletingMessages - :* I row.selfDeletingMessagesTtl + ( row.selfDeletingMessages + :* row.selfDeletingMessagesTtl :* Nil ), - afcGuestLink = mkFeatureWithLock row.guestLinksLock (I row.guestLinks :* Nil), - afcSndFactorPasswordChallenge = mkFeatureWithLock row.sndFactorLock (I row.sndFactor :* Nil), + afcGuestLink = mkFeatureWithLock row.guestLinksLock (row.guestLinks :* Nil), + afcSndFactorPasswordChallenge = mkFeatureWithLock row.sndFactorLock (row.sndFactor :* Nil), afcMLS = mkFeatureWithLock row.mlsLock - ( I row.mls - :* I row.mlsDefaultProtocol - :* I row.mlsToggleUsers - :* I row.mlsAllowedCipherSuites - :* I row.mlsDefaultCipherSuite - :* I row.mlsSupportedProtocols + ( row.mls + :* row.mlsDefaultProtocol + :* row.mlsToggleUsers + :* row.mlsAllowedCipherSuites + :* row.mlsDefaultCipherSuite + :* row.mlsSupportedProtocols :* Nil ), - afcExposeInvitationURLsToTeamAdmin = mkFeatureWithLock Nothing (I row.exposeInvitationUrls :* Nil), + afcExposeInvitationURLsToTeamAdmin = mkFeatureWithLock Nothing (row.exposeInvitationUrls :* Nil), afcOutlookCalIntegration = mkFeatureWithLock row.outlookCalIntegrationLock - (I row.outlookCalIntegration :* Nil), + (row.outlookCalIntegration :* Nil), afcMlsE2EId = mkFeatureWithLock row.mlsE2eidLock - ( I row.mlsE2eid - :* I row.mlsE2eidGracePeriod - :* I row.mlsE2eidAcmeDiscoverUrl - :* I row.mlsE2eidMaybeCrlProxy - :* I row.mlsE2eidMaybeUseProxyOnMobile + ( row.mlsE2eid + :* row.mlsE2eidGracePeriod + :* row.mlsE2eidAcmeDiscoverUrl + :* row.mlsE2eidMaybeCrlProxy + :* row.mlsE2eidMaybeUseProxyOnMobile :* Nil ), afcMlsMigration = mkFeatureWithLock row.mlsMigrationLock - ( I row.mlsMigration - :* I row.mlsMigrationStartTime - :* I row.mlsMigrationFinalizeRegardlessAfter + ( row.mlsMigration + :* row.mlsMigrationStartTime + :* row.mlsMigrationFinalizeRegardlessAfter :* Nil ), afcEnforceFileDownloadLocation = mkFeatureWithLock row.enforceDownloadLocationLock - ( I row.enforceDownloadLocation - :* I row.enforceDownloadLocation_Location + ( row.enforceDownloadLocation + :* row.enforceDownloadLocation_Location :* Nil ), - afcLimitedEventFanout = mkFeatureWithLock Nothing (I row.limitEventFanout :* Nil) + afcLimitedEventFanout = mkFeatureWithLock Nothing (row.limitEventFanout :* Nil) } getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeatureWithLock) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index eed8254d062..b741b7cf206 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wwarn #-} -- | Abstraction to fetch and store feature values from and to the database. module Galley.Cassandra.MakeFeature where @@ -9,44 +10,42 @@ import Data.Functor import Data.Functor.Identity import Data.Id import Data.Kind -import Data.List.Singletons +import Data.List.Singletons (Length) import Data.Misc (HttpsUrl) -import Data.Singletons +import Data.Singletons (demote) import Data.Time import GHC.TypeNats import Galley.Cassandra.Instances () import Generics.SOP -import Imports hiding (Generic) +import Imports hiding (Generic, Map) import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature class MakeFeature cfg where - type FeatureReadRow cfg :: [Type] - type FeatureReadRow cfg = '[Maybe FeatureStatus] - type FeatureWriteRow cfg :: [Type] - type FeatureWriteRow cfg = '[FeatureStatus] + type FeatureRow cfg :: [Type] + type FeatureRow cfg = '[FeatureStatus] featureColumns :: String - mkFeature :: NP I (FeatureReadRow cfg) -> DbFeature cfg + mkFeature :: NP Maybe (FeatureRow cfg) -> DbFeature cfg default mkFeature :: - (FeatureReadRow cfg ~ '[Maybe FeatureStatus]) => - NP I (FeatureReadRow cfg) -> + (FeatureRow cfg ~ '[FeatureStatus]) => + NP Maybe (FeatureRow cfg) -> DbFeature cfg - mkFeature = foldMap dbFeatureStatus . unI . hd + mkFeature = foldMap dbFeatureStatus . hd - unmkFeature :: Feature cfg -> NP I (FeatureWriteRow cfg) + unmkFeature :: Feature cfg -> NP Maybe (FeatureRow cfg) default unmkFeature :: - (FeatureWriteRow cfg ~ '[FeatureStatus]) => + (FeatureRow cfg ~ '[FeatureStatus]) => Feature cfg -> - NP I (FeatureWriteRow cfg) - unmkFeature feat = I feat.status :* Nil + NP Maybe (FeatureRow cfg) + unmkFeature feat = Just feat.status :* Nil mkFeatureWithLock :: (MakeFeature cfg) => Maybe LockStatus -> - NP I (FeatureReadRow cfg) -> + NP Maybe (FeatureRow cfg) -> DbFeatureWithLock cfg mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) @@ -69,18 +68,17 @@ instance MakeFeature DigitalSignaturesConfig where featureColumns = "digital_signatures" instance MakeFeature AppLockConfig where - type FeatureReadRow AppLockConfig = '[Maybe FeatureStatus, Maybe EnforceAppLock, Maybe Int32] - type FeatureWriteRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] + type FeatureRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" - mkFeature (I status :* I enforce :* I timeout :* Nil) = + mkFeature (status :* enforce :* timeout :* Nil) = foldMap dbFeatureStatus status <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) unmkFeature feat = - I feat.status - :* I feat.config.applockEnforceAppLock - :* I feat.config.applockInactivityTimeoutSecs + Just feat.status + :* Just feat.config.applockEnforceAppLock + :* Just feat.config.applockInactivityTimeoutSecs :* Nil instance MakeFeature ClassifiedDomainsConfig where @@ -90,31 +88,29 @@ instance MakeFeature FileSharingConfig where featureColumns = "file_sharing" instance MakeFeature ConferenceCallingConfig where - type FeatureReadRow ConferenceCallingConfig = '[Maybe FeatureStatus, Maybe One2OneCalls] - type FeatureWriteRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] + type FeatureRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] featureColumns = "conference_calling_status, conference_calling_one_to_one" - mkFeature (I status :* I calls :* Nil) = + mkFeature (status :* calls :* Nil) = foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . ConferenceCallingConfig) calls unmkFeature feat = - I feat.status - :* I feat.config.one2OneCalls + Just feat.status + :* Just feat.config.one2OneCalls :* Nil instance MakeFeature SelfDeletingMessagesConfig where - type FeatureReadRow SelfDeletingMessagesConfig = '[Maybe FeatureStatus, Maybe Int32] - type FeatureWriteRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] + type FeatureRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" - mkFeature (I status :* I ttl :* Nil) = + mkFeature (status :* ttl :* Nil) = foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl unmkFeature feat = - I feat.status - :* I feat.config.sdmEnforcedTimeoutSeconds + Just feat.status + :* Just feat.config.sdmEnforcedTimeoutSeconds :* Nil instance MakeFeature GuestLinksConfig where @@ -131,17 +127,7 @@ instance MakeFeature OutlookCalIntegrationConfig where instance MakeFeature MLSConfig where type - FeatureReadRow MLSConfig = - '[ Maybe FeatureStatus, - Maybe ProtocolTag, - Maybe (C.Set UserId), - Maybe (C.Set CipherSuiteTag), - Maybe CipherSuiteTag, - Maybe (C.Set ProtocolTag) - ] - - type - FeatureWriteRow MLSConfig = + FeatureRow MLSConfig = '[ FeatureStatus, ProtocolTag, (C.Set UserId), @@ -152,48 +138,47 @@ instance MakeFeature MLSConfig where featureColumns = "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" - mkFeature (I status :* I defProto :* I toggleUsers :* I ciphersuites :* I defCiphersuite :* I supportedProtos :* Nil) = - foldMap dbFeatureStatus status - <> foldMap - dbFeatureConfig - ( MLSConfig (foldMap C.fromSet toggleUsers) - <$> defProto - <*> pure (foldMap C.fromSet ciphersuites) - <*> defCiphersuite - <*> pure (foldMap C.fromSet supportedProtos) - ) + mkFeature + ( status + :* defProto + :* toggleUsers + :* ciphersuites + :* defCiphersuite + :* supportedProtos + :* Nil + ) = + foldMap dbFeatureStatus status + <> foldMap + dbFeatureConfig + ( MLSConfig (foldMap C.fromSet toggleUsers) + <$> defProto + <*> pure (foldMap C.fromSet ciphersuites) + <*> defCiphersuite + <*> pure (foldMap C.fromSet supportedProtos) + ) unmkFeature feat = - I feat.status - :* I feat.config.mlsDefaultProtocol - :* I (C.Set feat.config.mlsProtocolToggleUsers) - :* I (C.Set feat.config.mlsAllowedCipherSuites) - :* I feat.config.mlsDefaultCipherSuite - :* I (C.Set feat.config.mlsSupportedProtocols) + Just feat.status + :* Just feat.config.mlsDefaultProtocol + :* Just (C.Set feat.config.mlsProtocolToggleUsers) + :* Just (C.Set feat.config.mlsAllowedCipherSuites) + :* Just feat.config.mlsDefaultCipherSuite + :* Just (C.Set feat.config.mlsSupportedProtocols) :* Nil instance MakeFeature MlsE2EIdConfig where type - FeatureReadRow MlsE2EIdConfig = - '[ Maybe FeatureStatus, - Maybe Int32, - Maybe HttpsUrl, - Maybe HttpsUrl, - Maybe Bool - ] - - type - FeatureWriteRow MlsE2EIdConfig = + FeatureRow MlsE2EIdConfig = '[ FeatureStatus, Int32, - Maybe HttpsUrl, - Maybe HttpsUrl, + HttpsUrl, + HttpsUrl, Bool ] featureColumns = "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" - mkFeature (I status :* I gracePeriod :* I acmeDiscoveryUrl :* I crlProxy :* I useProxyOnMobile :* Nil) = + mkFeature (status :* gracePeriod :* acmeDiscoveryUrl :* crlProxy :* useProxyOnMobile :* Nil) = foldMap dbFeatureStatus status <> dbFeatureModConfig ( \defCfg -> @@ -207,113 +192,96 @@ instance MakeFeature MlsE2EIdConfig where ) unmkFeature feat = - I feat.status - :* I (truncate feat.config.verificationExpiration) - :* I feat.config.acmeDiscoveryUrl - :* I feat.config.crlProxy - :* I feat.config.useProxyOnMobile + Just feat.status + :* Just (truncate feat.config.verificationExpiration) + :* feat.config.acmeDiscoveryUrl + :* feat.config.crlProxy + :* Just feat.config.useProxyOnMobile :* Nil instance MakeFeature MlsMigrationConfig where type - FeatureReadRow MlsMigrationConfig = - '[ Maybe FeatureStatus, - Maybe UTCTime, - Maybe UTCTime - ] - - type - FeatureWriteRow MlsMigrationConfig = - '[FeatureStatus, Maybe UTCTime, Maybe UTCTime] + FeatureRow MlsMigrationConfig = + '[FeatureStatus, UTCTime, UTCTime] featureColumns = "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" - mkFeature (I status :* I startTime :* I finalizeAfter :* Nil) = + mkFeature (status :* startTime :* finalizeAfter :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) unmkFeature feat = - I feat.status - :* I feat.config.startTime - :* I feat.config.finaliseRegardlessAfter + Just feat.status + :* feat.config.startTime + :* feat.config.finaliseRegardlessAfter :* Nil instance MakeFeature EnforceFileDownloadLocationConfig where - type FeatureReadRow EnforceFileDownloadLocationConfig = '[Maybe FeatureStatus, Maybe Text] - type FeatureWriteRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Maybe Text] + type FeatureRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Text] featureColumns = "enforce_file_download_location_status, enforce_file_download_location" - mkFeature (I status :* I location :* Nil) = + mkFeature (status :* location :* Nil) = foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) - unmkFeature feat = I feat.status :* I feat.config.enforcedDownloadLocation :* Nil + unmkFeature feat = Just feat.status :* feat.config.enforcedDownloadLocation :* Nil instance MakeFeature LimitedEventFanoutConfig where featureColumns = "limited_event_fanout_status" getFeature :: - forall cfg m. + forall cfg m row mrow. ( MonadClient m, + row ~ FeatureRow cfg, MakeFeature cfg, - AsTuple (FeatureReadRow cfg), - Tuple (TupleP (FeatureReadRow cfg)) + IsProductType (TupleP mrow) mrow, + AllZip (IsF Maybe) row mrow, + Tuple (TupleP mrow) ) => TeamId -> m (DbFeature cfg) getFeature tid = do row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (mkFeature . fromTuple) row + pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row where selectQ = "select " <> featureColumns @cfg <> " from team_features where team_id = ?" - select :: PrepQuery R (Identity TeamId) (TupleP (FeatureReadRow cfg)) + select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = fromString selectQ setFeature :: - forall cfg m. + forall cfg m row mrow. ( MonadClient m, + row ~ FeatureRow cfg, MakeFeature cfg, - AsTuple (TeamId ': FeatureWriteRow cfg), - Tuple (TupleP (TeamId ': FeatureWriteRow cfg)), - KnownNat (Length (TeamId ': FeatureWriteRow cfg)) + IsProductType (TupleP (TeamId : mrow)) (TeamId : mrow), + AllZip (IsF Maybe) row mrow, + Tuple (TupleP (TeamId : mrow)), + KnownNat (Length row) ) => TeamId -> Feature cfg -> m () setFeature tid feat = do - retry x5 $ write insert (params LocalQuorum (toTuple (I tid :* unmkFeature feat))) + retry x5 $ write insert (params LocalQuorum (productTypeTo (I tid :* factorI (unmkFeature feat)))) where n :: Int - n = fromIntegral (demote @(Length (TeamId ': FeatureWriteRow cfg))) + n = fromIntegral (demote @(Length row)) - insert :: PrepQuery W (TupleP (TeamId ': FeatureWriteRow cfg)) () + insert :: PrepQuery W (TupleP (TeamId ': mrow)) () insert = fromString $ "insert into team_features (team_id, " <> featureColumns @cfg <> ") values (" - <> intercalate "," (replicate n "?") + <> intercalate "," (replicate (succ n) "?") <> ")" -type AsTuple xs = (Code (TupleP xs) ~ '[xs], Generic (TupleP xs)) - -toTuple :: (AsTuple xs) => NP I xs -> TupleP xs -toTuple = to . SOP . Z - -fromTuple :: (AsTuple xs) => TupleP xs -> NP I xs -fromTuple = unZ . unSOP . from - --- | This could be replaced in principle by a type class as follows: --- @@ --- class TupleP xs t --- instance (Code t ~ '[xs], Generic t) => TupleP xs t --- @@ --- but then we wouldn't have the functional dependency xs -> t, which is needed --- to keep inference sane. +-- | This is necessary in order to convert an @NP f xs@ type to something that +-- CQL can understand. type family TupleP (xs :: [Type]) where TupleP '[a] = Identity a TupleP [a, b] = (a, b) @@ -322,3 +290,22 @@ type family TupleP (xs :: [Type]) where TupleP [a, b, c, d, e] = (a, b, c, d, e) TupleP [a, b, c, d, e, f] = (a, b, c, d, e, f) TupleP [a, b, c, d, e, f, g] = (a, b, c, d, e, f, g) + +-- | Convert @NP f [x1, ..., xn]@ to @NP I [f x1, ..., f xn]@. +-- +-- This works because @I . f = f@. +factorI :: forall f xs ys. (AllZip (IsF f) xs ys) => NP f xs -> NP I ys +factorI Nil = Nil +factorI (x :* xs) = I x :* factorI xs + +-- | Convert @NP I [f x1, ..., f xn]@ to @NP f [x1, ..., xn]@. +-- +-- See 'factorI'. +unfactorI :: forall f xs ys. (AllZip (IsF f) xs ys) => NP I ys -> NP f xs +unfactorI Nil = Nil +unfactorI (I x :* xs) = x :* unfactorI xs + +-- | This is to emulate a constraint-level lambda. +class (f x ~ y) => IsF f x y | y -> x + +instance (f x ~ y) => IsF f x y From 1093a94ec64cc5e7af13d4f3a3ddf28f9b8cc018 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 08:23:37 +0200 Subject: [PATCH 13/34] Add lockStatusColumn to MakeFeature --- .../src/Galley/Cassandra/MakeFeature.hs | 34 ++++- .../src/Galley/Cassandra/TeamFeatures.hs | 124 ++++++++---------- 2 files changed, 88 insertions(+), 70 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index b741b7cf206..8f822c0c855 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -27,6 +27,8 @@ class MakeFeature cfg where type FeatureRow cfg = '[FeatureStatus] featureColumns :: String + lockStatusColumn :: Maybe String + lockStatusColumn = Nothing mkFeature :: NP Maybe (FeatureRow cfg) -> DbFeature cfg default mkFeature :: @@ -86,10 +88,12 @@ instance MakeFeature ClassifiedDomainsConfig where instance MakeFeature FileSharingConfig where featureColumns = "file_sharing" + lockStatusColumn = Just "file_sharing_lock_status" instance MakeFeature ConferenceCallingConfig where type FeatureRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] featureColumns = "conference_calling_status, conference_calling_one_to_one" + lockStatusColumn = Just "conference_calling" mkFeature (status :* calls :* Nil) = foldMap dbFeatureStatus status @@ -103,6 +107,7 @@ instance MakeFeature ConferenceCallingConfig where instance MakeFeature SelfDeletingMessagesConfig where type FeatureRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" + lockStatusColumn = Just "self_deleting_messages_lock_status" mkFeature (status :* ttl :* Nil) = foldMap dbFeatureStatus status @@ -115,15 +120,18 @@ instance MakeFeature SelfDeletingMessagesConfig where instance MakeFeature GuestLinksConfig where featureColumns = "guest_links_status" + lockStatusColumn = Just "guest_links_lock_status" instance MakeFeature SndFactorPasswordChallengeConfig where featureColumns = "snd_factor_password_challenge_status" + lockStatusColumn = Just "snd_factor_password_challenge_lock_status" instance MakeFeature ExposeInvitationURLsToTeamAdminConfig where featureColumns = "expose_invitation_urls_to_team_admin" instance MakeFeature OutlookCalIntegrationConfig where featureColumns = "outlook_cal_integration_status" + lockStatusColumn = Just "outlook_cal_integration_lock_status" instance MakeFeature MLSConfig where type @@ -137,6 +145,7 @@ instance MakeFeature MLSConfig where ] featureColumns = "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" + lockStatusColumn = Just "mls_lock_status" mkFeature ( status @@ -177,6 +186,7 @@ instance MakeFeature MlsE2EIdConfig where ] featureColumns = "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" + lockStatusColumn = Just "mls_e2eid_lock_status" mkFeature (status :* gracePeriod :* acmeDiscoveryUrl :* crlProxy :* useProxyOnMobile :* Nil) = foldMap dbFeatureStatus status @@ -206,6 +216,7 @@ instance MakeFeature MlsMigrationConfig where featureColumns = "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" + lockStatusColumn = Just "mls_migration_lock_status" mkFeature (status :* startTime :* finalizeAfter :* Nil) = foldMap dbFeatureStatus status @@ -221,6 +232,7 @@ instance MakeFeature EnforceFileDownloadLocationConfig where type FeatureRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Text] featureColumns = "enforce_file_download_location_status, enforce_file_download_location" + lockStatusColumn = Just "enforce_file_download_location_lock_status" mkFeature (status :* location :* Nil) = foldMap dbFeatureStatus status @@ -230,7 +242,7 @@ instance MakeFeature EnforceFileDownloadLocationConfig where instance MakeFeature LimitedEventFanoutConfig where featureColumns = "limited_event_fanout_status" -getFeature :: +fetchFeature :: forall cfg m row mrow. ( MonadClient m, row ~ FeatureRow cfg, @@ -241,7 +253,7 @@ getFeature :: ) => TeamId -> m (DbFeature cfg) -getFeature tid = do +fetchFeature tid = do row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row where @@ -252,7 +264,7 @@ getFeature tid = do select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = fromString selectQ -setFeature :: +storeFeature :: forall cfg m row mrow. ( MonadClient m, row ~ FeatureRow cfg, @@ -265,7 +277,7 @@ setFeature :: TeamId -> Feature cfg -> m () -setFeature tid feat = do +storeFeature tid feat = do retry x5 $ write insert (params LocalQuorum (productTypeTo (I tid :* factorI (unmkFeature feat)))) where n :: Int @@ -280,6 +292,20 @@ setFeature tid feat = do <> intercalate "," (replicate (succ n) "?") <> ")" +fetchFeatureLockStatus :: + forall cfg m. + (MakeFeature cfg, MonadClient m) => + TeamId -> + m (Maybe LockStatus) +fetchFeatureLockStatus tid = do + case lockStatusColumn @cfg of + Nothing -> pure Nothing + Just col -> do + let select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatus)) + select = fromString $ "select " <> col <> " from team_features where team_id = ?" + row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure $ join $ fmap runIdentity row + -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. type family TupleP (xs :: [Type]) where diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index adc11a33c75..82be8ea61e9 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -66,61 +66,70 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case embedClient $ getAllFeatureConfigs tid getFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (DbFeature cfg) -getFeatureConfig FeatureSingletonLegalholdConfig = getFeature -getFeatureConfig FeatureSingletonSSOConfig = getFeature -getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = getFeature -getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = getFeature +getFeatureConfig FeatureSingletonLegalholdConfig = fetchFeature +getFeatureConfig FeatureSingletonSSOConfig = fetchFeature +getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = fetchFeature +getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = fetchFeature getFeatureConfig FeatureSingletonClassifiedDomainsConfig = const (pure mempty) -getFeatureConfig FeatureSingletonDigitalSignaturesConfig = getFeature -getFeatureConfig FeatureSingletonAppLockConfig = getFeature -getFeatureConfig FeatureSingletonFileSharingConfig = getFeature -getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = getFeature -getFeatureConfig FeatureSingletonConferenceCallingConfig = getFeature -getFeatureConfig FeatureSingletonGuestLinksConfig = getFeature -getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = getFeature -getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = getFeature -getFeatureConfig FeatureSingletonMLSConfig = getFeature -getFeatureConfig FeatureSingletonMlsE2EIdConfig = getFeature -getFeatureConfig FeatureSingletonMlsMigration = getFeature -getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = getFeature -getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = getFeature -getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = getFeature -getFeatureConfig FeatureSingletonLimitedEventFanoutConfig = getFeature +getFeatureConfig FeatureSingletonDigitalSignaturesConfig = fetchFeature +getFeatureConfig FeatureSingletonAppLockConfig = fetchFeature +getFeatureConfig FeatureSingletonFileSharingConfig = fetchFeature +getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = fetchFeature +getFeatureConfig FeatureSingletonConferenceCallingConfig = fetchFeature +getFeatureConfig FeatureSingletonGuestLinksConfig = fetchFeature +getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeature +getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = fetchFeature +getFeatureConfig FeatureSingletonMLSConfig = fetchFeature +getFeatureConfig FeatureSingletonMlsE2EIdConfig = fetchFeature +getFeatureConfig FeatureSingletonMlsMigration = fetchFeature +getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeature +getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = fetchFeature +getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeature +getFeatureConfig FeatureSingletonLimitedEventFanoutConfig = fetchFeature setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () -setFeatureConfig FeatureSingletonLegalholdConfig = setFeature -setFeatureConfig FeatureSingletonSSOConfig = setFeature -setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = setFeature -setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = setFeature +setFeatureConfig FeatureSingletonLegalholdConfig = storeFeature +setFeatureConfig FeatureSingletonSSOConfig = storeFeature +setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = storeFeature +setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = storeFeature setFeatureConfig FeatureSingletonClassifiedDomainsConfig = \_ _ -> pure () -setFeatureConfig FeatureSingletonDigitalSignaturesConfig = setFeature -setFeatureConfig FeatureSingletonAppLockConfig = setFeature -setFeatureConfig FeatureSingletonFileSharingConfig = setFeature -setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = setFeature -setFeatureConfig FeatureSingletonConferenceCallingConfig = setFeature -setFeatureConfig FeatureSingletonGuestLinksConfig = setFeature -setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = setFeature -setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = setFeature -setFeatureConfig FeatureSingletonMLSConfig = setFeature -setFeatureConfig FeatureSingletonMlsE2EIdConfig = setFeature -setFeatureConfig FeatureSingletonMlsMigration = setFeature -setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = setFeature -setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = setFeature -setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = setFeature -setFeatureConfig FeatureSingletonLimitedEventFanoutConfig = setFeature +setFeatureConfig FeatureSingletonDigitalSignaturesConfig = storeFeature +setFeatureConfig FeatureSingletonAppLockConfig = storeFeature +setFeatureConfig FeatureSingletonFileSharingConfig = storeFeature +setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = storeFeature +setFeatureConfig FeatureSingletonConferenceCallingConfig = storeFeature +setFeatureConfig FeatureSingletonGuestLinksConfig = storeFeature +setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = storeFeature +setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = storeFeature +setFeatureConfig FeatureSingletonMLSConfig = storeFeature +setFeatureConfig FeatureSingletonMlsE2EIdConfig = storeFeature +setFeatureConfig FeatureSingletonMlsMigration = storeFeature +setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = storeFeature +setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = storeFeature +setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = storeFeature +setFeatureConfig FeatureSingletonLimitedEventFanoutConfig = storeFeature getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) -getFeatureLockStatus FeatureSingletonFileSharingConfig tid = getLockStatusC "file_sharing_lock_status" tid -getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid = getLockStatusC "self_deleting_messages_lock_status" tid -getFeatureLockStatus FeatureSingletonGuestLinksConfig tid = getLockStatusC "guest_links_lock_status" tid -getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid = getLockStatusC "snd_factor_password_challenge_lock_status" tid -getFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid = getLockStatusC "mls_e2eid_lock_status" tid -getFeatureLockStatus FeatureSingletonMlsMigration tid = getLockStatusC "mls_migration_lock_status" tid -getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid = getLockStatusC "outlook_cal_integration_lock_status" tid -getFeatureLockStatus FeatureSingletonMLSConfig tid = getLockStatusC "mls_lock_status" tid -getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid = getLockStatusC "enforce_file_download_location_lock_status" tid -getFeatureLockStatus FeatureSingletonConferenceCallingConfig tid = getLockStatusC "conference_calling" tid -getFeatureLockStatus _ _ = pure Nothing +getFeatureLockStatus FeatureSingletonLegalholdConfig = fetchFeatureLockStatus @LegalholdConfig +getFeatureLockStatus FeatureSingletonSSOConfig = fetchFeatureLockStatus @SSOConfig +getFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = fetchFeatureLockStatus @SearchVisibilityAvailableConfig +getFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = fetchFeatureLockStatus @ValidateSAMLEmailsConfig +getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = \_ -> pure Nothing +getFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = fetchFeatureLockStatus @DigitalSignaturesConfig +getFeatureLockStatus FeatureSingletonAppLockConfig = fetchFeatureLockStatus @AppLockConfig +getFeatureLockStatus FeatureSingletonFileSharingConfig = fetchFeatureLockStatus @FileSharingConfig +getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = fetchFeatureLockStatus @SelfDeletingMessagesConfig +getFeatureLockStatus FeatureSingletonConferenceCallingConfig = fetchFeatureLockStatus @ConferenceCallingConfig +getFeatureLockStatus FeatureSingletonGuestLinksConfig = fetchFeatureLockStatus @GuestLinksConfig +getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeatureLockStatus @SndFactorPasswordChallengeConfig +getFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = fetchFeatureLockStatus @SearchVisibilityInboundConfig +getFeatureLockStatus FeatureSingletonMLSConfig = fetchFeatureLockStatus @MLSConfig +getFeatureLockStatus FeatureSingletonMlsE2EIdConfig = fetchFeatureLockStatus @MlsE2EIdConfig +getFeatureLockStatus FeatureSingletonMlsMigration = fetchFeatureLockStatus @MlsMigrationConfig +getFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeatureLockStatus @ExposeInvitationURLsToTeamAdminConfig +getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = fetchFeatureLockStatus @OutlookCalIntegrationConfig +getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeatureLockStatus @EnforceFileDownloadLocationConfig +getFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = fetchFeatureLockStatus @LimitedEventFanoutConfig setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockStatus -> m () setFeatureLockStatus FeatureSingletonFileSharingConfig tid feat = setLockStatusC "file_sharing_lock_status" tid feat @@ -135,23 +144,6 @@ setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid feat setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid feat = setLockStatusC "conference_calling" tid feat setFeatureLockStatus _ _tid _status = pure () -getLockStatusC :: - forall m. - (MonadClient m) => - String -> - TeamId -> - m (Maybe LockStatus) -getLockStatusC lockStatusCol tid = do - let q = query1 select (params LocalQuorum (Identity tid)) - (>>= runIdentity) <$> retry x1 q - where - select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatus)) - select = - fromString $ - "select " - <> lockStatusCol - <> " from team_features where team_id = ?" - setLockStatusC :: (MonadClient m) => String -> From 24fc44e1831c03dcec935a59c17000401f7ad246 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 08:38:26 +0200 Subject: [PATCH 14/34] Turn featureColumns into a list --- .../Cassandra/GetAllTeamFeatureConfigs.hs | 2 +- .../src/Galley/Cassandra/MakeFeature.hs | 67 ++++++++++++------- 2 files changed, 45 insertions(+), 24 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index d146451b915..c823c7ba7f4 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -149,7 +149,7 @@ allFeatureConfigsFromRow row = Nothing (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil), afcFileSharing = mkFeatureWithLock row.fileSharingLock (row.fileSharing :* Nil), - afcClassifiedDomains = mkFeatureWithLock Nothing (Nothing :* Nil), + afcClassifiedDomains = mkFeatureWithLock Nothing Nil, afcConferenceCalling = mkFeatureWithLock row.conferenceCallingLock diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 8f822c0c855..d2e796a8f9d 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -26,7 +26,7 @@ class MakeFeature cfg where type FeatureRow cfg :: [Type] type FeatureRow cfg = '[FeatureStatus] - featureColumns :: String + featureColumns :: NP (K String) (FeatureRow cfg) lockStatusColumn :: Maybe String lockStatusColumn = Nothing @@ -52,26 +52,26 @@ mkFeatureWithLock :: mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) instance MakeFeature LegalholdConfig where - featureColumns = "legalhold_status" + featureColumns = K "legalhold_status" :* Nil instance MakeFeature SSOConfig where - featureColumns = "sso_status" + featureColumns = K "sso_status" :* Nil instance MakeFeature SearchVisibilityAvailableConfig where - featureColumns = "search_visibility_status" + featureColumns = K "search_visibility_status" :* Nil instance MakeFeature SearchVisibilityInboundConfig where - featureColumns = "search_visibility_status" + featureColumns = K "search_visibility_status" :* Nil instance MakeFeature ValidateSAMLEmailsConfig where - featureColumns = "validate_saml_emails" + featureColumns = K "validate_saml_emails" :* Nil instance MakeFeature DigitalSignaturesConfig where - featureColumns = "digital_signatures" + featureColumns = K "digital_signatures" :* Nil instance MakeFeature AppLockConfig where type FeatureRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] - featureColumns = "app_lock_status, app_lock_enforce, app_lock_inactivity_timeout_secs" + featureColumns = K "app_lock_status" :* K "app_lock_enforce" :* K "app_lock_inactivity_timeout_secs" :* Nil mkFeature (status :* enforce :* timeout :* Nil) = foldMap dbFeatureStatus status @@ -84,15 +84,19 @@ instance MakeFeature AppLockConfig where :* Nil instance MakeFeature ClassifiedDomainsConfig where - featureColumns = "" + type FeatureRow ClassifiedDomainsConfig = '[] + featureColumns = Nil + + mkFeature Nil = mempty + unmkFeature _ = Nil instance MakeFeature FileSharingConfig where - featureColumns = "file_sharing" + featureColumns = K "file_sharing" :* Nil lockStatusColumn = Just "file_sharing_lock_status" instance MakeFeature ConferenceCallingConfig where type FeatureRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] - featureColumns = "conference_calling_status, conference_calling_one_to_one" + featureColumns = K "conference_calling_status" :* K "conference_calling_one_to_one" :* Nil lockStatusColumn = Just "conference_calling" mkFeature (status :* calls :* Nil) = @@ -106,7 +110,7 @@ instance MakeFeature ConferenceCallingConfig where instance MakeFeature SelfDeletingMessagesConfig where type FeatureRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] - featureColumns = "self_deleting_messages_status, self_deleting_messages_ttl" + featureColumns = K "self_deleting_messages_status" :* K "self_deleting_messages_ttl" :* Nil lockStatusColumn = Just "self_deleting_messages_lock_status" mkFeature (status :* ttl :* Nil) = @@ -119,18 +123,18 @@ instance MakeFeature SelfDeletingMessagesConfig where :* Nil instance MakeFeature GuestLinksConfig where - featureColumns = "guest_links_status" + featureColumns = K "guest_links_status" :* Nil lockStatusColumn = Just "guest_links_lock_status" instance MakeFeature SndFactorPasswordChallengeConfig where - featureColumns = "snd_factor_password_challenge_status" + featureColumns = K "snd_factor_password_challenge_status" :* Nil lockStatusColumn = Just "snd_factor_password_challenge_lock_status" instance MakeFeature ExposeInvitationURLsToTeamAdminConfig where - featureColumns = "expose_invitation_urls_to_team_admin" + featureColumns = K "expose_invitation_urls_to_team_admin" :* Nil instance MakeFeature OutlookCalIntegrationConfig where - featureColumns = "outlook_cal_integration_status" + featureColumns = K "outlook_cal_integration_status" :* Nil lockStatusColumn = Just "outlook_cal_integration_lock_status" instance MakeFeature MLSConfig where @@ -144,7 +148,13 @@ instance MakeFeature MLSConfig where (C.Set ProtocolTag) ] featureColumns = - "mls_status, mls_default_protocol, mls_protocol_toggle_users, mls_allowed_ciphersuites, mls_default_ciphersuite, mls_supported_protocols" + K "mls_status" + :* K "mls_default_protocol" + :* K "mls_protocol_toggle_users" + :* K "mls_allowed_ciphersuites" + :* K "mls_default_ciphersuite" + :* K "mls_supported_protocols" + :* Nil lockStatusColumn = Just "mls_lock_status" mkFeature @@ -185,7 +195,12 @@ instance MakeFeature MlsE2EIdConfig where Bool ] featureColumns = - "mls_e2eid_status, mls_e2eid_grace_period, mls_e2eid_acme_discovery_url, mls_e2eid_crl_proxy, mls_e2eid_use_proxy_on_mobile" + K "mls_e2eid_status" + :* K "mls_e2eid_grace_period" + :* K "mls_e2eid_acme_discovery_url" + :* K "mls_e2eid_crl_proxy" + :* K "mls_e2eid_use_proxy_on_mobile" + :* Nil lockStatusColumn = Just "mls_e2eid_lock_status" mkFeature (status :* gracePeriod :* acmeDiscoveryUrl :* crlProxy :* useProxyOnMobile :* Nil) = @@ -215,7 +230,10 @@ instance MakeFeature MlsMigrationConfig where '[FeatureStatus, UTCTime, UTCTime] featureColumns = - "mls_migration_status, mls_migration_start_time, mls_migration_finalise_regardless_after" + K "mls_migration_status" + :* K "mls_migration_start_time" + :* K "mls_migration_finalise_regardless_after" + :* Nil lockStatusColumn = Just "mls_migration_lock_status" mkFeature (status :* startTime :* finalizeAfter :* Nil) = @@ -231,7 +249,10 @@ instance MakeFeature MlsMigrationConfig where instance MakeFeature EnforceFileDownloadLocationConfig where type FeatureRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Text] - featureColumns = "enforce_file_download_location_status, enforce_file_download_location" + featureColumns = + K "enforce_file_download_location_status" + :* K "enforce_file_download_location" + :* Nil lockStatusColumn = Just "enforce_file_download_location_lock_status" mkFeature (status :* location :* Nil) = @@ -240,7 +261,7 @@ instance MakeFeature EnforceFileDownloadLocationConfig where unmkFeature feat = Just feat.status :* feat.config.enforcedDownloadLocation :* Nil instance MakeFeature LimitedEventFanoutConfig where - featureColumns = "limited_event_fanout_status" + featureColumns = K "limited_event_fanout_status" :* Nil fetchFeature :: forall cfg m row mrow. @@ -259,7 +280,7 @@ fetchFeature tid = do where selectQ = "select " - <> featureColumns @cfg + <> intercalate ", " (hcollapse (featureColumns @cfg)) <> " from team_features where team_id = ?" select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = fromString selectQ @@ -287,7 +308,7 @@ storeFeature tid feat = do insert = fromString $ "insert into team_features (team_id, " - <> featureColumns @cfg + <> intercalate ", " (hcollapse (featureColumns @cfg)) <> ") values (" <> intercalate "," (replicate (succ n) "?") <> ")" From 3ba7688e293ed9d94ed62a72530760b8d9334c4a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 08:44:14 +0200 Subject: [PATCH 15/34] Extend MakeFeature abstraction to nullary features --- .../src/Galley/Cassandra/MakeFeature.hs | 31 +++++++++++++------ .../src/Galley/Cassandra/TeamFeatures.hs | 6 ++-- 2 files changed, 24 insertions(+), 13 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index d2e796a8f9d..eb0e60a5e4c 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -275,15 +275,18 @@ fetchFeature :: TeamId -> m (DbFeature cfg) fetchFeature tid = do - row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row - where - selectQ = - "select " - <> intercalate ", " (hcollapse (featureColumns @cfg)) - <> " from team_features where team_id = ?" - select :: PrepQuery R (Identity TeamId) (TupleP mrow) - select = fromString selectQ + let cols = hcollapse (featureColumns @cfg) + if null cols + then pure mempty + else do + let select :: PrepQuery R (Identity TeamId) (TupleP mrow) + select = + fromString $ + "select " + <> intercalate ", " cols + <> " from team_features where team_id = ?" + row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row storeFeature :: forall cfg m row mrow. @@ -299,7 +302,14 @@ storeFeature :: Feature cfg -> m () storeFeature tid feat = do - retry x5 $ write insert (params LocalQuorum (productTypeTo (I tid :* factorI (unmkFeature feat)))) + if n == 0 + then pure () + else + retry x5 $ + write + insert + ( params LocalQuorum (productTypeTo (I tid :* factorI (unmkFeature feat))) + ) where n :: Int n = fromIntegral (demote @(Length row)) @@ -330,6 +340,7 @@ fetchFeatureLockStatus tid = do -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. type family TupleP (xs :: [Type]) where + TupleP '[] = () TupleP '[a] = Identity a TupleP [a, b] = (a, b) TupleP [a, b, c] = (a, b, c) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 82be8ea61e9..70b7920bee0 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -70,7 +70,7 @@ getFeatureConfig FeatureSingletonLegalholdConfig = fetchFeature getFeatureConfig FeatureSingletonSSOConfig = fetchFeature getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = fetchFeature getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = fetchFeature -getFeatureConfig FeatureSingletonClassifiedDomainsConfig = const (pure mempty) +getFeatureConfig FeatureSingletonClassifiedDomainsConfig = fetchFeature getFeatureConfig FeatureSingletonDigitalSignaturesConfig = fetchFeature getFeatureConfig FeatureSingletonAppLockConfig = fetchFeature getFeatureConfig FeatureSingletonFileSharingConfig = fetchFeature @@ -92,7 +92,7 @@ setFeatureConfig FeatureSingletonLegalholdConfig = storeFeature setFeatureConfig FeatureSingletonSSOConfig = storeFeature setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = storeFeature setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = storeFeature -setFeatureConfig FeatureSingletonClassifiedDomainsConfig = \_ _ -> pure () +setFeatureConfig FeatureSingletonClassifiedDomainsConfig = storeFeature setFeatureConfig FeatureSingletonDigitalSignaturesConfig = storeFeature setFeatureConfig FeatureSingletonAppLockConfig = storeFeature setFeatureConfig FeatureSingletonFileSharingConfig = storeFeature @@ -114,7 +114,7 @@ getFeatureLockStatus FeatureSingletonLegalholdConfig = fetchFeatureLockStatus @L getFeatureLockStatus FeatureSingletonSSOConfig = fetchFeatureLockStatus @SSOConfig getFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = fetchFeatureLockStatus @SearchVisibilityAvailableConfig getFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = fetchFeatureLockStatus @ValidateSAMLEmailsConfig -getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = \_ -> pure Nothing +getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = fetchFeatureLockStatus @ClassifiedDomainsConfig getFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = fetchFeatureLockStatus @DigitalSignaturesConfig getFeatureLockStatus FeatureSingletonAppLockConfig = fetchFeatureLockStatus @AppLockConfig getFeatureLockStatus FeatureSingletonFileSharingConfig = fetchFeatureLockStatus @FileSharingConfig From c503c87eb126bb2f05c6b0db877b6bb5eeb4d458 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 08:46:51 +0200 Subject: [PATCH 16/34] Use Tagged to improve type inference --- .../src/Galley/Cassandra/MakeFeature.hs | 6 +-- .../src/Galley/Cassandra/TeamFeatures.hs | 48 ++++++++++--------- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index eb0e60a5e4c..73a226fae0a 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -327,15 +327,15 @@ fetchFeatureLockStatus :: forall cfg m. (MakeFeature cfg, MonadClient m) => TeamId -> - m (Maybe LockStatus) + m (Tagged cfg (Maybe LockStatus)) fetchFeatureLockStatus tid = do case lockStatusColumn @cfg of - Nothing -> pure Nothing + Nothing -> pure (Tagged Nothing) Just col -> do let select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatus)) select = fromString $ "select " <> col <> " from team_features where team_id = ?" row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ join $ fmap runIdentity row + pure . Tagged . join . fmap runIdentity $ row -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 70b7920bee0..21e28a90687 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -57,7 +57,7 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case embedClient $ setFeatureConfig sing tid wsnl TFS.GetFeatureLockStatus sing tid -> do logEffect "TeamFeatureStore.GetFeatureLockStatus" - embedClient $ getFeatureLockStatus sing tid + fmap untag . embedClient $ getFeatureLockStatus sing tid TFS.SetFeatureLockStatus sing tid ls -> do logEffect "TeamFeatureStore.SetFeatureLockStatus" embedClient $ setFeatureLockStatus sing tid ls @@ -109,27 +109,31 @@ setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = storeFeature setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = storeFeature setFeatureConfig FeatureSingletonLimitedEventFanoutConfig = storeFeature -getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Maybe LockStatus) -getFeatureLockStatus FeatureSingletonLegalholdConfig = fetchFeatureLockStatus @LegalholdConfig -getFeatureLockStatus FeatureSingletonSSOConfig = fetchFeatureLockStatus @SSOConfig -getFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = fetchFeatureLockStatus @SearchVisibilityAvailableConfig -getFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = fetchFeatureLockStatus @ValidateSAMLEmailsConfig -getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = fetchFeatureLockStatus @ClassifiedDomainsConfig -getFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = fetchFeatureLockStatus @DigitalSignaturesConfig -getFeatureLockStatus FeatureSingletonAppLockConfig = fetchFeatureLockStatus @AppLockConfig -getFeatureLockStatus FeatureSingletonFileSharingConfig = fetchFeatureLockStatus @FileSharingConfig -getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = fetchFeatureLockStatus @SelfDeletingMessagesConfig -getFeatureLockStatus FeatureSingletonConferenceCallingConfig = fetchFeatureLockStatus @ConferenceCallingConfig -getFeatureLockStatus FeatureSingletonGuestLinksConfig = fetchFeatureLockStatus @GuestLinksConfig -getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeatureLockStatus @SndFactorPasswordChallengeConfig -getFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = fetchFeatureLockStatus @SearchVisibilityInboundConfig -getFeatureLockStatus FeatureSingletonMLSConfig = fetchFeatureLockStatus @MLSConfig -getFeatureLockStatus FeatureSingletonMlsE2EIdConfig = fetchFeatureLockStatus @MlsE2EIdConfig -getFeatureLockStatus FeatureSingletonMlsMigration = fetchFeatureLockStatus @MlsMigrationConfig -getFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeatureLockStatus @ExposeInvitationURLsToTeamAdminConfig -getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = fetchFeatureLockStatus @OutlookCalIntegrationConfig -getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeatureLockStatus @EnforceFileDownloadLocationConfig -getFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = fetchFeatureLockStatus @LimitedEventFanoutConfig +getFeatureLockStatus :: + (MonadClient m) => + FeatureSingleton cfg -> + TeamId -> + m (Tagged cfg (Maybe LockStatus)) +getFeatureLockStatus FeatureSingletonLegalholdConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonSSOConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonAppLockConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonFileSharingConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonConferenceCallingConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonGuestLinksConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonMLSConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonMlsE2EIdConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonMlsMigration = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeatureLockStatus +getFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = fetchFeatureLockStatus setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockStatus -> m () setFeatureLockStatus FeatureSingletonFileSharingConfig tid feat = setLockStatusC "file_sharing_lock_status" tid feat From f0f551ca05bc9c0968906f22cb18413171bb84a1 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 08:51:53 +0200 Subject: [PATCH 17/34] Add storeFeatureLockStatus --- .../src/Galley/Cassandra/MakeFeature.hs | 14 ++++++ .../src/Galley/Cassandra/TeamFeatures.hs | 48 +++++++++---------- 2 files changed, 38 insertions(+), 24 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 73a226fae0a..797b5f2c017 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -337,6 +337,20 @@ fetchFeatureLockStatus tid = do row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) pure . Tagged . join . fmap runIdentity $ row +storeFeatureLockStatus :: + forall cfg m. + (MakeFeature cfg, MonadClient m) => + TeamId -> + Tagged cfg LockStatus -> + m () +storeFeatureLockStatus tid lock = do + case lockStatusColumn @cfg of + Nothing -> pure () + Just col -> do + let insert :: PrepQuery W (TeamId, LockStatus) () + insert = fromString $ "insert into team_features (team_id, " <> col <> ") values (?, ?)" + retry x5 $ write insert (params LocalQuorum (tid, untag lock)) + -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. type family TupleP (xs :: [Type]) where diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 21e28a90687..42f21667c4c 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -60,7 +60,7 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case fmap untag . embedClient $ getFeatureLockStatus sing tid TFS.SetFeatureLockStatus sing tid ls -> do logEffect "TeamFeatureStore.SetFeatureLockStatus" - embedClient $ setFeatureLockStatus sing tid ls + embedClient $ setFeatureLockStatus sing tid (Tagged ls) TFS.GetAllFeatureConfigs tid -> do logEffect "TeamFeatureStore.GetAllFeatureConfigs" embedClient $ getAllFeatureConfigs tid @@ -135,32 +135,32 @@ getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = fetchFeatureL getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeatureLockStatus getFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = fetchFeatureLockStatus -setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockStatus -> m () -setFeatureLockStatus FeatureSingletonFileSharingConfig tid feat = setLockStatusC "file_sharing_lock_status" tid feat -setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig tid feat = setLockStatusC "self_deleting_messages_lock_status" tid feat -setFeatureLockStatus FeatureSingletonGuestLinksConfig tid feat = setLockStatusC "guest_links_lock_status" tid feat -setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig tid feat = setLockStatusC "snd_factor_password_challenge_lock_status" tid feat -setFeatureLockStatus FeatureSingletonMlsE2EIdConfig tid feat = setLockStatusC "mls_e2eid_lock_status" tid feat -setFeatureLockStatus FeatureSingletonMlsMigration tid feat = setLockStatusC "mls_migration_lock_status" tid feat -setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig tid feat = setLockStatusC "outlook_cal_integration_lock_status" tid feat -setFeatureLockStatus FeatureSingletonMLSConfig tid feat = setLockStatusC "mls_lock_status" tid feat -setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig tid feat = setLockStatusC "enforce_file_download_location_lock_status" tid feat -setFeatureLockStatus FeatureSingletonConferenceCallingConfig tid feat = setLockStatusC "conference_calling" tid feat -setFeatureLockStatus _ _tid _status = pure () - -setLockStatusC :: +setFeatureLockStatus :: (MonadClient m) => - String -> + FeatureSingleton cfg -> TeamId -> - LockStatus -> + Tagged cfg LockStatus -> m () -setLockStatusC col tid status = do - retry x5 $ write insert (params LocalQuorum (tid, status)) - where - insert :: PrepQuery W (TeamId, LockStatus) () - insert = - fromString $ - "insert into team_features (team_id, " <> col <> ") values (?, ?)" +setFeatureLockStatus FeatureSingletonLegalholdConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonSSOConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonAppLockConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonFileSharingConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonConferenceCallingConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonGuestLinksConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonMLSConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonMlsE2EIdConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonMlsMigration = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = storeFeatureLockStatus +setFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = storeFeatureLockStatus getFeatureConfigMulti :: forall cfg m. From aa5183cad829b49a06c1297a6d880f3413f2138c Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 09:24:48 +0200 Subject: [PATCH 18/34] Use TH to generate feature singleton cases --- services/galley/galley.cabal | 2 + .../galley/src/Galley/Cassandra/FeatureTH.hs | 18 +++ .../src/Galley/Cassandra/MakeFeature.hs | 3 + .../src/Galley/Cassandra/TeamFeatures.hs | 105 +++--------------- 4 files changed, 39 insertions(+), 89 deletions(-) create mode 100644 services/galley/src/Galley/Cassandra/FeatureTH.hs diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 0989055f875..649855d508a 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -136,6 +136,7 @@ library Galley.Cassandra.Conversation.MLS Galley.Cassandra.ConversationList Galley.Cassandra.CustomBackend + Galley.Cassandra.FeatureTH Galley.Cassandra.GetAllTeamFeatureConfigs Galley.Cassandra.Instances Galley.Cassandra.LegalHold @@ -350,6 +351,7 @@ library , ssl-util >=0.1 , stm >=2.4 , tagged + , template-haskell , text >=0.11 , time >=1.4 , tinylog >=0.10 diff --git a/services/galley/src/Galley/Cassandra/FeatureTH.hs b/services/galley/src/Galley/Cassandra/FeatureTH.hs new file mode 100644 index 00000000000..d4583cd0c27 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/FeatureTH.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Galley.Cassandra.FeatureTH where + +import Imports +import Language.Haskell.TH +import Wire.API.Team.Feature + +featureCases :: ExpQ -> Q Exp +featureCases rhsQ = do + rhs <- rhsQ + TyConI (DataD _ _ _ _ constructors _) <- reify ''FeatureSingleton + pure $ + LamCaseE + [ Match (ConP c [] []) (NormalB rhs) [] + | GadtC [c] _ _ <- constructors + ] diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 797b5f2c017..7708921e9fd 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wwarn #-} -- | Abstraction to fetch and store feature values from and to the database. @@ -10,6 +12,7 @@ import Data.Functor import Data.Functor.Identity import Data.Id import Data.Kind +import Data.List (nub) import Data.List.Singletons (Length) import Data.Misc (HttpsUrl) import Data.Singletons (demote) diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 42f21667c4c..0cc657987a7 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -25,6 +27,7 @@ where import Cassandra import Data.Id import Galley.API.Teams.Features.Get +import Galley.Cassandra.FeatureTH import Galley.Cassandra.GetAllTeamFeatureConfigs import Galley.Cassandra.Instances () import Galley.Cassandra.MakeFeature @@ -65,75 +68,27 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case logEffect "TeamFeatureStore.GetAllFeatureConfigs" embedClient $ getAllFeatureConfigs tid +getFeatureConfigMulti :: + forall cfg m. + (MonadClient m, MonadUnliftIO m) => + FeatureSingleton cfg -> + [TeamId] -> + m [(TeamId, DbFeature cfg)] +getFeatureConfigMulti proxy = + pooledMapConcurrentlyN 8 (\tid -> getFeatureConfig proxy tid <&> (tid,)) + getFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (DbFeature cfg) -getFeatureConfig FeatureSingletonLegalholdConfig = fetchFeature -getFeatureConfig FeatureSingletonSSOConfig = fetchFeature -getFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = fetchFeature -getFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = fetchFeature -getFeatureConfig FeatureSingletonClassifiedDomainsConfig = fetchFeature -getFeatureConfig FeatureSingletonDigitalSignaturesConfig = fetchFeature -getFeatureConfig FeatureSingletonAppLockConfig = fetchFeature -getFeatureConfig FeatureSingletonFileSharingConfig = fetchFeature -getFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = fetchFeature -getFeatureConfig FeatureSingletonConferenceCallingConfig = fetchFeature -getFeatureConfig FeatureSingletonGuestLinksConfig = fetchFeature -getFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeature -getFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = fetchFeature -getFeatureConfig FeatureSingletonMLSConfig = fetchFeature -getFeatureConfig FeatureSingletonMlsE2EIdConfig = fetchFeature -getFeatureConfig FeatureSingletonMlsMigration = fetchFeature -getFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeature -getFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = fetchFeature -getFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeature -getFeatureConfig FeatureSingletonLimitedEventFanoutConfig = fetchFeature +getFeatureConfig = $(featureCases [|fetchFeature|]) setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () -setFeatureConfig FeatureSingletonLegalholdConfig = storeFeature -setFeatureConfig FeatureSingletonSSOConfig = storeFeature -setFeatureConfig FeatureSingletonSearchVisibilityAvailableConfig = storeFeature -setFeatureConfig FeatureSingletonValidateSAMLEmailsConfig = storeFeature -setFeatureConfig FeatureSingletonClassifiedDomainsConfig = storeFeature -setFeatureConfig FeatureSingletonDigitalSignaturesConfig = storeFeature -setFeatureConfig FeatureSingletonAppLockConfig = storeFeature -setFeatureConfig FeatureSingletonFileSharingConfig = storeFeature -setFeatureConfig FeatureSingletonSelfDeletingMessagesConfig = storeFeature -setFeatureConfig FeatureSingletonConferenceCallingConfig = storeFeature -setFeatureConfig FeatureSingletonGuestLinksConfig = storeFeature -setFeatureConfig FeatureSingletonSndFactorPasswordChallengeConfig = storeFeature -setFeatureConfig FeatureSingletonSearchVisibilityInboundConfig = storeFeature -setFeatureConfig FeatureSingletonMLSConfig = storeFeature -setFeatureConfig FeatureSingletonMlsE2EIdConfig = storeFeature -setFeatureConfig FeatureSingletonMlsMigration = storeFeature -setFeatureConfig FeatureSingletonExposeInvitationURLsToTeamAdminConfig = storeFeature -setFeatureConfig FeatureSingletonOutlookCalIntegrationConfig = storeFeature -setFeatureConfig FeatureSingletonEnforceFileDownloadLocationConfig = storeFeature -setFeatureConfig FeatureSingletonLimitedEventFanoutConfig = storeFeature +setFeatureConfig = $(featureCases [|storeFeature|]) getFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (Tagged cfg (Maybe LockStatus)) -getFeatureLockStatus FeatureSingletonLegalholdConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonSSOConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonAppLockConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonFileSharingConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonConferenceCallingConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonGuestLinksConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonMLSConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonMlsE2EIdConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonMlsMigration = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = fetchFeatureLockStatus -getFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = fetchFeatureLockStatus +getFeatureLockStatus = $(featureCases [|fetchFeatureLockStatus|]) setFeatureLockStatus :: (MonadClient m) => @@ -141,32 +96,4 @@ setFeatureLockStatus :: TeamId -> Tagged cfg LockStatus -> m () -setFeatureLockStatus FeatureSingletonLegalholdConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonSSOConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonSearchVisibilityAvailableConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonValidateSAMLEmailsConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonClassifiedDomainsConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonDigitalSignaturesConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonAppLockConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonFileSharingConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonSelfDeletingMessagesConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonConferenceCallingConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonGuestLinksConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonSndFactorPasswordChallengeConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonSearchVisibilityInboundConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonMLSConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonMlsE2EIdConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonMlsMigration = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonExposeInvitationURLsToTeamAdminConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonOutlookCalIntegrationConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonEnforceFileDownloadLocationConfig = storeFeatureLockStatus -setFeatureLockStatus FeatureSingletonLimitedEventFanoutConfig = storeFeatureLockStatus - -getFeatureConfigMulti :: - forall cfg m. - (MonadClient m, MonadUnliftIO m) => - FeatureSingleton cfg -> - [TeamId] -> - m [(TeamId, DbFeature cfg)] -getFeatureConfigMulti proxy = - pooledMapConcurrentlyN 8 (\tid -> getFeatureConfig proxy tid <&> (tid,)) +setFeatureLockStatus = $(featureCases [|storeFeatureLockStatus|]) From 325b2988ace8b70c0f9131e055e3a8c4e5bed10e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 09:37:43 +0200 Subject: [PATCH 19/34] Rename unDbFeature to applyDbFeature --- libs/wire-api/src/Wire/API/Team/Feature.hs | 4 ++-- services/galley/src/Galley/API/LegalHold/Team.hs | 2 +- services/galley/src/Galley/API/Teams/Features/Get.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 48ece001f8d..f7d3b1e974d 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -220,7 +220,7 @@ featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg)) -- | Feature data stored in the database, as a function of its default values. newtype DbFeature cfg = DbFeature - {unDbFeature :: Feature cfg -> Feature cfg} + {applyDbFeature :: Feature cfg -> Feature cfg} instance Semigroup (DbFeature cfg) where DbFeature f <> DbFeature g = DbFeature (f . g) @@ -555,7 +555,7 @@ genericComputeFeature :: genericComputeFeature defFeature lockStatus dbFeature = case fromMaybe defFeature.lockStatus lockStatus of LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} - LockStatusUnlocked -> withUnlocked $ unDbFeature dbFeature (forgetLock defFeature) + LockStatusUnlocked -> withUnlocked $ applyDbFeature dbFeature (forgetLock defFeature) -------------------------------------------------------------------------------- -- GuestLinks feature diff --git a/services/galley/src/Galley/API/LegalHold/Team.hs b/services/galley/src/Galley/API/LegalHold/Team.hs index de1a37f6892..c62137f4e1a 100644 --- a/services/galley/src/Galley/API/LegalHold/Team.hs +++ b/services/galley/src/Galley/API/LegalHold/Team.hs @@ -64,7 +64,7 @@ computeLegalHoldFeatureStatus tid dbFeature = getLegalHoldFlag >>= \case FeatureLegalHoldDisabledPermanently -> pure FeatureStatusDisabled FeatureLegalHoldDisabledByDefault -> - pure (unDbFeature dbFeature def).status + pure (applyDbFeature dbFeature def).status FeatureLegalHoldWhitelistTeamsAndImplicitConsent -> do wl <- LegalHoldData.isTeamLegalholdWhitelisted tid pure $ if wl then FeatureStatusEnabled else FeatureStatusDisabled diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index fbfddc5171b..324aeb00ac7 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -463,7 +463,7 @@ instance GetFeatureConfig ConferenceCallingConfig where LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} LockStatusUnlocked -> withUnlocked $ - (unDbFeature dbFeature) + (applyDbFeature dbFeature) (forgetLock defFeature) { status = FeatureStatusEnabled } From a15c86b050e76ae7801985a56a5b54f2165e1ca5 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Tue, 6 Aug 2024 14:15:39 +0200 Subject: [PATCH 20/34] [feat] galley - make compile with AllFeatures represented as NP - rewrite boilerplate to NP combinators - regeneate nix derivations - format all - make galley, wire-subsystems and wire-api compile --- libs/galley-types/default.nix | 2 + libs/wire-api/src/Wire/API/Team/Feature.hs | 198 +++++++++--------- .../golden/Test/Wire/API/Golden/FromJSON.hs | 2 +- .../golden/Test/Wire/API/Golden/Generated.hs | 6 +- .../src/Wire/UserSubsystem/Interpreter.hs | 3 +- .../Wire/UserSubsystem/InterpreterSpec.hs | 18 +- services/brig/src/Brig/Calling/API.hs | 4 +- services/brig/src/Brig/Provider/API.hs | 8 +- services/galley/default.nix | 8 + .../src/Galley/API/Teams/Features/Get.hs | 124 +++-------- .../Cassandra/GetAllTeamFeatureConfigs.hs | 93 ++------ .../src/Galley/Cassandra/MakeFeature.hs | 5 +- tools/stern/default.nix | 2 + 13 files changed, 188 insertions(+), 285 deletions(-) diff --git a/libs/galley-types/default.nix b/libs/galley-types/default.nix index c67ae7c7cb1..f977e3444c9 100644 --- a/libs/galley-types/default.nix +++ b/libs/galley-types/default.nix @@ -9,6 +9,7 @@ , bytestring-conversion , containers , crypton +, data-default , errors , gitignoreSource , imports @@ -34,6 +35,7 @@ mkDerivation { bytestring-conversion containers crypton + data-default errors imports lens diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index f7d3b1e974d..aa4174ba35b 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -1,8 +1,12 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE NoStarIsType #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. @@ -73,7 +77,12 @@ module Wire.API.Team.Feature MlsMigrationConfig (..), EnforceFileDownloadLocationConfig (..), LimitedEventFanoutConfig (..), - AllFeatures (..), + Features, + AllFeatures, + NpProject (..), + npProject, + NpUpdate (..), + npUpdate, AllFeatureConfigs, unImplicitLockStatus, ImplicitLockStatus (..), @@ -97,6 +106,7 @@ import Data.Kind import Data.Misc (HttpsUrl) import Data.OpenApi qualified as S import Data.Proxy +import Data.SOP import Data.Schema import Data.Scientific (toBoundedInteger) import Data.Text qualified as T @@ -1267,117 +1277,107 @@ instance Cass.Cql FeatureStatus where toCql FeatureStatusDisabled = Cass.CqlInt 0 toCql FeatureStatusEnabled = Cass.CqlInt 1 --- FUTUREWORK: rewrite using SOP -data AllFeatures f = AllFeatures - { afcLegalholdStatus :: f LegalholdConfig, - afcSSOStatus :: f SSOConfig, - afcTeamSearchVisibilityAvailable :: f SearchVisibilityAvailableConfig, - afcSearchVisibilityInboundConfig :: f SearchVisibilityInboundConfig, - afcValidateSAMLEmails :: f ValidateSAMLEmailsConfig, - afcDigitalSignatures :: f DigitalSignaturesConfig, - afcAppLock :: f AppLockConfig, - afcFileSharing :: f FileSharingConfig, - afcClassifiedDomains :: f ClassifiedDomainsConfig, - afcConferenceCalling :: f ConferenceCallingConfig, - afcSelfDeletingMessages :: f SelfDeletingMessagesConfig, - afcGuestLink :: f GuestLinksConfig, - afcSndFactorPasswordChallenge :: f SndFactorPasswordChallengeConfig, - afcMLS :: f MLSConfig, - afcExposeInvitationURLsToTeamAdmin :: f ExposeInvitationURLsToTeamAdminConfig, - afcOutlookCalIntegration :: f OutlookCalIntegrationConfig, - afcMlsE2EId :: f MlsE2EIdConfig, - afcMlsMigration :: f MlsMigrationConfig, - afcEnforceFileDownloadLocation :: f EnforceFileDownloadLocationConfig, - afcLimitedEventFanout :: f LimitedEventFanoutConfig - } - +-- | list of available features config types +type Features :: [Type] +type Features = + [ LegalholdConfig, + SSOConfig, + SearchVisibilityAvailableConfig, + SearchVisibilityInboundConfig, + ValidateSAMLEmailsConfig, + DigitalSignaturesConfig, + AppLockConfig, + FileSharingConfig, + ClassifiedDomainsConfig, + ConferenceCallingConfig, + SelfDeletingMessagesConfig, + GuestLinksConfig, + SndFactorPasswordChallengeConfig, + MLSConfig, + ExposeInvitationURLsToTeamAdminConfig, + OutlookCalIntegrationConfig, + MlsE2EIdConfig, + MlsMigrationConfig, + EnforceFileDownloadLocationConfig, + LimitedEventFanoutConfig + ] + +-- | list of available features as a record +type AllFeatures f = NP f Features + +-- | 'AllFeatures' specialised to the 'LockableFeature' functor type AllFeatureConfigs = AllFeatures LockableFeature +-- | constraint synonym requiring the @c@ instance for the @f@ type constructor applied to type @a@ to hold +class (c (f a)) => LiftForF c f a + +instance (c (f a)) => LiftForF c f a + +type LockableFeatureDefault = LiftForF Default LockableFeature + instance Default AllFeatureConfigs where - def = - AllFeatures - { afcLegalholdStatus = def, - afcSSOStatus = def, - afcTeamSearchVisibilityAvailable = def, - afcSearchVisibilityInboundConfig = def, - afcValidateSAMLEmails = def, - afcDigitalSignatures = def, - afcAppLock = def, - afcFileSharing = def, - afcClassifiedDomains = def, - afcConferenceCalling = def, - afcSelfDeletingMessages = def, - afcGuestLink = def, - afcSndFactorPasswordChallenge = def, - afcMLS = def, - afcExposeInvitationURLsToTeamAdmin = def, - afcOutlookCalIntegration = def, - afcMlsE2EId = def, - afcMlsMigration = def, - afcEnforceFileDownloadLocation = def, - afcLimitedEventFanout = def - } + def = hcpure (Proxy @LockableFeatureDefault) def + +-- | object schema for nary products +-- +-- TODO(mangoiv): generalize this to be useable with schema profunctor +class HObjectSchema c xs where + hobjectSchema :: (forall cfg. (c cfg) => ObjectSchema SwaggerDoc (f cfg)) -> ObjectSchema SwaggerDoc (NP f xs) + +instance HObjectSchema c '[] where + hobjectSchema _ = pure Nil + +instance (HObjectSchema c xs, c x) => HObjectSchema c ((x :: Type) : xs) where + hobjectSchema f = (:*) <$> hd .= f <*> tl .= hobjectSchema @c @xs f + +-- | constraint synonym for 'ToSchema' 'AllFeatureConfigs' +class (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => FeatureFieldConstraints cfg + +instance (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => FeatureFieldConstraints cfg instance ToSchema AllFeatureConfigs where schema = - object "AllFeatureConfigs" $ - AllFeatures - <$> afcLegalholdStatus .= featureField - <*> afcSSOStatus .= featureField - <*> afcTeamSearchVisibilityAvailable .= featureField - <*> afcSearchVisibilityInboundConfig .= featureField - <*> afcValidateSAMLEmails .= featureField - <*> afcDigitalSignatures .= featureField - <*> afcAppLock .= featureField - <*> afcFileSharing .= featureField - <*> afcClassifiedDomains .= featureField - <*> afcConferenceCalling .= featureField - <*> afcSelfDeletingMessages .= featureField - <*> afcGuestLink .= featureField - <*> afcSndFactorPasswordChallenge .= featureField - <*> afcMLS .= featureField - <*> afcExposeInvitationURLsToTeamAdmin .= featureField - <*> afcOutlookCalIntegration .= featureField - <*> afcMlsE2EId .= featureField - <*> afcMlsMigration .= featureField - <*> afcEnforceFileDownloadLocation .= featureField - <*> afcLimitedEventFanout .= featureField + object "AllFeatureConfigs" $ hobjectSchema @FeatureFieldConstraints featureField where - featureField :: - forall cfg. - (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => - ObjectSchema SwaggerDoc (LockableFeature cfg) + featureField :: forall cfg. (FeatureFieldConstraints cfg) => ObjectSchema SwaggerDoc (LockableFeature cfg) featureField = field (T.pack (symbolVal (Proxy @(FeatureSymbol cfg)))) schema instance Arbitrary AllFeatureConfigs where - arbitrary = - AllFeatures - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = hsequence' $ hcpure (Proxy @(LiftForF Arbitrary LockableFeature)) (Comp arbitrary) -makeLenses ''ImplicitLockStatus +class NpProject x xs where + npProject' :: Proxy x -> NP f xs -> f x + +instance {-# OVERLAPPING #-} NpProject x (x : xs) where + npProject' _ (x :* _) = x + +instance (NpProject x xs) => NpProject x (y : xs) where + npProject' p (_ :* xs) = npProject' p xs + +instance (TypeError ('ShowType x :<>: 'Text " not found")) => NpProject x '[] where + npProject' = error "npProject': someone naughty removed the type error constraint" + +-- | Get the first field of a given type out of an @'NP' f xs@. +npProject :: forall x f xs. (NpProject x xs) => NP f xs -> f x +npProject = npProject' (Proxy @x) -deriving instance Show AllFeatureConfigs +class NpUpdate x xs where + npUpdate' :: Proxy x -> f x -> NP f xs -> NP f xs -deriving instance Eq AllFeatureConfigs +instance {-# OVERLAPPING #-} NpUpdate x (x : xs) where + npUpdate' _ x (_ :* xs) = x :* xs + +instance (NpUpdate x xs) => NpUpdate x (y : xs) where + npUpdate' p x (y :* xs) = y :* npUpdate' p x xs + +instance (TypeError ('ShowType x :<>: 'Text " not found")) => NpUpdate x '[] where + npUpdate' = error "npUpdate': someone naughty removed the type error constraint" + +-- | Update the first field of a given type in an @'NP' f xs@. +npUpdate :: forall x f xs. (NpUpdate x xs) => f x -> NP f xs -> NP f xs +npUpdate = npUpdate' (Proxy @x) + +makeLenses ''ImplicitLockStatus deriving via (Schema AllFeatureConfigs) instance (FromJSON AllFeatureConfigs) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs index d97e39d2bbf..9aece18a8cb 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/FromJSON.hs @@ -21,11 +21,11 @@ import Imports import Test.Tasty import Test.Tasty.HUnit import Test.Wire.API.Golden.Generated.Invite_user (testObject_Invite_user_2) +import Test.Wire.API.Golden.Generated.LockableFeature_team import Test.Wire.API.Golden.Generated.MemberUpdateData_user import Test.Wire.API.Golden.Generated.NewOtrMessage_user import Test.Wire.API.Golden.Generated.RmClient_user import Test.Wire.API.Golden.Generated.SimpleMember_user -import Test.Wire.API.Golden.Generated.LockableFeature_team import Test.Wire.API.Golden.Runner import Wire.API.Conversation (Conversation, MemberUpdate, OtherMemberUpdate) import Wire.API.User (NewUser, NewUserPublic) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index ff52988b3b1..36af8c92ec1 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -86,6 +86,7 @@ import Test.Wire.API.Golden.Generated.Event_conversation qualified import Test.Wire.API.Golden.Generated.Event_featureConfig qualified import Test.Wire.API.Golden.Generated.Event_team qualified import Test.Wire.API.Golden.Generated.Event_user qualified +import Test.Wire.API.Golden.Generated.Feature_team qualified import Test.Wire.API.Golden.Generated.HandleUpdate_user qualified import Test.Wire.API.Golden.Generated.InvitationCode_user qualified import Test.Wire.API.Golden.Generated.InvitationList_team qualified @@ -99,6 +100,8 @@ import Test.Wire.API.Golden.Generated.LimitedQualifiedUserIdList_user qualified import Test.Wire.API.Golden.Generated.ListType_team qualified import Test.Wire.API.Golden.Generated.LocaleUpdate_user qualified import Test.Wire.API.Golden.Generated.Locale_user qualified +import Test.Wire.API.Golden.Generated.LockableFeaturePatch_team qualified +import Test.Wire.API.Golden.Generated.LockableFeature_team qualified import Test.Wire.API.Golden.Generated.LoginCodeTimeout_user qualified import Test.Wire.API.Golden.Generated.LoginCode_user qualified import Test.Wire.API.Golden.Generated.ManagedBy_user qualified @@ -227,9 +230,6 @@ import Test.Wire.API.Golden.Generated.VerificationAction_user qualified import Test.Wire.API.Golden.Generated.VerifyDeleteUser_user qualified import Test.Wire.API.Golden.Generated.ViewLegalHoldServiceInfo_team qualified import Test.Wire.API.Golden.Generated.ViewLegalHoldService_team qualified -import Test.Wire.API.Golden.Generated.Feature_team qualified -import Test.Wire.API.Golden.Generated.LockableFeaturePatch_team qualified -import Test.Wire.API.Golden.Generated.LockableFeature_team qualified import Test.Wire.API.Golden.Generated.Wrapped_20_22some_5fint_22_20Int_user qualified import Test.Wire.API.Golden.Runner import Wire.API.Routes.Version diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 0fd15702e2e..7b0edcee302 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -472,7 +472,8 @@ checkHandleImpl uhandle = do hasE2EId :: (Member GalleyAPIAccess r) => StoredUser -> Sem r Bool hasE2EId user = - (.status) . afcMlsE2EId + -- FUTUREWORK(mangoiv): we should use a function 'getSingleFeatureConfigForUser' + (.status) . npProject @MlsE2EIdConfig <$> getAllFeatureConfigsForUser (Just user.id) <&> \case FeatureStatusEnabled -> True FeatureStatusDisabled -> False diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 62ac69f5f54..096e740c642 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -221,13 +221,12 @@ spec = describe "UserSubsystem.Interpreter" do getSelfProfile (toLocalUnsafe domain selfId) in retrievedProfile === Nothing - prop "should mark user as managed by scim if E2EId is enabled for the user and they have a handle" \storedSelf domain susbsystemConfig mlsE2EIdConfig -> + prop "should mark user as managed by scim if E2EId is enabled for the user and they have a handle" \storedSelf domain susbsystemConfig (mlsE2EIdConfig :: MlsE2EIdConfig) -> let localBackend = def {users = [storedSelf]} allFeatureConfigs = - def - { afcMlsE2EId = - LockableFeature FeatureStatusEnabled LockStatusUnlocked mlsE2EIdConfig - } + npUpdate + (LockableFeature FeatureStatusEnabled LockStatusUnlocked mlsE2EIdConfig) + def SelfProfile retrievedUser = fromJust . runAllErrorsUnsafe @@ -333,13 +332,14 @@ spec = describe "UserSubsystem.Interpreter" do $ interpretNoFederationStack localBackend Nothing - def - { afcMlsE2EId = - def + ( npUpdate + ( def { status = FeatureStatusEnabled } :: LockableFeature MlsE2EIdConfig - } + ) + def + ) config do updateUserProfile lusr Nothing UpdateOriginScim (def {name = Just newName}) diff --git a/services/brig/src/Brig/Calling/API.hs b/services/brig/src/Brig/Calling/API.hs index 35d5f0a858c..9b58b382ff9 100644 --- a/services/brig/src/Brig/Calling/API.hs +++ b/services/brig/src/Brig/Calling/API.hs @@ -83,7 +83,7 @@ getCallsConfigV2 uid _ limit = do sftFederation <- view enableSFTFederation discoveredServers <- turnServersV2 (env ^. turnServers) shared <- do - ccStatus <- lift $ liftSem $ ((.status) . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + ccStatus <- lift $ liftSem $ ((.status) . npProject @ConferenceCallingConfig <$> getAllFeatureConfigsForUser (Just uid)) pure $ case ccStatus of FeatureStatusEnabled -> True FeatureStatusDisabled -> False @@ -118,7 +118,7 @@ getCallsConfig uid _ = do env <- view turnEnv discoveredServers <- turnServersV1 (env ^. turnServers) shared <- do - ccStatus <- lift $ liftSem $ ((.status) . afcConferenceCalling <$> getAllFeatureConfigsForUser (Just uid)) + ccStatus <- lift $ liftSem $ ((.status) . npProject @ConferenceCallingConfig <$> getAllFeatureConfigsForUser (Just uid)) pure $ case ccStatus of FeatureStatusEnabled -> True FeatureStatusDisabled -> False diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 6a5fc4dec4c..f55928f4fb1 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -804,8 +804,12 @@ guardSecondFactorDisabled :: Maybe UserId -> ExceptT HttpError (AppT r) () guardSecondFactorDisabled mbUserId = do - enabled <- lift $ liftSem $ (==) Feature.FeatureStatusEnabled . (.status) . Feature.afcSndFactorPasswordChallenge <$> GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId - when enabled $ (throwStd (errorToWai @'E.AccessDenied)) + feat <- lift $ liftSem $ GalleyAPIAccess.getAllFeatureConfigsForUser mbUserId + let enabled = + (Feature.npProject @Feature.SndFactorPasswordChallengeConfig feat).status + == Feature.FeatureStatusEnabled + when enabled do + throwStd $ errorToWai @'E.AccessDenied minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/default.nix b/services/galley/default.nix index 362e174d34a..de625562b12 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -42,6 +42,7 @@ , federator , filepath , galley-types +, generics-sop , gitignoreSource , gundeck-types , hex @@ -86,6 +87,7 @@ , servant-client-core , servant-server , singletons +, singletons-base , sop-core , split , ssl-util @@ -98,6 +100,7 @@ , tasty-cannon , tasty-hunit , tasty-quickcheck +, template-haskell , temporary , text , time @@ -156,6 +159,7 @@ mkDerivation { crypton crypton-x509 currency-codes + data-default data-timeout either enclosed-exceptions @@ -164,6 +168,7 @@ mkDerivation { extended extra galley-types + generics-sop gundeck-types hex HsOpenSSL @@ -193,10 +198,13 @@ mkDerivation { servant-client servant-server singletons + singletons-base + sop-core split ssl-util stm tagged + template-haskell text time tinylog diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index 324aeb00ac7..d6d84c40336 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. @@ -41,6 +41,7 @@ import Data.Default import Data.Id import Data.Kind import Data.Qualified (Local, tUnqualified) +import Data.SOP import Data.Tagged import Galley.API.LegalHold.Team import Galley.API.Util @@ -183,19 +184,6 @@ getAllFeatureConfigsForTeam luid tid = do void $ getTeamMember tid (tUnqualified luid) >>= noteS @'NotATeamMember getAllFeatureConfigs tid -getAllFeatureConfigs :: - ( Member (Input Opts) r, - Member LegalHoldStore r, - Member TeamFeatureStore r, - Member TeamStore r - ) => - TeamId -> - Sem r AllFeatureConfigs -getAllFeatureConfigs tid = do - features <- TeamFeatures.getAllFeatureConfigs tid - defFeatures <- getAllFeatureConfigsForServer - biTraverseAllFeatures (computeFeatureWithLock tid) defFeatures features - computeFeatureWithLock :: forall cfg r. (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => @@ -206,68 +194,40 @@ computeFeatureWithLock :: computeFeatureWithLock tid defFeature feat = computeFeature @cfg tid defFeature feat.lockStatus feat.feature --- | One of a number of possible combinators. This is the only one we happen to need. -biTraverseAllFeatures :: - ( Member (Input Opts) r, - Member TeamStore r, - Member LegalHoldStore r - ) => - ( forall cfg. - (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => - f cfg -> - g cfg -> - Sem r (h cfg) - ) -> - (AllFeatures f -> AllFeatures g -> Sem r (AllFeatures h)) -biTraverseAllFeatures phi features1 features2 = do - afcLegalholdStatus <- phi (afcLegalholdStatus features1) (afcLegalholdStatus features2) - afcSSOStatus <- phi (afcSSOStatus features1) (afcSSOStatus features2) - afcTeamSearchVisibilityAvailable <- phi (afcTeamSearchVisibilityAvailable features1) (afcTeamSearchVisibilityAvailable features2) - afcSearchVisibilityInboundConfig <- phi (afcSearchVisibilityInboundConfig features1) (afcSearchVisibilityInboundConfig features2) - afcValidateSAMLEmails <- phi (afcValidateSAMLEmails features1) (afcValidateSAMLEmails features2) - afcDigitalSignatures <- phi (afcDigitalSignatures features1) (afcDigitalSignatures features2) - afcAppLock <- phi (afcAppLock features1) (afcAppLock features2) - afcFileSharing <- phi (afcFileSharing features1) (afcFileSharing features2) - afcClassifiedDomains <- phi (afcClassifiedDomains features1) (afcClassifiedDomains features2) - afcConferenceCalling <- phi (afcConferenceCalling features1) (afcConferenceCalling features2) - afcSelfDeletingMessages <- phi (afcSelfDeletingMessages features1) (afcSelfDeletingMessages features2) - afcGuestLink <- phi (afcGuestLink features1) (afcGuestLink features2) - afcSndFactorPasswordChallenge <- phi (afcSndFactorPasswordChallenge features1) (afcSndFactorPasswordChallenge features2) - afcMLS <- phi (afcMLS features1) (afcMLS features2) - afcExposeInvitationURLsToTeamAdmin <- phi (afcExposeInvitationURLsToTeamAdmin features1) (afcExposeInvitationURLsToTeamAdmin features2) - afcOutlookCalIntegration <- phi (afcOutlookCalIntegration features1) (afcOutlookCalIntegration features2) - afcMlsE2EId <- phi (afcMlsE2EId features1) (afcMlsE2EId features2) - afcMlsMigration <- phi (afcMlsMigration features1) (afcMlsMigration features2) - afcEnforceFileDownloadLocation <- phi (afcEnforceFileDownloadLocation features1) (afcEnforceFileDownloadLocation features2) - afcLimitedEventFanout <- phi (afcLimitedEventFanout features1) (afcLimitedEventFanout features2) - pure AllFeatures {..} +class (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForServerConstraints r cfg + +instance (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForServerConstraints r cfg getAllFeatureConfigsForServer :: forall r. (Member (Input Opts) r) => Sem r AllFeatureConfigs -getAllFeatureConfigsForServer = - AllFeatures - <$> getConfigForServer @LegalholdConfig - <*> getConfigForServer @SSOConfig - <*> getConfigForServer @SearchVisibilityAvailableConfig - <*> getConfigForServer @SearchVisibilityInboundConfig - <*> getConfigForServer @ValidateSAMLEmailsConfig - <*> getConfigForServer @DigitalSignaturesConfig - <*> getConfigForServer @AppLockConfig - <*> getConfigForServer @FileSharingConfig - <*> getConfigForServer @ClassifiedDomainsConfig - <*> getConfigForServer @ConferenceCallingConfig - <*> getConfigForServer @SelfDeletingMessagesConfig - <*> getConfigForServer @GuestLinksConfig - <*> getConfigForServer @SndFactorPasswordChallengeConfig - <*> getConfigForServer @MLSConfig - <*> getConfigForServer @ExposeInvitationURLsToTeamAdminConfig - <*> getConfigForServer @OutlookCalIntegrationConfig - <*> getConfigForServer @MlsE2EIdConfig - <*> getConfigForServer @MlsMigrationConfig - <*> getConfigForServer @EnforceFileDownloadLocationConfig - <*> getConfigForServer @LimitedEventFanoutConfig +getAllFeatureConfigsForServer = hsequence' $ hcpure (Proxy @GetFeatureConfig) $ Comp getConfigForServer + +getAllFeatureConfigs :: + forall r. + ( Member (Input Opts) r, + Member LegalHoldStore r, + Member TeamFeatureStore r, + Member TeamStore r + ) => + TeamId -> + Sem r AllFeatureConfigs +getAllFeatureConfigs tid = do + features <- TeamFeatures.getAllFeatureConfigs tid + defFeatures <- getAllFeatureConfigsForServer + hsequence' $ hcliftA2 (Proxy @(GetAllFeatureConfigsForServerConstraints r)) compute defFeatures features + where + compute :: + (ComputeFeatureConstraints p r, GetFeatureConfig p) => + LockableFeature p -> + DbFeatureWithLock p -> + (Sem r :.: LockableFeature) p + compute defFeature feat = Comp $ computeFeatureWithLock tid defFeature feat + +class (GetConfigForUserConstraints cfg r, GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForUserConstraints r cfg + +instance (GetConfigForUserConstraints cfg r, GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForUserConstraints r cfg getAllFeatureConfigsForUser :: forall r. @@ -284,27 +244,7 @@ getAllFeatureConfigsForUser :: Sem r AllFeatureConfigs getAllFeatureConfigsForUser uid = do mTid <- getTeamAndCheckMembership uid - AllFeatures - <$> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid - <*> getConfigForTeamUser uid mTid + hsequence' $ hcpure (Proxy @(GetAllFeatureConfigsForUserConstraints r)) $ Comp $ getConfigForTeamUser uid mTid getSingleFeatureConfigForUser :: forall cfg r. diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index c823c7ba7f4..e05cb80117c 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -137,78 +137,27 @@ emptyRow = allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeatureWithLock allFeatureConfigsFromRow row = - AllFeatures - { afcLegalholdStatus = mkFeatureWithLock Nothing (row.legalhold :* Nil), - afcSSOStatus = mkFeatureWithLock Nothing (row.sso :* Nil), - afcTeamSearchVisibilityAvailable = mkFeatureWithLock Nothing (row.searchVisibility :* Nil), - afcSearchVisibilityInboundConfig = mkFeatureWithLock Nothing (row.searchVisibility :* Nil), - afcValidateSAMLEmails = mkFeatureWithLock Nothing (row.validateSamlEmails :* Nil), - afcDigitalSignatures = mkFeatureWithLock Nothing (row.digitalSignatures :* Nil), - afcAppLock = - mkFeatureWithLock - Nothing - (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil), - afcFileSharing = mkFeatureWithLock row.fileSharingLock (row.fileSharing :* Nil), - afcClassifiedDomains = mkFeatureWithLock Nothing Nil, - afcConferenceCalling = - mkFeatureWithLock - row.conferenceCallingLock - ( row.conferenceCalling - :* row.conferenceCallingOne2One - :* Nil - ), - afcSelfDeletingMessages = - mkFeatureWithLock - row.selfDeletingMessagesLock - ( row.selfDeletingMessages - :* row.selfDeletingMessagesTtl - :* Nil - ), - afcGuestLink = mkFeatureWithLock row.guestLinksLock (row.guestLinks :* Nil), - afcSndFactorPasswordChallenge = mkFeatureWithLock row.sndFactorLock (row.sndFactor :* Nil), - afcMLS = - mkFeatureWithLock - row.mlsLock - ( row.mls - :* row.mlsDefaultProtocol - :* row.mlsToggleUsers - :* row.mlsAllowedCipherSuites - :* row.mlsDefaultCipherSuite - :* row.mlsSupportedProtocols - :* Nil - ), - afcExposeInvitationURLsToTeamAdmin = mkFeatureWithLock Nothing (row.exposeInvitationUrls :* Nil), - afcOutlookCalIntegration = - mkFeatureWithLock - row.outlookCalIntegrationLock - (row.outlookCalIntegration :* Nil), - afcMlsE2EId = - mkFeatureWithLock - row.mlsE2eidLock - ( row.mlsE2eid - :* row.mlsE2eidGracePeriod - :* row.mlsE2eidAcmeDiscoverUrl - :* row.mlsE2eidMaybeCrlProxy - :* row.mlsE2eidMaybeUseProxyOnMobile - :* Nil - ), - afcMlsMigration = - mkFeatureWithLock - row.mlsMigrationLock - ( row.mlsMigration - :* row.mlsMigrationStartTime - :* row.mlsMigrationFinalizeRegardlessAfter - :* Nil - ), - afcEnforceFileDownloadLocation = - mkFeatureWithLock - row.enforceDownloadLocationLock - ( row.enforceDownloadLocation - :* row.enforceDownloadLocation_Location - :* Nil - ), - afcLimitedEventFanout = mkFeatureWithLock Nothing (row.limitEventFanout :* Nil) - } + mkFeatureWithLock Nothing (row.legalhold :* Nil) + :* mkFeatureWithLock Nothing (row.sso :* Nil) + :* mkFeatureWithLock Nothing (row.searchVisibility :* Nil) + :* mkFeatureWithLock Nothing (row.searchVisibility :* Nil) + :* mkFeatureWithLock Nothing (row.validateSamlEmails :* Nil) + :* mkFeatureWithLock Nothing (row.digitalSignatures :* Nil) + :* mkFeatureWithLock Nothing (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil) + :* mkFeatureWithLock row.fileSharingLock (row.fileSharing :* Nil) + :* mkFeatureWithLock Nothing Nil + :* mkFeatureWithLock row.conferenceCallingLock (row.conferenceCalling :* row.conferenceCallingOne2One :* Nil) + :* mkFeatureWithLock row.selfDeletingMessagesLock (row.selfDeletingMessages :* row.selfDeletingMessagesTtl :* Nil) + :* mkFeatureWithLock row.guestLinksLock (row.guestLinks :* Nil) + :* mkFeatureWithLock row.sndFactorLock (row.sndFactor :* Nil) + :* mkFeatureWithLock row.mlsLock (row.mls :* row.mlsDefaultProtocol :* row.mlsToggleUsers :* row.mlsAllowedCipherSuites :* row.mlsDefaultCipherSuite :* row.mlsSupportedProtocols :* Nil) + :* mkFeatureWithLock Nothing (row.exposeInvitationUrls :* Nil) + :* mkFeatureWithLock row.outlookCalIntegrationLock (row.outlookCalIntegration :* Nil) + :* mkFeatureWithLock row.mlsE2eidLock (row.mlsE2eid :* row.mlsE2eidGracePeriod :* row.mlsE2eidAcmeDiscoverUrl :* row.mlsE2eidMaybeCrlProxy :* row.mlsE2eidMaybeUseProxyOnMobile :* Nil) + :* mkFeatureWithLock row.mlsMigrationLock (row.mlsMigration :* row.mlsMigrationStartTime :* row.mlsMigrationFinalizeRegardlessAfter :* Nil) + :* mkFeatureWithLock row.enforceDownloadLocationLock (row.enforceDownloadLocation :* row.enforceDownloadLocation_Location :* Nil) + :* mkFeatureWithLock Nothing (row.limitEventFanout :* Nil) + :* Nil getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeatureWithLock) getAllFeatureConfigs tid = do diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 7708921e9fd..5c5fb703331 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wwarn #-} -- | Abstraction to fetch and store feature values from and to the database. @@ -12,7 +10,6 @@ import Data.Functor import Data.Functor.Identity import Data.Id import Data.Kind -import Data.List (nub) import Data.List.Singletons (Length) import Data.Misc (HttpsUrl) import Data.Singletons (demote) @@ -338,7 +335,7 @@ fetchFeatureLockStatus tid = do let select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatus)) select = fromString $ "select " <> col <> " from team_features where team_id = ?" row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure . Tagged . join . fmap runIdentity $ row + pure . Tagged . (runIdentity =<<) $ row storeFeatureLockStatus :: forall cfg m. diff --git a/tools/stern/default.nix b/tools/stern/default.nix index cde1f4ba46a..18246b4fc52 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -11,6 +11,7 @@ , bytestring-conversion , containers , cookie +, data-default , errors , exceptions , extended @@ -100,6 +101,7 @@ mkDerivation { bytestring-conversion containers cookie + data-default exceptions extra HsOpenSSL From e00b5382f647101e4fcf8a26abcee0c7211aa331 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 6 Aug 2024 16:43:09 +0200 Subject: [PATCH 21/34] Incorporate lock status in feature queries --- libs/wire-api/src/Wire/API/Team/Feature.hs | 33 +-- .../galley/src/Galley/API/Teams/Features.hs | 15 +- .../src/Galley/API/Teams/Features/Get.hs | 51 ++-- .../Cassandra/GetAllTeamFeatureConfigs.hs | 52 ++-- .../src/Galley/Cassandra/MakeFeature.hs | 247 +++++++++++------- .../src/Galley/Cassandra/TeamFeatures.hs | 27 +- .../src/Galley/Effects/TeamFeatureStore.hs | 9 +- 7 files changed, 227 insertions(+), 207 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index aa4174ba35b..4fc8cb1856b 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -32,7 +32,7 @@ module Wire.API.Team.Feature featureNameBS, LockStatus (..), DbFeature (..), - DbFeatureWithLock (..), + dbFeatureLockStatus, dbFeatureStatus, dbFeatureConfig, dbFeatureModConfig, @@ -104,6 +104,7 @@ import Data.Id import Data.Json.Util import Data.Kind import Data.Misc (HttpsUrl) +import Data.Monoid import Data.OpenApi qualified as S import Data.Proxy import Data.SOP @@ -230,13 +231,11 @@ featureNameBS = UTF8.fromString $ symbolVal (Proxy @(FeatureSymbol cfg)) -- | Feature data stored in the database, as a function of its default values. newtype DbFeature cfg = DbFeature - {applyDbFeature :: Feature cfg -> Feature cfg} + {applyDbFeature :: LockableFeature cfg -> LockableFeature cfg} + deriving (Semigroup, Monoid) via Endo (LockableFeature cfg) -instance Semigroup (DbFeature cfg) where - DbFeature f <> DbFeature g = DbFeature (f . g) - -instance Monoid (DbFeature cfg) where - mempty = DbFeature id +dbFeatureLockStatus :: LockStatus -> DbFeature cfg +dbFeatureLockStatus s = DbFeature $ \w -> w {lockStatus = s} dbFeatureStatus :: FeatureStatus -> DbFeature cfg dbFeatureStatus s = DbFeature $ \w -> w {status = s} @@ -247,11 +246,6 @@ dbFeatureConfig c = DbFeature $ \w -> w {config = c} dbFeatureModConfig :: (cfg -> cfg) -> DbFeature cfg dbFeatureModConfig f = DbFeature $ \w -> w {config = f w.config} -data DbFeatureWithLock cfg = DbFeatureWithLock - { lockStatus :: Maybe LockStatus, - feature :: DbFeature cfg - } - ---------------------------------------------------------------------- -- LockableFeature @@ -557,15 +551,12 @@ instance (IsFeatureConfig a, ToSchema a) => FromJSON (ImplicitLockStatus a) wher -- | Convert a feature coming from the database to its public form. This can be -- overridden on a feature basis by implementing the `computeFeature` method of -- the `GetFeatureConfig` class. -genericComputeFeature :: - LockableFeature cfg -> - Maybe LockStatus -> - DbFeature cfg -> - LockableFeature cfg -genericComputeFeature defFeature lockStatus dbFeature = - case fromMaybe defFeature.lockStatus lockStatus of - LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} - LockStatusUnlocked -> withUnlocked $ applyDbFeature dbFeature (forgetLock defFeature) +genericComputeFeature :: forall cfg. LockableFeature cfg -> DbFeature cfg -> LockableFeature cfg +genericComputeFeature defFeature dbFeature = + let feat = applyDbFeature dbFeature defFeature + in case feat.lockStatus of + LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} + LockStatusUnlocked -> feat -------------------------------------------------------------------------------- -- GuestLinks feature diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 46d205b468a..38d16da2f45 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -98,9 +98,7 @@ patchFeatureStatusInternal tid patch = do assertTeamExists tid currentFeatureStatus <- getFeatureStatus @cfg DontDoAuth tid let newFeatureStatus = applyPatch currentFeatureStatus - -- setting the config can fail, so we need to do it first - void $ setConfigForTeam @cfg tid (forgetLock newFeatureStatus) - when (isJust $ patch.lockStatus) $ void $ updateLockStatus @cfg tid newFeatureStatus.lockStatus + void $ setConfigForTeam @cfg tid newFeatureStatus getFeatureStatus @cfg DontDoAuth tid where applyPatch :: LockableFeature cfg -> LockableFeature cfg @@ -137,8 +135,9 @@ setFeatureStatus doauth tid feat = do void $ permissionCheck ChangeTeamFeature zusrMembership DontDoAuth -> assertTeamExists tid - guardLockStatus . (.lockStatus) =<< getConfigForTeam @cfg tid - setConfigForTeam @cfg tid feat + feat0 <- getConfigForTeam @cfg tid + guardLockStatus feat0.lockStatus + setConfigForTeam @cfg tid (withLockStatus feat0.lockStatus feat) setFeatureStatusInternal :: forall cfg r. @@ -188,7 +187,7 @@ persistAndPushEvent :: Member TeamStore r ) => TeamId -> - Feature cfg -> + LockableFeature cfg -> Sem r (LockableFeature cfg) persistAndPushEvent tid feat = do setFeatureConfig (featureSingleton @cfg) tid feat @@ -249,7 +248,7 @@ class (GetFeatureConfig cfg) => SetFeatureConfig cfg where Member TeamStore r ) => TeamId -> - Feature cfg -> + LockableFeature cfg -> Sem r (LockableFeature cfg) default setConfigForTeam :: ( ComputeFeatureConstraints cfg r, @@ -262,7 +261,7 @@ class (GetFeatureConfig cfg) => SetFeatureConfig cfg where Member TeamStore r ) => TeamId -> - Feature cfg -> + LockableFeature cfg -> Sem r (LockableFeature cfg) setConfigForTeam tid feat = persistAndPushEvent tid feat diff --git a/services/galley/src/Galley/API/Teams/Features/Get.hs b/services/galley/src/Galley/API/Teams/Features/Get.hs index d6d84c40336..842403e7960 100644 --- a/services/galley/src/Galley/API/Teams/Features/Get.hs +++ b/services/galley/src/Galley/API/Teams/Features/Get.hs @@ -36,7 +36,6 @@ where import Control.Error (hush) import Control.Lens -import Data.Bifunctor (second) import Data.Default import Data.Id import Data.Kind @@ -103,18 +102,16 @@ class (IsFeatureConfig cfg) => GetFeatureConfig cfg where (ComputeFeatureConstraints cfg r) => TeamId -> LockableFeature cfg -> - Maybe LockStatus -> DbFeature cfg -> Sem r (LockableFeature cfg) default computeFeature :: TeamId -> LockableFeature cfg -> - Maybe LockStatus -> DbFeature cfg -> Sem r (LockableFeature cfg) - computeFeature _tid defFeature lockStatus dbFeature = + computeFeature _tid defFeature dbFeature = pure $ - genericComputeFeature @cfg defFeature lockStatus dbFeature + genericComputeFeature @cfg defFeature dbFeature getFeatureStatus :: forall cfg r. @@ -148,10 +145,10 @@ getFeatureStatusMulti :: Sem r (Multi.TeamFeatureNoConfigMultiResponse cfg) getFeatureStatusMulti (Multi.TeamFeatureNoConfigMultiRequest tids) = do cfgs <- getConfigForMultiTeam @cfg tids - let xs = uncurry toTeamStatus . second forgetLock <$> cfgs + let xs = uncurry toTeamStatus <$> cfgs pure $ Multi.TeamFeatureNoConfigMultiResponse xs -toTeamStatus :: TeamId -> Feature cfg -> Multi.TeamStatus cfg +toTeamStatus :: TeamId -> LockableFeature cfg -> Multi.TeamStatus cfg toTeamStatus tid feat = Multi.TeamStatus tid feat.status getTeamAndCheckMembership :: @@ -184,16 +181,6 @@ getAllFeatureConfigsForTeam luid tid = do void $ getTeamMember tid (tUnqualified luid) >>= noteS @'NotATeamMember getAllFeatureConfigs tid -computeFeatureWithLock :: - forall cfg r. - (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => - TeamId -> - LockableFeature cfg -> - DbFeatureWithLock cfg -> - Sem r (LockableFeature cfg) -computeFeatureWithLock tid defFeature feat = - computeFeature @cfg tid defFeature feat.lockStatus feat.feature - class (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForServerConstraints r cfg instance (GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForServerConstraints r cfg @@ -221,9 +208,9 @@ getAllFeatureConfigs tid = do compute :: (ComputeFeatureConstraints p r, GetFeatureConfig p) => LockableFeature p -> - DbFeatureWithLock p -> + DbFeature p -> (Sem r :.: LockableFeature) p - compute defFeature feat = Comp $ computeFeatureWithLock tid defFeature feat + compute defFeature feat = Comp $ computeFeature tid defFeature feat class (GetConfigForUserConstraints cfg r, GetFeatureConfig cfg, ComputeFeatureConstraints cfg r) => GetAllFeatureConfigsForUserConstraints r cfg @@ -274,15 +261,12 @@ getConfigForTeam :: Sem r (LockableFeature cfg) getConfigForTeam tid = do dbFeature <- TeamFeatures.getFeatureConfig (featureSingleton @cfg) tid - lockStatus <- TeamFeatures.getFeatureLockStatus (featureSingleton @cfg) tid defFeature <- getConfigForServer computeFeature @cfg tid defFeature - lockStatus dbFeature --- Note: this function assumes the feature cannot be locked getConfigForMultiTeam :: forall cfg r. ( GetFeatureConfig cfg, @@ -296,7 +280,7 @@ getConfigForMultiTeam tids = do defFeature <- getConfigForServer features <- TeamFeatures.getFeatureConfigMulti (featureSingleton @cfg) tids for features $ \(tid, dbFeature) -> do - feat <- computeFeature @cfg tid defFeature (Just LockStatusUnlocked) dbFeature + feat <- computeFeature @cfg tid defFeature dbFeature pure (tid, feat) getConfigForTeamUser :: @@ -353,7 +337,7 @@ instance GetFeatureConfig LegalholdConfig where ComputeFeatureConstraints LegalholdConfig r = (Member TeamStore r, Member LegalHoldStore r) - computeFeature tid defFeature _lockStatus dbFeature = do + computeFeature tid defFeature dbFeature = do status <- computeLegalHoldFeatureStatus tid dbFeature pure $ defFeature {status = status} @@ -398,15 +382,12 @@ instance GetFeatureConfig ConferenceCallingConfig where feat <- getAccountConferenceCallingConfigClient uid pure $ withLockStatus (def @(LockableFeature ConferenceCallingConfig)).lockStatus feat - computeFeature _tid defFeature lockStatus dbFeature = - pure $ case fromMaybe defFeature.lockStatus lockStatus of - LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} - LockStatusUnlocked -> - withUnlocked $ - (applyDbFeature dbFeature) - (forgetLock defFeature) - { status = FeatureStatusEnabled - } + computeFeature _tid defFeature dbFeature = + pure $ + let feat = applyDbFeature dbFeature defFeature {status = FeatureStatusEnabled} + in case feat.lockStatus of + LockStatusLocked -> defFeature {lockStatus = LockStatusLocked} + LockStatusUnlocked -> feat instance GetFeatureConfig SelfDeletingMessagesConfig where getConfigForServer = @@ -434,11 +415,11 @@ instance GetFeatureConfig ExposeInvitationURLsToTeamAdminConfig where (Member (Input Opts) r) -- the lock status of this feature is calculated from the allow list, not the database - computeFeature tid defFeature _lockStatus dbFeature = do + computeFeature tid defFeature dbFeature = do allowList <- input <&> view (settings . exposeInvitationURLsTeamAllowlist . to (fromMaybe [])) let teamAllowed = tid `elem` allowList lockStatus = if teamAllowed then LockStatusUnlocked else LockStatusLocked - pure $ genericComputeFeature defFeature (Just lockStatus) dbFeature + pure $ genericComputeFeature defFeature (dbFeatureLockStatus lockStatus <> dbFeature) instance GetFeatureConfig OutlookCalIntegrationConfig where getConfigForServer = diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index e05cb80117c..c02b6e28362 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -135,31 +135,39 @@ emptyRow = limitEventFanout = Nothing } -allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeatureWithLock +allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeature allFeatureConfigsFromRow row = - mkFeatureWithLock Nothing (row.legalhold :* Nil) - :* mkFeatureWithLock Nothing (row.sso :* Nil) - :* mkFeatureWithLock Nothing (row.searchVisibility :* Nil) - :* mkFeatureWithLock Nothing (row.searchVisibility :* Nil) - :* mkFeatureWithLock Nothing (row.validateSamlEmails :* Nil) - :* mkFeatureWithLock Nothing (row.digitalSignatures :* Nil) - :* mkFeatureWithLock Nothing (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil) - :* mkFeatureWithLock row.fileSharingLock (row.fileSharing :* Nil) - :* mkFeatureWithLock Nothing Nil - :* mkFeatureWithLock row.conferenceCallingLock (row.conferenceCalling :* row.conferenceCallingOne2One :* Nil) - :* mkFeatureWithLock row.selfDeletingMessagesLock (row.selfDeletingMessages :* row.selfDeletingMessagesTtl :* Nil) - :* mkFeatureWithLock row.guestLinksLock (row.guestLinks :* Nil) - :* mkFeatureWithLock row.sndFactorLock (row.sndFactor :* Nil) - :* mkFeatureWithLock row.mlsLock (row.mls :* row.mlsDefaultProtocol :* row.mlsToggleUsers :* row.mlsAllowedCipherSuites :* row.mlsDefaultCipherSuite :* row.mlsSupportedProtocols :* Nil) - :* mkFeatureWithLock Nothing (row.exposeInvitationUrls :* Nil) - :* mkFeatureWithLock row.outlookCalIntegrationLock (row.outlookCalIntegration :* Nil) - :* mkFeatureWithLock row.mlsE2eidLock (row.mlsE2eid :* row.mlsE2eidGracePeriod :* row.mlsE2eidAcmeDiscoverUrl :* row.mlsE2eidMaybeCrlProxy :* row.mlsE2eidMaybeUseProxyOnMobile :* Nil) - :* mkFeatureWithLock row.mlsMigrationLock (row.mlsMigration :* row.mlsMigrationStartTime :* row.mlsMigrationFinalizeRegardlessAfter :* Nil) - :* mkFeatureWithLock row.enforceDownloadLocationLock (row.enforceDownloadLocation :* row.enforceDownloadLocation_Location :* Nil) - :* mkFeatureWithLock Nothing (row.limitEventFanout :* Nil) + mkFeature (row.legalhold :* Nil) + :* mkFeature (row.sso :* Nil) + :* mkFeature (row.searchVisibility :* Nil) + :* mkFeature (row.searchVisibility :* Nil) + :* mkFeature (row.validateSamlEmails :* Nil) + :* mkFeature (row.digitalSignatures :* Nil) + :* mkFeature (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil) + :* mkFeature (row.fileSharingLock :* row.fileSharing :* Nil) + :* mkFeature Nil + :* mkFeature (row.conferenceCallingLock :* row.conferenceCalling :* row.conferenceCallingOne2One :* Nil) + :* mkFeature (row.selfDeletingMessagesLock :* row.selfDeletingMessages :* row.selfDeletingMessagesTtl :* Nil) + :* mkFeature (row.guestLinksLock :* row.guestLinks :* Nil) + :* mkFeature (row.sndFactorLock :* row.sndFactor :* Nil) + :* mkFeature (row.mlsLock :* row.mls :* row.mlsDefaultProtocol :* row.mlsToggleUsers :* row.mlsAllowedCipherSuites :* row.mlsDefaultCipherSuite :* row.mlsSupportedProtocols :* Nil) + :* mkFeature (row.exposeInvitationUrls :* Nil) + :* mkFeature (row.outlookCalIntegrationLock :* row.outlookCalIntegration :* Nil) + :* mkFeature + ( row.mlsE2eidLock + :* row.mlsE2eid + :* row.mlsE2eidGracePeriod + :* row.mlsE2eidAcmeDiscoverUrl + :* row.mlsE2eidMaybeCrlProxy + :* row.mlsE2eidMaybeUseProxyOnMobile + :* Nil + ) + :* mkFeature (row.mlsMigrationLock :* row.mlsMigration :* row.mlsMigrationStartTime :* row.mlsMigrationFinalizeRegardlessAfter :* Nil) + :* mkFeature (row.enforceDownloadLocationLock :* row.enforceDownloadLocation :* row.enforceDownloadLocation_Location :* Nil) + :* mkFeature (row.limitEventFanout :* Nil) :* Nil -getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeatureWithLock) +getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeature) getAllFeatureConfigs tid = do mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) pure $ allFeatureConfigsFromRow $ maybe emptyRow asRecord mRow diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 5c5fb703331..71a1c62a95b 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -14,6 +14,7 @@ import Data.List.Singletons (Length) import Data.Misc (HttpsUrl) import Data.Singletons (demote) import Data.Time +import GHC.TypeError import GHC.TypeNats import Galley.Cassandra.Instances () import Generics.SOP @@ -27,8 +28,6 @@ class MakeFeature cfg where type FeatureRow cfg = '[FeatureStatus] featureColumns :: NP (K String) (FeatureRow cfg) - lockStatusColumn :: Maybe String - lockStatusColumn = Nothing mkFeature :: NP Maybe (FeatureRow cfg) -> DbFeature cfg default mkFeature :: @@ -37,20 +36,13 @@ class MakeFeature cfg where DbFeature cfg mkFeature = foldMap dbFeatureStatus . hd - unmkFeature :: Feature cfg -> NP Maybe (FeatureRow cfg) + unmkFeature :: LockableFeature cfg -> NP Maybe (FeatureRow cfg) default unmkFeature :: (FeatureRow cfg ~ '[FeatureStatus]) => - Feature cfg -> + LockableFeature cfg -> NP Maybe (FeatureRow cfg) unmkFeature feat = Just feat.status :* Nil -mkFeatureWithLock :: - (MakeFeature cfg) => - Maybe LockStatus -> - NP Maybe (FeatureRow cfg) -> - DbFeatureWithLock cfg -mkFeatureWithLock lockStatus row = DbFeatureWithLock lockStatus (mkFeature row) - instance MakeFeature LegalholdConfig where featureColumns = K "legalhold_status" :* Nil @@ -71,7 +63,11 @@ instance MakeFeature DigitalSignaturesConfig where instance MakeFeature AppLockConfig where type FeatureRow AppLockConfig = '[FeatureStatus, EnforceAppLock, Int32] - featureColumns = K "app_lock_status" :* K "app_lock_enforce" :* K "app_lock_inactivity_timeout_secs" :* Nil + featureColumns = + K "app_lock_status" + :* K "app_lock_enforce" + :* K "app_lock_inactivity_timeout_secs" + :* Nil mkFeature (status :* enforce :* timeout :* Nil) = foldMap dbFeatureStatus status @@ -91,56 +87,98 @@ instance MakeFeature ClassifiedDomainsConfig where unmkFeature _ = Nil instance MakeFeature FileSharingConfig where - featureColumns = K "file_sharing" :* Nil - lockStatusColumn = Just "file_sharing_lock_status" + type FeatureRow FileSharingConfig = '[LockStatus, FeatureStatus] + featureColumns = K "file_sharing_lock_status" :* K "file_sharing" :* Nil + + mkFeature (lockStatus :* status :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status + + unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature ConferenceCallingConfig where - type FeatureRow ConferenceCallingConfig = '[FeatureStatus, One2OneCalls] - featureColumns = K "conference_calling_status" :* K "conference_calling_one_to_one" :* Nil - lockStatusColumn = Just "conference_calling" + type FeatureRow ConferenceCallingConfig = '[LockStatus, FeatureStatus, One2OneCalls] + featureColumns = + K "conference_calling" + :* K "conference_calling_status" + :* K "conference_calling_one_to_one" + :* Nil - mkFeature (status :* calls :* Nil) = - foldMap dbFeatureStatus status + mkFeature (lockStatus :* status :* calls :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . ConferenceCallingConfig) calls unmkFeature feat = - Just feat.status + Just feat.lockStatus + :* Just feat.status :* Just feat.config.one2OneCalls :* Nil instance MakeFeature SelfDeletingMessagesConfig where - type FeatureRow SelfDeletingMessagesConfig = '[FeatureStatus, Int32] - featureColumns = K "self_deleting_messages_status" :* K "self_deleting_messages_ttl" :* Nil - lockStatusColumn = Just "self_deleting_messages_lock_status" + type FeatureRow SelfDeletingMessagesConfig = '[LockStatus, FeatureStatus, Int32] + featureColumns = + K "self_deleting_messages_lock_status" + :* K "self_deleting_messages_status" + :* K "self_deleting_messages_ttl" + :* Nil - mkFeature (status :* ttl :* Nil) = - foldMap dbFeatureStatus status + mkFeature (lockStatus :* status :* ttl :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl unmkFeature feat = - Just feat.status + Just feat.lockStatus + :* Just feat.status :* Just feat.config.sdmEnforcedTimeoutSeconds :* Nil instance MakeFeature GuestLinksConfig where - featureColumns = K "guest_links_status" :* Nil - lockStatusColumn = Just "guest_links_lock_status" + type FeatureRow GuestLinksConfig = '[LockStatus, FeatureStatus] + featureColumns = K "guest_links_lock_status" :* K "guest_links_status" :* Nil + + mkFeature (lockStatus :* status :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status + + unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature SndFactorPasswordChallengeConfig where - featureColumns = K "snd_factor_password_challenge_status" :* Nil - lockStatusColumn = Just "snd_factor_password_challenge_lock_status" + type FeatureRow SndFactorPasswordChallengeConfig = '[LockStatus, FeatureStatus] + featureColumns = + K "snd_factor_password_challenge_lock_status" + :* K "snd_factor_password_challenge_status" + :* Nil + + mkFeature (lockStatus :* status :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status + + unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature ExposeInvitationURLsToTeamAdminConfig where featureColumns = K "expose_invitation_urls_to_team_admin" :* Nil instance MakeFeature OutlookCalIntegrationConfig where - featureColumns = K "outlook_cal_integration_status" :* Nil - lockStatusColumn = Just "outlook_cal_integration_lock_status" + type FeatureRow OutlookCalIntegrationConfig = '[LockStatus, FeatureStatus] + + featureColumns = + K "outlook_cal_integration_lock_status" + :* K "outlook_cal_integration_status" + :* Nil + + mkFeature (lockStatus :* status :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status + + unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature MLSConfig where type FeatureRow MLSConfig = - '[ FeatureStatus, + '[ LockStatus, + FeatureStatus, ProtocolTag, (C.Set UserId), (C.Set CipherSuiteTag), @@ -148,17 +186,18 @@ instance MakeFeature MLSConfig where (C.Set ProtocolTag) ] featureColumns = - K "mls_status" + K "mls_lock_status" + :* K "mls_status" :* K "mls_default_protocol" :* K "mls_protocol_toggle_users" :* K "mls_allowed_ciphersuites" :* K "mls_default_ciphersuite" :* K "mls_supported_protocols" :* Nil - lockStatusColumn = Just "mls_lock_status" mkFeature - ( status + ( lockStatus + :* status :* defProto :* toggleUsers :* ciphersuites @@ -166,7 +205,8 @@ instance MakeFeature MLSConfig where :* supportedProtos :* Nil ) = - foldMap dbFeatureStatus status + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status <> foldMap dbFeatureConfig ( MLSConfig (foldMap C.fromSet toggleUsers) @@ -177,7 +217,8 @@ instance MakeFeature MLSConfig where ) unmkFeature feat = - Just feat.status + Just feat.lockStatus + :* Just feat.status :* Just feat.config.mlsDefaultProtocol :* Just (C.Set feat.config.mlsProtocolToggleUsers) :* Just (C.Set feat.config.mlsAllowedCipherSuites) @@ -188,36 +229,47 @@ instance MakeFeature MLSConfig where instance MakeFeature MlsE2EIdConfig where type FeatureRow MlsE2EIdConfig = - '[ FeatureStatus, + '[ LockStatus, + FeatureStatus, Int32, HttpsUrl, HttpsUrl, Bool ] featureColumns = - K "mls_e2eid_status" + K "mls_e2eid_lock_status" + :* K "mls_e2eid_status" :* K "mls_e2eid_grace_period" :* K "mls_e2eid_acme_discovery_url" :* K "mls_e2eid_crl_proxy" :* K "mls_e2eid_use_proxy_on_mobile" :* Nil - lockStatusColumn = Just "mls_e2eid_lock_status" - mkFeature (status :* gracePeriod :* acmeDiscoveryUrl :* crlProxy :* useProxyOnMobile :* Nil) = - foldMap dbFeatureStatus status - <> dbFeatureModConfig - ( \defCfg -> - defCfg - { verificationExpiration = - maybe defCfg.verificationExpiration fromIntegral gracePeriod, - acmeDiscoveryUrl = acmeDiscoveryUrl, - crlProxy = crlProxy, - useProxyOnMobile = fromMaybe defCfg.useProxyOnMobile useProxyOnMobile - } - ) + mkFeature + ( lockStatus + :* status + :* gracePeriod + :* acmeDiscoveryUrl + :* crlProxy + :* useProxyOnMobile + :* Nil + ) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status + <> dbFeatureModConfig + ( \defCfg -> + defCfg + { verificationExpiration = + maybe defCfg.verificationExpiration fromIntegral gracePeriod, + acmeDiscoveryUrl = acmeDiscoveryUrl, + crlProxy = crlProxy, + useProxyOnMobile = fromMaybe defCfg.useProxyOnMobile useProxyOnMobile + } + ) unmkFeature feat = - Just feat.status + Just feat.lockStatus + :* Just feat.status :* Just (truncate feat.config.verificationExpiration) :* feat.config.acmeDiscoveryUrl :* feat.config.crlProxy @@ -227,38 +279,45 @@ instance MakeFeature MlsE2EIdConfig where instance MakeFeature MlsMigrationConfig where type FeatureRow MlsMigrationConfig = - '[FeatureStatus, UTCTime, UTCTime] + '[LockStatus, FeatureStatus, UTCTime, UTCTime] featureColumns = - K "mls_migration_status" + K "mls_migration_lock_status" + :* K "mls_migration_status" :* K "mls_migration_start_time" :* K "mls_migration_finalise_regardless_after" :* Nil - lockStatusColumn = Just "mls_migration_lock_status" - mkFeature (status :* startTime :* finalizeAfter :* Nil) = - foldMap dbFeatureStatus status + mkFeature (lockStatus :* status :* startTime :* finalizeAfter :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) unmkFeature feat = - Just feat.status + Just feat.lockStatus + :* Just feat.status :* feat.config.startTime :* feat.config.finaliseRegardlessAfter :* Nil instance MakeFeature EnforceFileDownloadLocationConfig where - type FeatureRow EnforceFileDownloadLocationConfig = '[FeatureStatus, Text] + type FeatureRow EnforceFileDownloadLocationConfig = '[LockStatus, FeatureStatus, Text] featureColumns = - K "enforce_file_download_location_status" + K "enforce_file_download_location_lock_status" + :* K "enforce_file_download_location_status" :* K "enforce_file_download_location" :* Nil - lockStatusColumn = Just "enforce_file_download_location_lock_status" - mkFeature (status :* location :* Nil) = - foldMap dbFeatureStatus status + mkFeature (lockStatus :* status :* location :* Nil) = + foldMap dbFeatureLockStatus lockStatus + <> foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) - unmkFeature feat = Just feat.status :* feat.config.enforcedDownloadLocation :* Nil + unmkFeature feat = + Just feat.lockStatus + :* Just feat.status + :* feat.config.enforcedDownloadLocation + :* Nil instance MakeFeature LimitedEventFanoutConfig where featureColumns = K "limited_event_fanout_status" :* Nil @@ -275,15 +334,14 @@ fetchFeature :: TeamId -> m (DbFeature cfg) fetchFeature tid = do - let cols = hcollapse (featureColumns @cfg) - if null cols - then pure mempty - else do + case featureColumns @cfg of + Nil -> pure (mkFeature Nil) + cols -> do let select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = fromString $ "select " - <> intercalate ", " cols + <> intercalate ", " (hcollapse cols) <> " from team_features where team_id = ?" row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row @@ -299,7 +357,7 @@ storeFeature :: KnownNat (Length row) ) => TeamId -> - Feature cfg -> + LockableFeature cfg -> m () storeFeature tid feat = do if n == 0 @@ -323,33 +381,34 @@ storeFeature tid feat = do <> intercalate "," (replicate (succ n) "?") <> ")" -fetchFeatureLockStatus :: - forall cfg m. - (MakeFeature cfg, MonadClient m) => - TeamId -> - m (Tagged cfg (Maybe LockStatus)) -fetchFeatureLockStatus tid = do - case lockStatusColumn @cfg of - Nothing -> pure (Tagged Nothing) - Just col -> do - let select :: PrepQuery R (Identity TeamId) (Identity (Maybe LockStatus)) - select = fromString $ "select " <> col <> " from team_features where team_id = ?" - row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure . Tagged . (runIdentity =<<) $ row +class (FeatureRow cfg ~ row) => StoreFeatureLockStatus (row :: [Type]) cfg | cfg -> row where + storeFeatureLockStatus' :: (MonadClient m) => TeamId -> Tagged cfg LockStatus -> m () + +instance + {-# OVERLAPPING #-} + ( FeatureRow cfg ~ (LockStatus ': row), + MakeFeature cfg + ) => + StoreFeatureLockStatus (LockStatus ': row) cfg + where + storeFeatureLockStatus' tid lock = do + let col = unK (hd (featureColumns @cfg)) + insert :: PrepQuery W (TeamId, LockStatus) () + insert = + fromString $ + "insert into team_features (team_id, " <> col <> ") values (?, ?)" + retry x5 $ write insert (params LocalQuorum (tid, (untag lock))) + +instance (FeatureRow cfg ~ row) => StoreFeatureLockStatus row cfg where + storeFeatureLockStatus' _ _ = pure () storeFeatureLockStatus :: forall cfg m. - (MakeFeature cfg, MonadClient m) => + (MonadClient m, StoreFeatureLockStatus (FeatureRow cfg) cfg) => TeamId -> Tagged cfg LockStatus -> m () -storeFeatureLockStatus tid lock = do - case lockStatusColumn @cfg of - Nothing -> pure () - Just col -> do - let insert :: PrepQuery W (TeamId, LockStatus) () - insert = fromString $ "insert into team_features (team_id, " <> col <> ") values (?, ?)" - retry x5 $ write insert (params LocalQuorum (tid, untag lock)) +storeFeatureLockStatus = storeFeatureLockStatus' @(FeatureRow cfg) -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. @@ -362,6 +421,8 @@ type family TupleP (xs :: [Type]) where TupleP [a, b, c, d, e] = (a, b, c, d, e) TupleP [a, b, c, d, e, f] = (a, b, c, d, e, f) TupleP [a, b, c, d, e, f, g] = (a, b, c, d, e, f, g) + TupleP [a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h) + TupleP _ = TypeError ('Text "TupleP: tuple too long") -- | Convert @NP f [x1, ..., xn]@ to @NP I [f x1, ..., f xn]@. -- diff --git a/services/galley/src/Galley/Cassandra/TeamFeatures.hs b/services/galley/src/Galley/Cassandra/TeamFeatures.hs index 0cc657987a7..f1db0f1a5c6 100644 --- a/services/galley/src/Galley/Cassandra/TeamFeatures.hs +++ b/services/galley/src/Galley/Cassandra/TeamFeatures.hs @@ -55,15 +55,12 @@ interpretTeamFeatureStoreToCassandra = interpret $ \case TFS.GetFeatureConfigMulti sing tids -> do logEffect "TeamFeatureStore.GetFeatureConfigMulti" embedClient $ getFeatureConfigMulti sing tids - TFS.SetFeatureConfig sing tid wsnl -> do + TFS.SetFeatureConfig sing tid feat -> do logEffect "TeamFeatureStore.SetFeatureConfig" - embedClient $ setFeatureConfig sing tid wsnl - TFS.GetFeatureLockStatus sing tid -> do - logEffect "TeamFeatureStore.GetFeatureLockStatus" - fmap untag . embedClient $ getFeatureLockStatus sing tid - TFS.SetFeatureLockStatus sing tid ls -> do + embedClient $ setFeatureConfig sing tid feat + TFS.SetFeatureLockStatus sing tid lock -> do logEffect "TeamFeatureStore.SetFeatureLockStatus" - embedClient $ setFeatureLockStatus sing tid (Tagged ls) + embedClient $ setFeatureLockStatus sing tid (Tagged lock) TFS.GetAllFeatureConfigs tid -> do logEffect "TeamFeatureStore.GetAllFeatureConfigs" embedClient $ getAllFeatureConfigs tid @@ -80,20 +77,8 @@ getFeatureConfigMulti proxy = getFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> m (DbFeature cfg) getFeatureConfig = $(featureCases [|fetchFeature|]) -setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Feature cfg -> m () +setFeatureConfig :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> LockableFeature cfg -> m () setFeatureConfig = $(featureCases [|storeFeature|]) -getFeatureLockStatus :: - (MonadClient m) => - FeatureSingleton cfg -> - TeamId -> - m (Tagged cfg (Maybe LockStatus)) -getFeatureLockStatus = $(featureCases [|fetchFeatureLockStatus|]) - -setFeatureLockStatus :: - (MonadClient m) => - FeatureSingleton cfg -> - TeamId -> - Tagged cfg LockStatus -> - m () +setFeatureLockStatus :: (MonadClient m) => FeatureSingleton cfg -> TeamId -> Tagged cfg LockStatus -> m () setFeatureLockStatus = $(featureCases [|storeFeatureLockStatus|]) diff --git a/services/galley/src/Galley/Effects/TeamFeatureStore.hs b/services/galley/src/Galley/Effects/TeamFeatureStore.hs index 18ac6648a70..d319d3515da 100644 --- a/services/galley/src/Galley/Effects/TeamFeatureStore.hs +++ b/services/galley/src/Galley/Effects/TeamFeatureStore.hs @@ -20,7 +20,6 @@ module Galley.Effects.TeamFeatureStore where import Data.Id -import Imports import Polysemy import Wire.API.Team.Feature @@ -37,12 +36,8 @@ data TeamFeatureStore m a where SetFeatureConfig :: FeatureSingleton cfg -> TeamId -> - Feature cfg -> + LockableFeature cfg -> TeamFeatureStore m () - GetFeatureLockStatus :: - FeatureSingleton cfg -> - TeamId -> - TeamFeatureStore m (Maybe LockStatus) SetFeatureLockStatus :: FeatureSingleton cfg -> TeamId -> @@ -50,6 +45,6 @@ data TeamFeatureStore m a where TeamFeatureStore m () GetAllFeatureConfigs :: TeamId -> - TeamFeatureStore m (AllFeatures DbFeatureWithLock) + TeamFeatureStore m (AllFeatures DbFeature) makeSem ''TeamFeatureStore From 2bf29b711c8a7573e1ba0a29a4a941fc402ca687 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 7 Aug 2024 11:44:34 +0200 Subject: [PATCH 22/34] Automate concatenation of rows Also rename FeatureSingletonMlsMigration{Config} --- .gitignore | 3 + libs/wire-api/src/Wire/API/Team/Feature.hs | 7 +- services/galley/galley.cabal | 2 +- .../galley/src/Galley/Cassandra/FeatureTH.hs | 33 ++- .../Cassandra/GetAllTeamFeatureConfigs.hs | 238 ++++-------------- .../src/Galley/Cassandra/MakeFeature.hs | 30 +-- .../galley/src/Galley/Cassandra/Orphans.hs | 8 + 7 files changed, 108 insertions(+), 213 deletions(-) create mode 100644 services/galley/src/Galley/Cassandra/Orphans.hs diff --git a/.gitignore b/.gitignore index a6318e378e3..c5be8f38512 100644 --- a/.gitignore +++ b/.gitignore @@ -60,6 +60,9 @@ stack-dev.yaml # HIE db files (e.g. generated for stan) *.hie +# dump timings +*.dump-timings + # generated files under .local .local diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 4fc8cb1856b..88ec2f9a25a 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -210,10 +210,7 @@ data FeatureSingleton cfg where FeatureSingletonExposeInvitationURLsToTeamAdminConfig :: FeatureSingleton ExposeInvitationURLsToTeamAdminConfig FeatureSingletonOutlookCalIntegrationConfig :: FeatureSingleton OutlookCalIntegrationConfig FeatureSingletonMlsE2EIdConfig :: FeatureSingleton MlsE2EIdConfig - FeatureSingletonMlsMigration :: - -- FUTUREWORK: rename to `FeatureSingletonMlsMigrationConfig` (or drop the `Config` from - -- all other constructors) - FeatureSingleton MlsMigrationConfig + FeatureSingletonMlsMigrationConfig :: FeatureSingleton MlsMigrationConfig FeatureSingletonEnforceFileDownloadLocationConfig :: FeatureSingleton EnforceFileDownloadLocationConfig FeatureSingletonLimitedEventFanoutConfig :: FeatureSingleton LimitedEventFanoutConfig @@ -1145,7 +1142,7 @@ instance Default (LockableFeature MlsMigrationConfig) where instance IsFeatureConfig MlsMigrationConfig where type FeatureSymbol MlsMigrationConfig = "mlsMigration" - featureSingleton = FeatureSingletonMlsMigration + featureSingleton = FeatureSingletonMlsMigrationConfig objectSchema = field "config" schema ---------------------------------------------------------------------- diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 649855d508a..3437caf3795 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -141,6 +141,7 @@ library Galley.Cassandra.Instances Galley.Cassandra.LegalHold Galley.Cassandra.MakeFeature + Galley.Cassandra.Orphans Galley.Cassandra.Proposal Galley.Cassandra.Queries Galley.Cassandra.SearchVisibility @@ -302,7 +303,6 @@ library , cassava >=0.5.2 , comonad , containers >=0.5 - , cql , crypton , crypton-x509 , currency-codes >=2.0 diff --git a/services/galley/src/Galley/Cassandra/FeatureTH.hs b/services/galley/src/Galley/Cassandra/FeatureTH.hs index d4583cd0c27..e0c1fb12be2 100644 --- a/services/galley/src/Galley/Cassandra/FeatureTH.hs +++ b/services/galley/src/Galley/Cassandra/FeatureTH.hs @@ -3,8 +3,10 @@ module Galley.Cassandra.FeatureTH where +import Data.Kind +import Generics.SOP.TH import Imports -import Language.Haskell.TH +import Language.Haskell.TH hiding (Type) import Wire.API.Team.Feature featureCases :: ExpQ -> Q Exp @@ -16,3 +18,32 @@ featureCases rhsQ = do [ Match (ConP c [] []) (NormalB rhs) [] | GadtC [c] _ _ <- constructors ] + +generateTupleP :: Q [Dec] +generateTupleP = do + let maxSize = 64 :: Int + tylist <- [t|[Type]|] + let vars = [VarT (mkName ("a" <> show i)) | i <- [0 .. maxSize - 1]] + pure + [ ClosedTypeFamilyD + (TypeFamilyHead (mkName "TupleP") [KindedTV (mkName "xs") () tylist] NoSig Nothing) + [ TySynEqn + Nothing + ( ConT (mkName "TupleP") + `AppT` mkPattern (take n vars) + ) + (mkTuple (take n vars)) + | n <- [0 .. maxSize] + ] + ] + where + mkPattern = foldr (\x y -> PromotedConsT `AppT` x `AppT` y) PromotedNilT + + mkTuple [] = ConT ''() + mkTuple [v] = ConT ''Identity `AppT` v + mkTuple vs = + let n = length vs + in foldl' AppT (TupleT n) vs + +generateSOPInstances :: Q [Dec] +generateSOPInstances = concat <$> traverse (deriveGeneric . tupleTypeName) [31 .. 50] diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index c02b6e28362..4ee8b8d13ce 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -1,206 +1,66 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} module Galley.Cassandra.GetAllTeamFeatureConfigs where import Cassandra -import Cassandra qualified as C import Data.Id -import Data.Misc (HttpsUrl) -import Data.SOP -import Data.Time -import Database.CQL.Protocol import Galley.Cassandra.Instances () import Galley.Cassandra.MakeFeature -import Imports -import Wire.API.Conversation.Protocol (ProtocolTag) -import Wire.API.MLS.CipherSuite +import Galley.Cassandra.Orphans () +import Generics.SOP +import Imports hiding (Map) +import Polysemy.Internal 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, - conferenceCallingOne2One :: Maybe One2OneCalls, - conferenceCallingLock :: Maybe LockStatus, - -- 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, - mlsE2eidMaybeCrlProxy :: Maybe HttpsUrl, - mlsE2eidMaybeUseProxyOnMobile :: Maybe Bool, - 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) +type family ConcatFeatureRow xs where + ConcatFeatureRow '[] = '[] + ConcatFeatureRow (x : xs) = Append (FeatureRow x) (ConcatFeatureRow xs) -recordInstance ''AllTeamFeatureConfigsRow +type AllFeatureRow = ConcatFeatureRow Features -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, - conferenceCallingOne2One = Nothing, - conferenceCallingLock = 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, - mlsE2eidMaybeCrlProxy = Nothing, - mlsE2eidMaybeUseProxyOnMobile = 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 - } +emptyRow :: NP Maybe AllFeatureRow +emptyRow = hpure Nothing -allFeatureConfigsFromRow :: AllTeamFeatureConfigsRow -> AllFeatures DbFeature -allFeatureConfigsFromRow row = - mkFeature (row.legalhold :* Nil) - :* mkFeature (row.sso :* Nil) - :* mkFeature (row.searchVisibility :* Nil) - :* mkFeature (row.searchVisibility :* Nil) - :* mkFeature (row.validateSamlEmails :* Nil) - :* mkFeature (row.digitalSignatures :* Nil) - :* mkFeature (row.appLock :* row.appLockEnforce :* row.appLockInactivityTimeoutSecs :* Nil) - :* mkFeature (row.fileSharingLock :* row.fileSharing :* Nil) - :* mkFeature Nil - :* mkFeature (row.conferenceCallingLock :* row.conferenceCalling :* row.conferenceCallingOne2One :* Nil) - :* mkFeature (row.selfDeletingMessagesLock :* row.selfDeletingMessages :* row.selfDeletingMessagesTtl :* Nil) - :* mkFeature (row.guestLinksLock :* row.guestLinks :* Nil) - :* mkFeature (row.sndFactorLock :* row.sndFactor :* Nil) - :* mkFeature (row.mlsLock :* row.mls :* row.mlsDefaultProtocol :* row.mlsToggleUsers :* row.mlsAllowedCipherSuites :* row.mlsDefaultCipherSuite :* row.mlsSupportedProtocols :* Nil) - :* mkFeature (row.exposeInvitationUrls :* Nil) - :* mkFeature (row.outlookCalIntegrationLock :* row.outlookCalIntegration :* Nil) - :* mkFeature - ( row.mlsE2eidLock - :* row.mlsE2eid - :* row.mlsE2eidGracePeriod - :* row.mlsE2eidAcmeDiscoverUrl - :* row.mlsE2eidMaybeCrlProxy - :* row.mlsE2eidMaybeUseProxyOnMobile - :* Nil - ) - :* mkFeature (row.mlsMigrationLock :* row.mlsMigration :* row.mlsMigrationStartTime :* row.mlsMigrationFinalizeRegardlessAfter :* Nil) - :* mkFeature (row.enforceDownloadLocationLock :* row.enforceDownloadLocation :* row.enforceDownloadLocation_Location :* Nil) - :* mkFeature (row.limitEventFanout :* Nil) - :* Nil +class ConcatFeatures cfgs where + mkAllFeatures :: NP Maybe (ConcatFeatureRow cfgs) -> NP DbFeature cfgs -getAllFeatureConfigs :: (MonadClient m) => TeamId -> m (AllFeatures DbFeature) +instance ConcatFeatures '[] where + mkAllFeatures Nil = Nil + +instance + ( Split (FeatureRow cfg) (ConcatFeatureRow cfgs), + ConcatFeatures cfgs, + MakeFeature cfg + ) => + ConcatFeatures (cfg : cfgs) + where + mkAllFeatures row = case split @(FeatureRow cfg) @(ConcatFeatureRow cfgs) row of + (row0, row1) -> mkFeature row0 :* mkAllFeatures row1 + +class Split xs ys where + split :: NP f (Append xs ys) -> (NP f xs, NP f ys) + +instance Split '[] ys where + split ys = (Nil, ys) + +instance (Split xs ys) => Split (x ': xs) ys where + split (z :* zs) = case split zs of + (xs, ys) -> (z :* xs, ys) + +getAllFeatureConfigs :: + forall row mrow m. + ( MonadClient m, + row ~ AllFeatureRow, + Tuple (TupleP mrow), + IsProductType (TupleP mrow) mrow, + AllZip (IsF Maybe) row mrow + ) => + TeamId -> + m (AllFeatures DbFeature) getAllFeatureConfigs tid = do mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ allFeatureConfigsFromRow $ maybe emptyRow asRecord mRow + pure $ mkAllFeatures $ maybe emptyRow (unfactorI . productTypeFrom) 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_status, ttl(conference_calling_status), conference_calling_one_to_one, 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_crl_proxy, mls_e2eid_use_proxy_on_mobile, 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 = ?" + select :: PrepQuery R (Identity TeamId) (TupleP mrow) + select = fromString "" diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 71a1c62a95b..275f3842acb 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE TemplateHaskell #-} -- | Abstraction to fetch and store feature values from and to the database. module Galley.Cassandra.MakeFeature where @@ -14,8 +14,8 @@ import Data.List.Singletons (Length) import Data.Misc (HttpsUrl) import Data.Singletons (demote) import Data.Time -import GHC.TypeError import GHC.TypeNats +import Galley.Cassandra.FeatureTH import Galley.Cassandra.Instances () import Generics.SOP import Imports hiding (Generic, Map) @@ -23,6 +23,10 @@ import Wire.API.Conversation.Protocol (ProtocolTag) import Wire.API.MLS.CipherSuite import Wire.API.Team.Feature +-- | This is necessary in order to convert an @NP f xs@ type to something that +-- CQL can understand. +$(generateTupleP) + class MakeFeature cfg where type FeatureRow cfg :: [Type] type FeatureRow cfg = '[FeatureStatus] @@ -52,6 +56,12 @@ instance MakeFeature SSOConfig where instance MakeFeature SearchVisibilityAvailableConfig where featureColumns = K "search_visibility_status" :* Nil +-- | This feature shares its status column with +-- 'SearchVisibilityAvailableConfig'. This means that when fetching all +-- features, this column is repeated in the query, i.e. the query looks like: +-- @@ +-- select ..., search_visibility_status, search_visibility_status, ... from team_features ... +-- @@ instance MakeFeature SearchVisibilityInboundConfig where featureColumns = K "search_visibility_status" :* Nil @@ -381,7 +391,7 @@ storeFeature tid feat = do <> intercalate "," (replicate (succ n) "?") <> ")" -class (FeatureRow cfg ~ row) => StoreFeatureLockStatus (row :: [Type]) cfg | cfg -> row where +class (FeatureRow cfg ~ row) => StoreFeatureLockStatus (row :: [Type]) cfg where storeFeatureLockStatus' :: (MonadClient m) => TeamId -> Tagged cfg LockStatus -> m () instance @@ -410,20 +420,6 @@ storeFeatureLockStatus :: m () storeFeatureLockStatus = storeFeatureLockStatus' @(FeatureRow cfg) --- | This is necessary in order to convert an @NP f xs@ type to something that --- CQL can understand. -type family TupleP (xs :: [Type]) where - TupleP '[] = () - TupleP '[a] = Identity a - TupleP [a, b] = (a, b) - TupleP [a, b, c] = (a, b, c) - TupleP [a, b, c, d] = (a, b, c, d) - TupleP [a, b, c, d, e] = (a, b, c, d, e) - TupleP [a, b, c, d, e, f] = (a, b, c, d, e, f) - TupleP [a, b, c, d, e, f, g] = (a, b, c, d, e, f, g) - TupleP [a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h) - TupleP _ = TypeError ('Text "TupleP: tuple too long") - -- | Convert @NP f [x1, ..., xn]@ to @NP I [f x1, ..., f xn]@. -- -- This works because @I . f = f@. diff --git a/services/galley/src/Galley/Cassandra/Orphans.hs b/services/galley/src/Galley/Cassandra/Orphans.hs new file mode 100644 index 00000000000..d939cdafdb0 --- /dev/null +++ b/services/galley/src/Galley/Cassandra/Orphans.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Galley.Cassandra.Orphans where + +import Galley.Cassandra.FeatureTH + +$generateSOPInstances From 00f853aa7e75124e08b3a28cd49d2c7e3d3063b0 Mon Sep 17 00:00:00 2001 From: Magnus Viernickel Date: Wed, 7 Aug 2024 14:15:09 +0200 Subject: [PATCH 23/34] [chore] add changelog entry --- changelog.d/5-internal/feature-flag-refactoring-1 | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 changelog.d/5-internal/feature-flag-refactoring-1 diff --git a/changelog.d/5-internal/feature-flag-refactoring-1 b/changelog.d/5-internal/feature-flag-refactoring-1 new file mode 100644 index 00000000000..92f0a33d35a --- /dev/null +++ b/changelog.d/5-internal/feature-flag-refactoring-1 @@ -0,0 +1,7 @@ +Refactor feature flags +- Improved naming slightly. Features types are now called `Feature`, `LockableFeature` and `LockableFeaturePatch` +- Turned `AllFeatures` into an extensible record type +- Removed `WithStatusBase` barbie. +- Deleted obsolete `computeFeatureConfigForTeamUser` +- Abstracted `getFeature` and `setFeature` +- Abstracted getAllTeamFeatures From 9d328b3681570924ec3f22141ed747a644df59ab Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:28:34 +0200 Subject: [PATCH 24/34] Remove todo Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> --- libs/wire-api/src/Wire/API/Team/Feature.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 88ec2f9a25a..8ad5c9fca5a 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -1307,8 +1307,6 @@ instance Default AllFeatureConfigs where def = hcpure (Proxy @LockableFeatureDefault) def -- | object schema for nary products --- --- TODO(mangoiv): generalize this to be useable with schema profunctor class HObjectSchema c xs where hobjectSchema :: (forall cfg. (c cfg) => ObjectSchema SwaggerDoc (f cfg)) -> ObjectSchema SwaggerDoc (NP f xs) From 70f1a1f5e8044141ea406b07988abc5e3f7437e7 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:38:56 +0200 Subject: [PATCH 25/34] Add haddock to generateSOPInstances Co-authored-by: Mango The Fourth <40720523+MangoIV@users.noreply.github.com> --- services/galley/src/Galley/Cassandra/FeatureTH.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/services/galley/src/Galley/Cassandra/FeatureTH.hs b/services/galley/src/Galley/Cassandra/FeatureTH.hs index e0c1fb12be2..7422cbe601d 100644 --- a/services/galley/src/Galley/Cassandra/FeatureTH.hs +++ b/services/galley/src/Galley/Cassandra/FeatureTH.hs @@ -45,5 +45,9 @@ generateTupleP = do let n = length vs in foldl' AppT (TupleT n) vs +-- | generates some of the remaining @SOP.Generic@ instances as orphans +-- it is cut off at 50 on purpose to reduce compilation times +-- you may increase up to 64 which is the number at which you +-- you should probably start fixing cql instead. generateSOPInstances :: Q [Dec] generateSOPInstances = concat <$> traverse (deriveGeneric . tupleTypeName) [31 .. 50] From 59ce0ade4f9a1c003ff2c69e94e69d2ffaf9c707 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:17:33 +0200 Subject: [PATCH 26/34] Recurse on all features in Arbitray Event instance --- .../src/Wire/API/Event/FeatureConfig.hs | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index e2c57e7b3b3..ca1e3fc7534 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -30,7 +30,7 @@ import Data.OpenApi qualified as S import Data.Schema import GHC.TypeLits (KnownSymbol) import Imports -import Test.QuickCheck.Gen (oneof) +import Test.QuickCheck.Gen import Wire.API.Team.Feature import Wire.Arbitrary (Arbitrary (..), GenericUniform (..)) @@ -42,30 +42,31 @@ data Event = Event deriving (Eq, Show, Generic) deriving (A.ToJSON, A.FromJSON) via Schema Event +arbitraryFeature :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, Arbitrary cfg) => Gen A.Value +arbitraryFeature = toJSON <$> arbitrary @(LockableFeature cfg) + +class AllArbitraryFeatures cfgs where + allArbitraryFeatures :: [Gen A.Value] + +instance AllArbitraryFeatures '[] where + allArbitraryFeatures = [] + +instance + ( IsFeatureConfig cfg, + ToSchema cfg, + Arbitrary cfg, + AllArbitraryFeatures cfgs + ) => + AllArbitraryFeatures (cfg : cfgs) + where + allArbitraryFeatures = arbitraryFeature @cfg : allArbitraryFeatures @cfgs + instance Arbitrary Event where arbitrary = - do - let arbConfig = - oneof - [ arbitrary @(LockableFeature SSOConfig) <&> toJSON, - arbitrary @(LockableFeature SearchVisibilityAvailableConfig) <&> toJSON, - arbitrary @(LockableFeature ValidateSAMLEmailsConfig) <&> toJSON, - arbitrary @(LockableFeature DigitalSignaturesConfig) <&> toJSON, - arbitrary @(LockableFeature AppLockConfig) <&> toJSON, - arbitrary @(LockableFeature FileSharingConfig) <&> toJSON, - arbitrary @(LockableFeature ClassifiedDomainsConfig) <&> toJSON, - arbitrary @(LockableFeature ConferenceCallingConfig) <&> toJSON, - arbitrary @(LockableFeature SelfDeletingMessagesConfig) <&> toJSON, - arbitrary @(LockableFeature GuestLinksConfig) <&> toJSON, - arbitrary @(LockableFeature SndFactorPasswordChallengeConfig) <&> toJSON, - arbitrary @(LockableFeature SearchVisibilityInboundConfig) <&> toJSON, - arbitrary @(LockableFeature MLSConfig) <&> toJSON, - arbitrary @(LockableFeature ExposeInvitationURLsToTeamAdminConfig) <&> toJSON - ] - Event - <$> arbitrary - <*> arbitrary - <*> arbConfig + Event + <$> arbitrary + <*> arbitrary + <*> oneof (allArbitraryFeatures @Features) data EventType = Update deriving (Eq, Show, Generic) From 1b0d45bbec413da791e351ec84785c2eaff9ac10 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:22:00 +0200 Subject: [PATCH 27/34] Remove redundant hiding clause --- libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs index bc963d2d962..73087b78ea3 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs @@ -23,7 +23,7 @@ import Data.OpenApi (OpenApi) import Data.OpenApi.Lens import Data.Proxy import Imports -import Servant.API hiding (Header) +import Servant.API import Servant.OpenApi import Wire.API.Team.Feature From cae9fef80ff0500348c6351a480ee2c4f817420a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:33:54 +0200 Subject: [PATCH 28/34] Remove unnecessary extensions Also get rid of LiftForF constraint, which required `UndecidableSuperClasses`. --- libs/wire-api/src/Wire/API/Team/Feature.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index 8ad5c9fca5a..095c2fe5f9b 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -1,12 +1,8 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE NoStarIsType #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. @@ -1296,12 +1292,9 @@ type AllFeatures f = NP f Features -- | 'AllFeatures' specialised to the 'LockableFeature' functor type AllFeatureConfigs = AllFeatures LockableFeature --- | constraint synonym requiring the @c@ instance for the @f@ type constructor applied to type @a@ to hold -class (c (f a)) => LiftForF c f a +class (Default (LockableFeature cfg)) => LockableFeatureDefault cfg -instance (c (f a)) => LiftForF c f a - -type LockableFeatureDefault = LiftForF Default LockableFeature +instance (Default (LockableFeature cfg)) => LockableFeatureDefault cfg instance Default AllFeatureConfigs where def = hcpure (Proxy @LockableFeatureDefault) def @@ -1328,9 +1321,15 @@ instance ToSchema AllFeatureConfigs where featureField :: forall cfg. (FeatureFieldConstraints cfg) => ObjectSchema SwaggerDoc (LockableFeature cfg) featureField = field (T.pack (symbolVal (Proxy @(FeatureSymbol cfg)))) schema +class (Arbitrary cfg, IsFeatureConfig cfg) => ArbitraryFeatureConfig cfg + +instance (Arbitrary cfg, IsFeatureConfig cfg) => ArbitraryFeatureConfig cfg + instance Arbitrary AllFeatureConfigs where - arbitrary = hsequence' $ hcpure (Proxy @(LiftForF Arbitrary LockableFeature)) (Comp arbitrary) + arbitrary = hsequence' $ hcpure (Proxy @ArbitraryFeatureConfig) (Comp arbitrary) +-- | FUTUREWORK: 'NpProject' and 'NpUpdate' can be useful for more than +-- features. Maybe they should be moved somewhere else. class NpProject x xs where npProject' :: Proxy x -> NP f xs -> f x From d71e2e23caeb915b6b9cd4c07bec1e5f84fcd314 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:42:32 +0200 Subject: [PATCH 29/34] Rename mkFeature and unmkFeature --- services/galley/src/Galley/API/Internal.hs | 2 +- .../Cassandra/GetAllTeamFeatureConfigs.hs | 10 +-- .../src/Galley/Cassandra/MakeFeature.hs | 66 +++++++++---------- 3 files changed, 39 insertions(+), 39 deletions(-) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index ee5e94c3c45..7dc40d9c289 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -72,7 +72,7 @@ import Polysemy import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog qualified as P -import Servant hiding (JSON) +import Servant import System.Logger.Class hiding (Path, name) import System.Logger.Class qualified as Log import Wire.API.Conversation hiding (Member) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 4ee8b8d13ce..3fd1ba5f470 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -23,10 +23,10 @@ emptyRow :: NP Maybe AllFeatureRow emptyRow = hpure Nothing class ConcatFeatures cfgs where - mkAllFeatures :: NP Maybe (ConcatFeatureRow cfgs) -> NP DbFeature cfgs + rowToAllFeatures :: NP Maybe (ConcatFeatureRow cfgs) -> NP DbFeature cfgs instance ConcatFeatures '[] where - mkAllFeatures Nil = Nil + rowToAllFeatures Nil = Nil instance ( Split (FeatureRow cfg) (ConcatFeatureRow cfgs), @@ -35,8 +35,8 @@ instance ) => ConcatFeatures (cfg : cfgs) where - mkAllFeatures row = case split @(FeatureRow cfg) @(ConcatFeatureRow cfgs) row of - (row0, row1) -> mkFeature row0 :* mkAllFeatures row1 + rowToAllFeatures row = case split @(FeatureRow cfg) @(ConcatFeatureRow cfgs) row of + (row0, row1) -> rowToFeature row0 :* rowToAllFeatures row1 class Split xs ys where split :: NP f (Append xs ys) -> (NP f xs, NP f ys) @@ -60,7 +60,7 @@ getAllFeatureConfigs :: m (AllFeatures DbFeature) getAllFeatureConfigs tid = do mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ mkAllFeatures $ maybe emptyRow (unfactorI . productTypeFrom) mRow + pure $ rowToAllFeatures $ maybe emptyRow (unfactorI . productTypeFrom) mRow where select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = fromString "" diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 275f3842acb..f54e2a6e24e 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -33,19 +33,19 @@ class MakeFeature cfg where featureColumns :: NP (K String) (FeatureRow cfg) - mkFeature :: NP Maybe (FeatureRow cfg) -> DbFeature cfg - default mkFeature :: + rowToFeature :: NP Maybe (FeatureRow cfg) -> DbFeature cfg + default rowToFeature :: (FeatureRow cfg ~ '[FeatureStatus]) => NP Maybe (FeatureRow cfg) -> DbFeature cfg - mkFeature = foldMap dbFeatureStatus . hd + rowToFeature = foldMap dbFeatureStatus . hd - unmkFeature :: LockableFeature cfg -> NP Maybe (FeatureRow cfg) - default unmkFeature :: + featureToRow :: LockableFeature cfg -> NP Maybe (FeatureRow cfg) + default featureToRow :: (FeatureRow cfg ~ '[FeatureStatus]) => LockableFeature cfg -> NP Maybe (FeatureRow cfg) - unmkFeature feat = Just feat.status :* Nil + featureToRow feat = Just feat.status :* Nil instance MakeFeature LegalholdConfig where featureColumns = K "legalhold_status" :* Nil @@ -79,11 +79,11 @@ instance MakeFeature AppLockConfig where :* K "app_lock_inactivity_timeout_secs" :* Nil - mkFeature (status :* enforce :* timeout :* Nil) = + rowToFeature (status :* enforce :* timeout :* Nil) = foldMap dbFeatureStatus status <> foldMap dbFeatureConfig (AppLockConfig <$> enforce <*> timeout) - unmkFeature feat = + featureToRow feat = Just feat.status :* Just feat.config.applockEnforceAppLock :* Just feat.config.applockInactivityTimeoutSecs @@ -93,18 +93,18 @@ instance MakeFeature ClassifiedDomainsConfig where type FeatureRow ClassifiedDomainsConfig = '[] featureColumns = Nil - mkFeature Nil = mempty - unmkFeature _ = Nil + rowToFeature Nil = mempty + featureToRow _ = Nil instance MakeFeature FileSharingConfig where type FeatureRow FileSharingConfig = '[LockStatus, FeatureStatus] featureColumns = K "file_sharing_lock_status" :* K "file_sharing" :* Nil - mkFeature (lockStatus :* status :* Nil) = + rowToFeature (lockStatus :* status :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status - unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature ConferenceCallingConfig where type FeatureRow ConferenceCallingConfig = '[LockStatus, FeatureStatus, One2OneCalls] @@ -114,12 +114,12 @@ instance MakeFeature ConferenceCallingConfig where :* K "conference_calling_one_to_one" :* Nil - mkFeature (lockStatus :* status :* calls :* Nil) = + rowToFeature (lockStatus :* status :* calls :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . ConferenceCallingConfig) calls - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Just feat.config.one2OneCalls @@ -133,12 +133,12 @@ instance MakeFeature SelfDeletingMessagesConfig where :* K "self_deleting_messages_ttl" :* Nil - mkFeature (lockStatus :* status :* ttl :* Nil) = + rowToFeature (lockStatus :* status :* ttl :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status <> foldMap (dbFeatureConfig . SelfDeletingMessagesConfig) ttl - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Just feat.config.sdmEnforcedTimeoutSeconds @@ -148,11 +148,11 @@ instance MakeFeature GuestLinksConfig where type FeatureRow GuestLinksConfig = '[LockStatus, FeatureStatus] featureColumns = K "guest_links_lock_status" :* K "guest_links_status" :* Nil - mkFeature (lockStatus :* status :* Nil) = + rowToFeature (lockStatus :* status :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status - unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature SndFactorPasswordChallengeConfig where type FeatureRow SndFactorPasswordChallengeConfig = '[LockStatus, FeatureStatus] @@ -161,11 +161,11 @@ instance MakeFeature SndFactorPasswordChallengeConfig where :* K "snd_factor_password_challenge_status" :* Nil - mkFeature (lockStatus :* status :* Nil) = + rowToFeature (lockStatus :* status :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status - unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature ExposeInvitationURLsToTeamAdminConfig where featureColumns = K "expose_invitation_urls_to_team_admin" :* Nil @@ -178,11 +178,11 @@ instance MakeFeature OutlookCalIntegrationConfig where :* K "outlook_cal_integration_status" :* Nil - mkFeature (lockStatus :* status :* Nil) = + rowToFeature (lockStatus :* status :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status - unmkFeature feat = Just feat.lockStatus :* Just feat.status :* Nil + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Nil instance MakeFeature MLSConfig where type @@ -205,7 +205,7 @@ instance MakeFeature MLSConfig where :* K "mls_supported_protocols" :* Nil - mkFeature + rowToFeature ( lockStatus :* status :* defProto @@ -226,7 +226,7 @@ instance MakeFeature MLSConfig where <*> pure (foldMap C.fromSet supportedProtos) ) - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Just feat.config.mlsDefaultProtocol @@ -255,7 +255,7 @@ instance MakeFeature MlsE2EIdConfig where :* K "mls_e2eid_use_proxy_on_mobile" :* Nil - mkFeature + rowToFeature ( lockStatus :* status :* gracePeriod @@ -277,7 +277,7 @@ instance MakeFeature MlsE2EIdConfig where } ) - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* Just (truncate feat.config.verificationExpiration) @@ -298,12 +298,12 @@ instance MakeFeature MlsMigrationConfig where :* K "mls_migration_finalise_regardless_after" :* Nil - mkFeature (lockStatus :* status :* startTime :* finalizeAfter :* Nil) = + rowToFeature (lockStatus :* status :* startTime :* finalizeAfter :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status <> dbFeatureConfig (MlsMigrationConfig startTime finalizeAfter) - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* feat.config.startTime @@ -319,11 +319,11 @@ instance MakeFeature EnforceFileDownloadLocationConfig where :* K "enforce_file_download_location" :* Nil - mkFeature (lockStatus :* status :* location :* Nil) = + rowToFeature (lockStatus :* status :* location :* Nil) = foldMap dbFeatureLockStatus lockStatus <> foldMap dbFeatureStatus status <> dbFeatureConfig (EnforceFileDownloadLocationConfig location) - unmkFeature feat = + featureToRow feat = Just feat.lockStatus :* Just feat.status :* feat.config.enforcedDownloadLocation @@ -345,7 +345,7 @@ fetchFeature :: m (DbFeature cfg) fetchFeature tid = do case featureColumns @cfg of - Nil -> pure (mkFeature Nil) + Nil -> pure (rowToFeature Nil) cols -> do let select :: PrepQuery R (Identity TeamId) (TupleP mrow) select = @@ -354,7 +354,7 @@ fetchFeature tid = do <> intercalate ", " (hcollapse cols) <> " from team_features where team_id = ?" row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (mkFeature . unfactorI . productTypeFrom) row + pure $ foldMap (rowToFeature . unfactorI . productTypeFrom) row storeFeature :: forall cfg m row mrow. @@ -376,7 +376,7 @@ storeFeature tid feat = do retry x5 $ write insert - ( params LocalQuorum (productTypeTo (I tid :* factorI (unmkFeature feat))) + ( params LocalQuorum (productTypeTo (I tid :* factorI (featureToRow feat))) ) where n :: Int From 835f9254edb65aaeec3421cb1edf85d54f6325a0 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:48:38 +0200 Subject: [PATCH 30/34] Add generated code excerpt to generateTupleP Also remove unnecessary parenthesis. --- services/galley/src/Galley/Cassandra/MakeFeature.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index f54e2a6e24e..382fe4db0ea 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -25,7 +25,16 @@ import Wire.API.Team.Feature -- | This is necessary in order to convert an @NP f xs@ type to something that -- CQL can understand. -$(generateTupleP) +-- +-- The generated code looks like: +-- @@ +-- instance TupleP xs where +-- TupleP '[] = () +-- TupleP '[a] = Identity a +-- TupleP '[a, b] = (a, b) +-- ... +-- @@ +$generateTupleP class MakeFeature cfg where type FeatureRow cfg :: [Type] From cb76183167ca8d3f72f6e68bc8841acb29114b7b Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:50:49 +0200 Subject: [PATCH 31/34] Remove unnecessary constraint --- tools/stern/test/integration/API.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/tools/stern/test/integration/API.hs b/tools/stern/test/integration/API.hs index 591a01a30e2..de4d3917d9c 100644 --- a/tools/stern/test/integration/API.hs +++ b/tools/stern/test/integration/API.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} From ca74ec39f40f4a49a21c1c6e6e5ebf5ebdf40277 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 8 Aug 2024 08:56:51 +0200 Subject: [PATCH 32/34] Lint --- services/galley/default.nix | 2 -- services/galley/src/Galley/Cassandra/FeatureTH.hs | 2 +- .../galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/services/galley/default.nix b/services/galley/default.nix index de625562b12..c3ef5ddd9e3 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -27,7 +27,6 @@ , conduit , containers , cookie -, cql , crypton , crypton-x509 , currency-codes @@ -155,7 +154,6 @@ mkDerivation { cassava comonad containers - cql crypton crypton-x509 currency-codes diff --git a/services/galley/src/Galley/Cassandra/FeatureTH.hs b/services/galley/src/Galley/Cassandra/FeatureTH.hs index 7422cbe601d..cf52cdc6caf 100644 --- a/services/galley/src/Galley/Cassandra/FeatureTH.hs +++ b/services/galley/src/Galley/Cassandra/FeatureTH.hs @@ -1,5 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module Galley.Cassandra.FeatureTH where diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index 3fd1ba5f470..d13cc7642a6 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} module Galley.Cassandra.GetAllTeamFeatureConfigs where From e4737a1f5c74dde6e60e9702c089ebecf895e45f Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 9 Aug 2024 13:44:29 +0200 Subject: [PATCH 33/34] Finish implementation of getAllFeatureConfigs --- .../Cassandra/GetAllTeamFeatureConfigs.hs | 49 +++++++++++++------ .../src/Galley/Cassandra/MakeFeature.hs | 30 +++++++++--- 2 files changed, 57 insertions(+), 22 deletions(-) diff --git a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs index d13cc7642a6..6fd27b9e107 100644 --- a/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs +++ b/services/galley/src/Galley/Cassandra/GetAllTeamFeatureConfigs.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} -module Galley.Cassandra.GetAllTeamFeatureConfigs where +module Galley.Cassandra.GetAllTeamFeatureConfigs (getAllFeatureConfigs) where import Cassandra import Data.Id @@ -28,25 +28,49 @@ instance ConcatFeatures '[] where rowToAllFeatures Nil = Nil instance - ( Split (FeatureRow cfg) (ConcatFeatureRow cfgs), + ( SplitNP (FeatureRow cfg) (ConcatFeatureRow cfgs), ConcatFeatures cfgs, MakeFeature cfg ) => ConcatFeatures (cfg : cfgs) where - rowToAllFeatures row = case split @(FeatureRow cfg) @(ConcatFeatureRow cfgs) row of + rowToAllFeatures row = case splitNP @(FeatureRow cfg) @(ConcatFeatureRow cfgs) row of (row0, row1) -> rowToFeature row0 :* rowToAllFeatures row1 -class Split xs ys where - split :: NP f (Append xs ys) -> (NP f xs, NP f ys) +class SplitNP xs ys where + splitNP :: NP f (Append xs ys) -> (NP f xs, NP f ys) -instance Split '[] ys where - split ys = (Nil, ys) +instance SplitNP '[] ys where + splitNP ys = (Nil, ys) -instance (Split xs ys) => Split (x ': xs) ys where - split (z :* zs) = case split zs of +instance (SplitNP xs ys) => SplitNP (x ': xs) ys where + splitNP (z :* zs) = case splitNP zs of (xs, ys) -> (z :* xs, ys) +class AppendNP xs ys where + appendNP :: NP f xs -> NP f ys -> NP f (Append xs ys) + +instance AppendNP '[] ys where + appendNP Nil ys = ys + +instance (AppendNP xs ys) => AppendNP (x : xs) ys where + appendNP (x :* xs) ys = x :* appendNP xs ys + +class ConcatColumns cfgs where + concatColumns :: NP (K String) (ConcatFeatureRow cfgs) + +instance ConcatColumns '[] where + concatColumns = Nil + +instance + ( AppendNP (FeatureRow cfg) (ConcatFeatureRow cfgs), + MakeFeature cfg, + ConcatColumns cfgs + ) => + ConcatColumns (cfg : cfgs) + where + concatColumns = featureColumns @cfg `appendNP` concatColumns @cfgs + getAllFeatureConfigs :: forall row mrow m. ( MonadClient m, @@ -58,8 +82,5 @@ getAllFeatureConfigs :: TeamId -> m (AllFeatures DbFeature) getAllFeatureConfigs tid = do - mRow <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ rowToAllFeatures $ maybe emptyRow (unfactorI . productTypeFrom) mRow - where - select :: PrepQuery R (Identity TeamId) (TupleP mrow) - select = fromString "" + mRow <- fetchFeatureRow @row @mrow tid (concatColumns @Features) + pure . rowToAllFeatures $ fromMaybe emptyRow mRow diff --git a/services/galley/src/Galley/Cassandra/MakeFeature.hs b/services/galley/src/Galley/Cassandra/MakeFeature.hs index 382fe4db0ea..2db777f2521 100644 --- a/services/galley/src/Galley/Cassandra/MakeFeature.hs +++ b/services/galley/src/Galley/Cassandra/MakeFeature.hs @@ -356,14 +356,28 @@ fetchFeature tid = do case featureColumns @cfg of Nil -> pure (rowToFeature Nil) cols -> do - let select :: PrepQuery R (Identity TeamId) (TupleP mrow) - select = - fromString $ - "select " - <> intercalate ", " (hcollapse cols) - <> " from team_features where team_id = ?" - row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) - pure $ foldMap (rowToFeature . unfactorI . productTypeFrom) row + mRow <- fetchFeatureRow @row @mrow tid cols + pure $ foldMap rowToFeature mRow + +fetchFeatureRow :: + forall row mrow m. + ( MonadClient m, + IsProductType (TupleP mrow) mrow, + AllZip (IsF Maybe) row mrow, + Tuple (TupleP mrow) + ) => + TeamId -> + NP (K String) row -> + m (Maybe (NP Maybe row)) +fetchFeatureRow tid cols = do + let select :: PrepQuery R (Identity TeamId) (TupleP mrow) + select = + fromString $ + "select " + <> intercalate ", " (hcollapse cols) + <> " from team_features where team_id = ?" + row <- retry x1 $ query1 select (params LocalQuorum (Identity tid)) + pure $ fmap (unfactorI . productTypeFrom) row storeFeature :: forall cfg m row mrow. From e269b7e0134901ddff21e10268f61ba7e1c328c3 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 9 Aug 2024 14:04:54 +0200 Subject: [PATCH 34/34] Fix conference calling flag assertions --- integration/test/Test/FeatureFlags.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/integration/test/Test/FeatureFlags.hs b/integration/test/Test/FeatureFlags.hs index a0d274b9a2e..4b285e6bef2 100644 --- a/integration/test/Test/FeatureFlags.hs +++ b/integration/test/Test/FeatureFlags.hs @@ -811,8 +811,7 @@ testConferenceCallingInternal = do do notif <- awaitMatch isFeatureConfigUpdateNotif ws notif %. "payload.0.name" `shouldMatch` "conferenceCalling" - -- TODO: the patch event is currently wrong, and does not reflect the update - notif %. "payload.0.data" `shouldMatch` (confCalling defaultArgs {status = "disabled", lockStatus = Just "locked"}) + notif %. "payload.0.data" `shouldMatch` (confCalling defaultArgs {status = "enabled", lockStatus = Just "unlocked"}) checkFeature "conferenceCalling" m tid (confCalling defaultArgs {status = "enabled", lockStatus = Just "unlocked"}) -- just disable @@ -836,7 +835,7 @@ testConferenceCallingInternal = do do notif <- awaitMatch isFeatureConfigUpdateNotif ws notif %. "payload.0.name" `shouldMatch` "conferenceCalling" - notif %. "payload.0.data" `shouldMatch` (confCalling defaultArgs {lockStatus = Just "unlocked"}) + notif %. "payload.0.data" `shouldMatch` (confCalling defaultArgs) checkFeature "conferenceCalling" m tid (confCalling defaultArgs) _testLockStatusWithConfig ::