Feature flag refactoring (part 2)

changelog.d/5-internal/feature-flag-refactoring-2

@@ -0,0 +1 @@
+Clean up and reorganise feature flag endpoints

libs/galley-types/default.nix

@@ -17,7 +17,6 @@
 , lib
 , memory
 , QuickCheck
-, schema-profunctor
 , text
 , types-common
 , utf8-string
@@ -41,7 +40,6 @@ mkDerivation {
     lens
     memory
     QuickCheck
-    schema-profunctor
     text
     types-common
     utf8-string

libs/galley-types/galley-types.cabal

@@ -81,7 +81,6 @@ library
     , lens                   >=4.12
     , memory
     , QuickCheck
-    , schema-profunctor
     , text                   >=0.11
     , types-common           >=0.16
     , utf8-string

libs/galley-types/src/Galley/Types/Teams.hs

@@ -66,7 +66,6 @@ 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
 import Imports
 import Test.QuickCheck (Arbitrary)
@@ -153,7 +152,7 @@ instance FromJSON FeatureFlags where
       <*> (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 :: forall cfg. (IsFeatureConfig cfg) => Object -> Key -> A.Parser (Defaults (ImplicitLockStatus cfg))
       withImplicitLockStatusOrDefault obj fieldName = fromMaybe (Defaults (ImplicitLockStatus def)) <$> obj .:? fieldName
 
 instance FromJSON FeatureSSO where

libs/wire-api/src/Wire/API/Error.hs

@@ -164,7 +164,7 @@ instance (KnownError e) => ToSchema (SStaticError e) where
 
 data CanThrow e
 
-data CanThrowMany e
+data CanThrowMany (es :: [k])
 
 instance (RoutesToPaths api) => RoutesToPaths (CanThrow err :> api) where
   getRoutes = getRoutes @api
@@ -203,18 +203,18 @@ type instance
   SpecialiseToVersion v (CanThrowMany es :> api) =
     CanThrowMany es :> SpecialiseToVersion v api
 
-instance (HasOpenApi api) => HasOpenApi (CanThrowMany '() :> api) where
+instance (HasOpenApi api) => HasOpenApi (CanThrowMany '[] :> api) where
   toOpenApi _ = toOpenApi (Proxy @api)
 
 instance
   (HasOpenApi (CanThrowMany es :> api), IsSwaggerError e) =>
-  HasOpenApi (CanThrowMany '(e, es) :> api)
+  HasOpenApi (CanThrowMany (e : es) :> api)
   where
   toOpenApi _ = addToOpenApi @e (toOpenApi (Proxy @(CanThrowMany es :> api)))
 
 type family DeclaredErrorEffects api :: EffectRow where
   DeclaredErrorEffects (CanThrow e :> api) = (ErrorEffect e ': DeclaredErrorEffects api)
-  DeclaredErrorEffects (CanThrowMany '(e, es) :> api) =
+  DeclaredErrorEffects (CanThrowMany (e : es) :> api) =
     DeclaredErrorEffects (CanThrow e :> CanThrowMany es :> api)
   DeclaredErrorEffects (x :> api) = DeclaredErrorEffects api
   DeclaredErrorEffects (Named n api) = DeclaredErrorEffects api

libs/wire-api/src/Wire/API/Event/FeatureConfig.hs

@@ -28,7 +28,6 @@ import Data.Aeson.KeyMap qualified as KeyMap
 import Data.Json.Util (ToJSONObject (toJSONObject))
 import Data.OpenApi qualified as S
 import Data.Schema
-import GHC.TypeLits (KnownSymbol)
 import Imports
 import Test.QuickCheck.Gen
 import Wire.API.Team.Feature
@@ -42,7 +41,7 @@ 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 :: forall cfg. (IsFeatureConfig cfg, Arbitrary cfg) => Gen A.Value
 arbitraryFeature = toJSON <$> arbitrary @(LockableFeature cfg)
 
 class AllArbitraryFeatures cfgs where
@@ -53,7 +52,6 @@ instance AllArbitraryFeatures '[] where
 
 instance
   ( IsFeatureConfig cfg,
-    ToSchema cfg,
     Arbitrary cfg,
     AllArbitraryFeatures cfgs
   ) =>
@@ -99,5 +97,5 @@ instance ToJSONObject Event where
 instance S.ToSchema Event where
   declareNamedSchema = schemaToSwagger
 
-mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => LockableFeature cfg -> Event
+mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg) => LockableFeature cfg -> Event
 mkUpdateEvent ws = Event Update (featureName @cfg) (toJSON ws)

libs/wire-api/src/Wire/API/Routes/Features.hs

@@ -0,0 +1,22 @@
+module Wire.API.Routes.Features where
+
+import Wire.API.Conversation.Role
+import Wire.API.Error.Galley
+import Wire.API.Team.Feature
+
+type family FeatureErrors cfg where
+  FeatureErrors LegalholdConfig =
+    '[ 'ActionDenied 'RemoveConversationMember,
+       'CannotEnableLegalHoldServiceLargeTeam,
+       'LegalHoldNotEnabled,
+       'LegalHoldDisableUnimplemented,
+       'LegalHoldServiceNotRegistered,
+       'UserLegalHoldIllegalOperation,
+       'LegalHoldCouldNotBlockConnections
+     ]
+  FeatureErrors _ = '[]
+
+type family FeatureAPIDesc cfg where
+  FeatureAPIDesc EnforceFileDownloadLocationConfig =
+    "<p><b>Custom feature: only supported on some dedicated on-prem systems.</b></p>"
+  FeatureAPIDesc _ = ""

libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs

@@ -26,7 +26,6 @@ import GHC.TypeLits (AppendSymbol)
 import Imports hiding (head)
 import Servant
 import Servant.OpenApi
-import Wire.API.ApplyMods
 import Wire.API.Bot
 import Wire.API.Bot.Service
 import Wire.API.Conversation
@@ -38,6 +37,7 @@ import Wire.API.Event.Conversation
 import Wire.API.FederationStatus
 import Wire.API.MakesFederatedCall
 import Wire.API.Provider.Service (ServiceRef)
+import Wire.API.Routes.Features
 import Wire.API.Routes.Internal.Brig.EJPD
 import Wire.API.Routes.Internal.Galley.ConversationsIntra
 import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti
@@ -56,128 +56,40 @@ import Wire.API.Team.Member
 import Wire.API.Team.SearchVisibility
 import Wire.API.User.Client
 
-type LegalHoldFeatureStatusChangeErrors =
-  '( 'ActionDenied 'RemoveConversationMember,
-     '( AuthenticationError,
-        '( 'CannotEnableLegalHoldServiceLargeTeam,
-           '( 'LegalHoldNotEnabled,
-              '( 'LegalHoldDisableUnimplemented,
-                 '( 'LegalHoldServiceNotRegistered,
-                    '( 'UserLegalHoldIllegalOperation,
-                       '( 'LegalHoldCouldNotBlockConnections, '())
-                     )
-                  )
-               )
-            )
-         )
-      )
-   )
-
 type LegalHoldFeaturesStatusChangeFederatedCalls =
   '[ MakesFederatedCall 'Galley "on-conversation-updated",
      MakesFederatedCall 'Galley "on-mls-message-sent"
    ]
 
+type family IFeatureAPI1 cfg where
+  -- special case for classified domains, since it cannot be set
+  IFeatureAPI1 ClassifiedDomainsConfig = IFeatureStatusGet ClassifiedDomainsConfig
+  IFeatureAPI1 cfg = IFeatureAPI1Full cfg
+
+type IFeatureAPI1Full cfg =
+  IFeatureStatusGet cfg
+    :<|> IFeatureStatusPut cfg
+    :<|> IFeatureStatusPatch cfg
+
+type family IAllFeaturesAPI cfgs where
+  IAllFeaturesAPI '[cfg] = IFeatureAPI1 cfg
+  IAllFeaturesAPI (cfg : cfgs) = IFeatureAPI1 cfg :<|> IAllFeaturesAPI cfgs
+
 type IFeatureAPI =
-  -- SSOConfig
-  IFeatureStatusGet SSOConfig
-    :<|> IFeatureStatusPut '[] '() SSOConfig
-    :<|> IFeatureStatusPatch '[] '() SSOConfig
-    -- LegalholdConfig
-    :<|> IFeatureStatusGet LegalholdConfig
-    :<|> IFeatureStatusPut
-           LegalHoldFeaturesStatusChangeFederatedCalls
-           LegalHoldFeatureStatusChangeErrors
-           LegalholdConfig
-    :<|> IFeatureStatusPatch
-           LegalHoldFeaturesStatusChangeFederatedCalls
-           LegalHoldFeatureStatusChangeErrors
-           LegalholdConfig
-    -- SearchVisibilityAvailableConfig
-    :<|> IFeatureStatusGet SearchVisibilityAvailableConfig
-    :<|> IFeatureStatusPut '[] '() SearchVisibilityAvailableConfig
-    :<|> IFeatureStatusPatch '[] '() SearchVisibilityAvailableConfig
-    -- ValidateSAMLEmailsConfig
-    :<|> IFeatureStatusGet ValidateSAMLEmailsConfig
-    :<|> IFeatureStatusPut '[] '() ValidateSAMLEmailsConfig
-    :<|> IFeatureStatusPatch '[] '() ValidateSAMLEmailsConfig
-    -- DigitalSignaturesConfig
-    :<|> IFeatureStatusGet DigitalSignaturesConfig
-    :<|> IFeatureStatusPut '[] '() DigitalSignaturesConfig
-    :<|> IFeatureStatusPatch '[] '() DigitalSignaturesConfig
-    -- AppLockConfig
-    :<|> IFeatureStatusGet AppLockConfig
-    :<|> IFeatureStatusPut '[] '() AppLockConfig
-    :<|> IFeatureStatusPatch '[] '() AppLockConfig
-    -- FileSharingConfig
-    :<|> IFeatureStatusGet FileSharingConfig
-    :<|> IFeatureStatusPut '[] '() FileSharingConfig
+  IAllFeaturesAPI Features
+    -- legacy lock status put endpoints
     :<|> IFeatureStatusLockStatusPut FileSharingConfig
-    :<|> IFeatureStatusPatch '[] '() FileSharingConfig
-    -- ConferenceCallingConfig
-    :<|> IFeatureStatusGet ConferenceCallingConfig
-    :<|> IFeatureStatusPut '[] '() ConferenceCallingConfig
     :<|> IFeatureStatusLockStatusPut ConferenceCallingConfig
-    :<|> IFeatureStatusPatch '[] '() ConferenceCallingConfig
-    -- SelfDeletingMessagesConfig
-    :<|> IFeatureStatusGet SelfDeletingMessagesConfig
-    :<|> IFeatureStatusPut '[] '() SelfDeletingMessagesConfig
     :<|> IFeatureStatusLockStatusPut SelfDeletingMessagesConfig
-    :<|> IFeatureStatusPatch '[] '() SelfDeletingMessagesConfig
-    -- GuestLinksConfig
-    :<|> IFeatureStatusGet GuestLinksConfig
-    :<|> IFeatureStatusPut '[] '() GuestLinksConfig
     :<|> IFeatureStatusLockStatusPut GuestLinksConfig
-    :<|> IFeatureStatusPatch '[] '() GuestLinksConfig
-    --  SndFactorPasswordChallengeConfig
-    :<|> IFeatureStatusGet SndFactorPasswordChallengeConfig
-    :<|> IFeatureStatusPut '[] '() SndFactorPasswordChallengeConfig
     :<|> IFeatureStatusLockStatusPut SndFactorPasswordChallengeConfig
-    :<|> IFeatureStatusPatch '[] '() SndFactorPasswordChallengeConfig
-    -- SearchVisibilityInboundConfig
-    :<|> IFeatureStatusGet SearchVisibilityInboundConfig
-    :<|> IFeatureStatusPut '[] '() SearchVisibilityInboundConfig
-    :<|> IFeatureStatusPatch '[] '() SearchVisibilityInboundConfig
-    :<|> IFeatureNoConfigMultiGet SearchVisibilityInboundConfig
-    -- ClassifiedDomainsConfig
-    :<|> IFeatureStatusGet ClassifiedDomainsConfig
-    -- MLSConfig
-    :<|> IFeatureStatusGet MLSConfig
-    :<|> IFeatureStatusPut '[] '() MLSConfig
-    :<|> IFeatureStatusPatch '[] '() MLSConfig
     :<|> IFeatureStatusLockStatusPut MLSConfig
-    -- ExposeInvitationURLsToTeamAdminConfig
-    :<|> IFeatureStatusGet ExposeInvitationURLsToTeamAdminConfig
-    :<|> IFeatureStatusPut '[] '() ExposeInvitationURLsToTeamAdminConfig
-    :<|> IFeatureStatusPatch '[] '() ExposeInvitationURLsToTeamAdminConfig
-    -- SearchVisibilityInboundConfig
-    :<|> IFeatureStatusGet SearchVisibilityInboundConfig
-    :<|> IFeatureStatusPut '[] '() SearchVisibilityInboundConfig
-    :<|> IFeatureStatusPatch '[] '() SearchVisibilityInboundConfig
-    -- OutlookCalIntegrationConfig
-    :<|> IFeatureStatusGet OutlookCalIntegrationConfig
-    :<|> IFeatureStatusPut '[] '() OutlookCalIntegrationConfig
-    :<|> IFeatureStatusPatch '[] '() OutlookCalIntegrationConfig
     :<|> IFeatureStatusLockStatusPut OutlookCalIntegrationConfig
-    -- MlsE2EIdConfig
-    :<|> IFeatureStatusGet MlsE2EIdConfig
-    :<|> IFeatureStatusPut '[] '() MlsE2EIdConfig
-    :<|> IFeatureStatusPatch '[] '() MlsE2EIdConfig
     :<|> IFeatureStatusLockStatusPut MlsE2EIdConfig
-    -- MlsMigrationConfig
-    :<|> IFeatureStatusGet MlsMigrationConfig
-    :<|> IFeatureStatusPut '[] '() MlsMigrationConfig
-    :<|> IFeatureStatusPatch '[] '() MlsMigrationConfig
     :<|> IFeatureStatusLockStatusPut MlsMigrationConfig
-    -- EnforceFileDownloadLocationConfig
-    :<|> IFeatureStatusGetWithDesc EnforceFileDownloadLocationConfig "<p><b>Custom feature: only supported for some decidated on-prem systems.</b></p>"
-    :<|> IFeatureStatusPutWithDesc '[] '() EnforceFileDownloadLocationConfig "<p><b>Custom feature: only supported for some decidated on-prem systems.</b></p>"
-    :<|> IFeatureStatusPatchWithDesc '[] '() EnforceFileDownloadLocationConfig "<p><b>Custom feature: only supported for some decidated on-prem systems.</b></p>"
-    :<|> IFeatureStatusLockStatusPutWithDesc EnforceFileDownloadLocationConfig "<p><b>Custom feature: only supported for some decidated on-prem systems.</b></p>"
-    -- LimitedEventFanoutConfig
-    :<|> IFeatureStatusGet LimitedEventFanoutConfig
-    :<|> IFeatureStatusPut '[] '() LimitedEventFanoutConfig
-    :<|> IFeatureStatusPatch '[] '() LimitedEventFanoutConfig
+    :<|> IFeatureStatusLockStatusPut EnforceFileDownloadLocationConfig
+    -- special endpoints
+    :<|> IFeatureNoConfigMultiGet SearchVisibilityInboundConfig
     -- all feature configs
     :<|> Named
            "feature-configs-internal"
@@ -393,62 +305,67 @@ type ITeamsAPIBase =
                     )
          )
 
-type IFeatureStatusGet f = IFeatureStatusGetWithDesc f ""
-
-type IFeatureStatusGetWithDesc f desc = Named '("iget", f) (Description desc :> FeatureStatusBaseGet f)
-
-type IFeatureStatusPut calls errs f = IFeatureStatusPutWithDesc calls errs f ""
-
-type IFeatureStatusPutWithDesc calls errs f desc = Named '("iput", f) (ApplyMods calls (Description desc :> FeatureStatusBasePutInternal errs f))
+type IFeatureStatusGet cfg =
+  Named
+    '("iget", cfg)
+    ( Description (FeatureAPIDesc cfg)
+        :> FeatureStatusBaseGet cfg
+    )
 
-type IFeatureStatusPatch calls errs f = IFeatureStatusPatchWithDesc calls errs f ""
+type IFeatureStatusPut cfg =
+  Named
+    '("iput", cfg)
+    ( Description (FeatureAPIDesc cfg)
+        :> FeatureStatusBasePutInternal cfg
+    )
 
-type IFeatureStatusPatchWithDesc calls errs f desc = Named '("ipatch", f) (ApplyMods calls (Description desc :> FeatureStatusBasePatchInternal errs f))
+type IFeatureStatusPatch cfg =
+  Named
+    '("ipatch", cfg)
+    ( Description (FeatureAPIDesc cfg)
+        :> FeatureStatusBasePatchInternal cfg
+    )
 
-type FeatureStatusBasePutInternal errs featureConfig =
+type FeatureStatusBasePutInternal cfg =
   FeatureStatusBaseInternal
-    (AppendSymbol "Put config for " (FeatureSymbol featureConfig))
-    errs
-    featureConfig
-    ( ReqBody '[JSON] (Feature featureConfig)
-        :> Put '[JSON] (LockableFeature featureConfig)
+    (AppendSymbol "Put config for " (FeatureSymbol cfg))
+    cfg
+    ( ReqBody '[JSON] (Feature cfg)
+        :> Put '[JSON] (LockableFeature cfg)
     )
 
-type FeatureStatusBasePatchInternal errs featureConfig =
+type FeatureStatusBasePatchInternal cfg =
   FeatureStatusBaseInternal
-    (AppendSymbol "Patch config for " (FeatureSymbol featureConfig))
-    errs
-    featureConfig
-    ( ReqBody '[JSON] (LockableFeaturePatch featureConfig)
-        :> Patch '[JSON] (LockableFeature featureConfig)
+    (AppendSymbol "Patch config for " (FeatureSymbol cfg))
+    cfg
+    ( ReqBody '[JSON] (LockableFeaturePatch cfg)
+        :> Patch '[JSON] (LockableFeature cfg)
     )
 
-type FeatureStatusBaseInternal desc errs featureConfig a =
+type FeatureStatusBaseInternal desc cfg a =
   Summary desc
     :> CanThrow OperationDenied
     :> CanThrow 'NotATeamMember
     :> CanThrow 'TeamNotFound
     :> CanThrow TeamFeatureError
-    :> CanThrowMany errs
+    :> CanThrowMany (FeatureErrors cfg)
     :> "teams"
     :> Capture "tid" TeamId
     :> "features"
-    :> FeatureSymbol featureConfig
+    :> FeatureSymbol cfg
     :> a
 
-type IFeatureStatusLockStatusPut featureName = IFeatureStatusLockStatusPutWithDesc featureName ""
-
-type IFeatureStatusLockStatusPutWithDesc featureName desc =
+type IFeatureStatusLockStatusPut cfg =
   Named
-    '("ilock", featureName)
-    ( Summary (AppendSymbol "(Un-)lock " (FeatureSymbol featureName))
-        :> Description desc
+    '("ilock", cfg)
+    ( Summary (AppendSymbol "(Un-)lock " (FeatureSymbol cfg))
+        :> Description (FeatureAPIDesc cfg)
         :> CanThrow 'NotATeamMember
         :> CanThrow 'TeamNotFound
         :> "teams"
         :> Capture "tid" TeamId
         :> "features"
-        :> FeatureSymbol featureName
+        :> FeatureSymbol cfg
         :> Capture "lockStatus" LockStatus
         :> Put '[JSON] LockStatusResponse
     )