Simplify Feature Configuration

changelog.d/5-internal/pr-2435

@@ -0,0 +1 @@
+Refactored and simplified the feature config API

libs/brig-types/src/Brig/Types/Search.hs

@@ -39,7 +39,7 @@ import Data.Id (TeamId)
 import Data.Text.Encoding
 import Imports
 import Test.QuickCheck
-import Wire.API.Team.Feature (TeamFeatureStatusValue (TeamFeatureDisabled, TeamFeatureEnabled))
+import Wire.API.Team.Feature
 import Wire.API.User.Search
 
 -- | Outbound search restrictions configured by team admin of the searcher. This
@@ -85,9 +85,9 @@ instance FromByteString SearchVisibilityInbound where
 defaultSearchVisibilityInbound :: SearchVisibilityInbound
 defaultSearchVisibilityInbound = SearchableByOwnTeam
 
-searchVisibilityInboundFromFeatureStatus :: TeamFeatureStatusValue -> SearchVisibilityInbound
-searchVisibilityInboundFromFeatureStatus TeamFeatureDisabled = SearchableByOwnTeam
-searchVisibilityInboundFromFeatureStatus TeamFeatureEnabled = SearchableByAllTeams
+searchVisibilityInboundFromFeatureStatus :: FeatureStatus -> SearchVisibilityInbound
+searchVisibilityInboundFromFeatureStatus FeatureStatusDisabled = SearchableByOwnTeam
+searchVisibilityInboundFromFeatureStatus FeatureStatusEnabled = SearchableByAllTeams
 
 instance ToJSON SearchVisibilityInbound where
   toJSON = String . decodeUtf8 . toStrict . toLazyByteString . builder

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -38,6 +39,8 @@ module Galley.Types.Teams
     flagTeamFeatureSndFactorPasswordChallengeStatus,
     flagTeamFeatureSearchVisibilityInbound,
     Defaults (..),
+    ImplicitLockStatus (..),
+    unImplicitLockStatus,
     unDefaults,
     FeatureSSO (..),
     FeatureLegalHold (..),
@@ -141,8 +144,10 @@ where
 
 import Control.Lens (makeLenses, view, (^.))
 import Data.Aeson
+import qualified Data.Aeson.Types as A
 import Data.Id (UserId)
 import qualified Data.Maybe as Maybe
+import qualified Data.Schema as Schema
 import qualified Data.Set as Set
 import Data.String.Conversions (cs)
 import Imports
@@ -222,20 +227,20 @@ data FeatureFlags = FeatureFlags
   { _flagSSO :: !FeatureSSO,
     _flagLegalHold :: !FeatureLegalHold,
     _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility,
-    _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)),
-    _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains),
-    _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing)),
-    _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)),
-    _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)),
-    _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)),
-    _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails)),
-    _flagTeamFeatureSndFactorPasswordChallengeStatus :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSndFactorPasswordChallenge)),
-    _flagTeamFeatureSearchVisibilityInbound :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSearchVisibilityInbound))
+    _flagAppLockDefaults :: !(Defaults (ImplicitLockStatus AppLockConfig)),
+    _flagClassifiedDomains :: !(ImplicitLockStatus ClassifiedDomainsConfig),
+    _flagFileSharing :: !(Defaults (WithStatus FileSharingConfig)),
+    _flagConferenceCalling :: !(Defaults (ImplicitLockStatus ConferenceCallingConfig)),
+    _flagSelfDeletingMessages :: !(Defaults (WithStatus SelfDeletingMessagesConfig)),
+    _flagConversationGuestLinks :: !(Defaults (WithStatus GuestLinksConfig)),
+    _flagsTeamFeatureValidateSAMLEmailsStatus :: !(Defaults (ImplicitLockStatus ValidateSAMLEmailsConfig)),
+    _flagTeamFeatureSndFactorPasswordChallengeStatus :: !(Defaults (WithStatus SndFactorPasswordChallengeConfig)),
+    _flagTeamFeatureSearchVisibilityInbound :: !(Defaults (ImplicitLockStatus SearchVisibilityInboundConfig))
   }
   deriving (Eq, Show, Generic)
 
 newtype Defaults a = Defaults {_unDefaults :: a}
-  deriving (Eq, Ord, Show, Enum, Bounded, Generic)
+  deriving (Eq, Ord, Show, Enum, Bounded, Generic, Functor)
   deriving newtype (Arbitrary)
 
 instance FromJSON a => FromJSON (Defaults a) where
@@ -265,22 +270,36 @@ data FeatureTeamSearchVisibility
   | FeatureTeamSearchVisibilityDisabledByDefault
   deriving (Eq, Ord, Show, Enum, Bounded, Generic)
 
+newtype ImplicitLockStatus (cfg :: *) = ImplicitLockStatus {_unImplicitLockStatus :: WithStatus cfg}
+  deriving newtype (Eq, Show, Arbitrary)
+
+instance (IsFeatureConfig a, Schema.ToSchema a) => ToJSON (ImplicitLockStatus a) where
+  toJSON (ImplicitLockStatus a) = toJSON $ forgetLock a
+
+instance (IsFeatureConfig a, Schema.ToSchema a) => FromJSON (ImplicitLockStatus a) where
+  parseJSON v = ImplicitLockStatus . withLockStatus (wsLockStatus $ defFeatureStatus @a) <$> parseJSON v
+
+makeLenses ''ImplicitLockStatus
+
 -- NOTE: This is used only in the config and thus YAML... camelcase
 instance FromJSON FeatureFlags where
   parseJSON = withObject "FeatureFlags" $ \obj ->
     FeatureFlags
       <$> obj .: "sso"
       <*> obj .: "legalhold"
       <*> obj .: "teamSearchVisibility"
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureAppLock)) <$> (obj .:? "appLock"))
-      <*> (fromMaybe (defTeamFeatureStatus @'TeamFeatureClassifiedDomains) <$> (obj .:? "classifiedDomains"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureFileSharing)) <$> (obj .:? "fileSharing"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureConferenceCalling)) <$> (obj .:? "conferenceCalling"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSelfDeletingMessages)) <$> (obj .:? "selfDeletingMessages"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureGuestLinks)) <$> (obj .:? "conversationGuestLinks"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureValidateSAMLEmails)) <$> (obj .:? "validateSAMLEmails"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSndFactorPasswordChallenge)) <$> (obj .:? "sndFactorPasswordChallenge"))
-      <*> (fromMaybe (Defaults (defTeamFeatureStatus @'TeamFeatureSearchVisibilityInbound)) <$> (obj .:? "searchVisibilityInbound"))
+      <*> withImplicitLockStatusOrDefault obj "appLock"
+      <*> (fromMaybe (ImplicitLockStatus (defFeatureStatus @ClassifiedDomainsConfig)) <$> (obj .:? "classifiedDomains"))
+      <*> (fromMaybe (Defaults (defFeatureStatus @FileSharingConfig)) <$> (obj .:? "fileSharing"))
+      <*> withImplicitLockStatusOrDefault obj "conferenceCalling"
+      <*> (fromMaybe (Defaults (defFeatureStatus @SelfDeletingMessagesConfig)) <$> (obj .:? "selfDeletingMessages"))
+      <*> (fromMaybe (Defaults (defFeatureStatus @GuestLinksConfig)) <$> (obj .:? "conversationGuestLinks"))
+      <*> withImplicitLockStatusOrDefault obj "validateSAMLEmails"
+      <*> (fromMaybe (Defaults (defFeatureStatus @SndFactorPasswordChallengeConfig)) <$> (obj .:? "sndFactorPasswordChallenge"))
+      <*> withImplicitLockStatusOrDefault obj "searchVisibilityInbound"
+    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
 
 instance ToJSON FeatureFlags where
   toJSON

libs/galley-types/test/unit/Test/Galley/Types.hs

@@ -31,6 +31,7 @@ import qualified Test.QuickCheck as QC
 import Test.Tasty
 import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
+import Wire.API.Team.Feature as Public
 
 tests :: TestTree
 tests =
@@ -83,12 +84,20 @@ instance Arbitrary FeatureFlags where
       <$> QC.elements [minBound ..]
       <*> QC.elements [minBound ..]
       <*> QC.elements [minBound ..]
+      -- the default lock status is implicitly added on deserialization and ignored on serialization, therefore we need to fix it to the default here
+      -- we will be able to remove this once the lock status is explicitly included in the config
+      <*> fmap (fmap unlocked) arbitrary
+      <*> fmap unlocked arbitrary
       <*> arbitrary
+      <*> fmap (fmap unlocked) arbitrary
       <*> arbitrary
       <*> arbitrary
+      <*> fmap (fmap unlocked) arbitrary
       <*> arbitrary
-      <*> arbitrary
-      <*> arbitrary
-      <*> arbitrary
-      <*> arbitrary
-      <*> arbitrary
+      <*> fmap (fmap unlocked) arbitrary
+    where
+      unlocked :: ImplicitLockStatus a -> ImplicitLockStatus a
+      unlocked = ImplicitLockStatus . setUnlocked . _unImplicitLockStatus
+
+      setUnlocked :: WithStatus a -> WithStatus a
+      setUnlocked ws = ws {wsLockStatus = Public.LockStatusUnlocked}

libs/schema-profunctor/src/Data/Schema.hs

@@ -48,6 +48,7 @@ module Data.Schema
     objectWithDocModifier,
     objectOver,
     jsonObject,
+    jsonValue,
     FieldFunctor,
     field,
     fieldWithDocModifier,
@@ -613,6 +614,10 @@ jsonObject =
   unnamed . object "Object" $
     mkSchema mempty pure (pure . (^.. ifolded . withIndex))
 
+-- | A schema for an arbitrary JSON value.
+jsonValue :: ValueSchema SwaggerDoc A.Value
+jsonValue = mkSchema mempty pure Just
+
 -- | A schema for a null value.
 null_ :: Monoid d => ValueSchemaP d () ()
 null_ = mkSchema mempty i o

libs/wire-api/package.yaml

@@ -89,6 +89,7 @@ library:
   - time >=1.4
   - unordered-containers >=0.2
   - uri-bytestring >=0.2
+  - utf8-string
   - uuid >=1.3
   - vector >= 0.12
   - wire-message-proto-lens

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

@@ -14,31 +14,31 @@
 --
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
-{-# LANGUAGE TemplateHaskell #-}
 
 module Wire.API.Event.FeatureConfig
   ( Event (..),
     EventType (..),
-    EventData (..),
+    mkUpdateEvent,
   )
 where
 
-import Control.Arrow ((&&&))
-import Control.Lens (makePrisms, _1)
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson (toJSON)
+import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KeyMap
-import Data.Json.Util (ToJSONObject (..))
+import Data.Json.Util (ToJSONObject (toJSONObject))
 import Data.Schema
 import qualified Data.Swagger as S
+import GHC.TypeLits (KnownSymbol)
 import Imports
-import Wire.API.Team.Feature (TeamFeatureAppLockConfig, TeamFeatureClassifiedDomainsConfig, TeamFeatureName (..), TeamFeatureSelfDeletingMessagesConfig, TeamFeatureStatusNoConfig, TeamFeatureStatusNoConfigAndLockStatus, TeamFeatureStatusWithConfig)
+import Wire.API.Team.Feature
 
 data Event = Event
   { _eventType :: EventType,
-    _eventFeatureName :: TeamFeatureName,
-    _eventData :: EventData
+    _eventFeatureName :: Text,
+    _eventData :: A.Value
   }
   deriving (Eq, Show, Generic)
+  deriving (A.ToJSON, A.FromJSON) via Schema Event
 
 data EventType = Update
   deriving (Eq, Show)
@@ -50,60 +50,25 @@ instance ToSchema EventType where
         [ element "feature-config.update" Update
         ]
 
-data EventData
-  = EdFeatureWithoutConfigChanged TeamFeatureStatusNoConfig
-  | EdFeatureWithoutConfigAndLockStatusChanged TeamFeatureStatusNoConfigAndLockStatus
-  | EdFeatureApplockChanged (TeamFeatureStatusWithConfig TeamFeatureAppLockConfig)
-  | EdFeatureClassifiedDomainsChanged (TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig)
-  | EdFeatureSelfDeletingMessagesChanged (TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig)
-  deriving (Eq, Show, Generic)
-
-makePrisms ''EventData
-
-taggedEventDataSchema :: ObjectSchema SwaggerDoc (TeamFeatureName, EventData)
-taggedEventDataSchema =
-  bind
-    (fst .= field "name" schema)
-    (snd .= fieldOver _1 "data" edata)
-  where
-    edata = dispatch $ \case
-      TeamFeatureLegalHold -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureSSO -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureSearchVisibility -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureValidateSAMLEmails -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureDigitalSignatures -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureAppLock -> tag _EdFeatureApplockChanged (unnamed schema)
-      TeamFeatureFileSharing -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema)
-      TeamFeatureClassifiedDomains -> tag _EdFeatureClassifiedDomainsChanged (unnamed schema)
-      TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema)
-      TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema)
-      TeamFeatureGuestLinks -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema)
-      TeamFeatureSndFactorPasswordChallenge -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema)
-      TeamFeatureSearchVisibilityInbound -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema)
-
 eventObjectSchema :: ObjectSchema SwaggerDoc Event
 eventObjectSchema =
-  mkEvent
-    <$> (_eventFeatureName &&& _eventData) .= taggedEventDataSchema
-    <*> _eventType .= field "type" schema
-  where
-    mkEvent :: (TeamFeatureName, EventData) -> EventType -> Event
-    mkEvent (feature, eventData) eventType = Event eventType feature eventData
+  Event
+    <$> _eventType .= field "type" schema
+    <*> _eventFeatureName .= field "name" schema
+    <*> _eventData .= field "data" jsonValue
 
 instance ToSchema Event where
-  schema = object "Event" eventObjectSchema
+  schema =
+    object "Event" eventObjectSchema
 
 instance ToJSONObject Event where
   toJSONObject =
     KeyMap.fromList
       . fromMaybe []
       . schemaOut eventObjectSchema
 
-instance FromJSON Event where
-  parseJSON = schemaParseJSON
-
-instance ToJSON Event where
-  toJSON = schemaToJSON
-
 instance S.ToSchema Event where
   declareNamedSchema = schemaToSwagger
+
+mkUpdateEvent :: forall cfg. (IsFeatureConfig cfg, ToSchema cfg, KnownSymbol (FeatureSymbol cfg)) => WithStatus cfg -> Event
+mkUpdateEvent ws = Event Update (featureName @cfg) (toJSON ws)

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

@@ -22,9 +22,9 @@ module Wire.API.Routes.Internal.Brig
     MLSAPI,
     TeamsAPI,
     EJPDRequest,
-    GetAccountFeatureConfig,
-    PutAccountFeatureConfig,
-    DeleteAccountFeatureConfig,
+    GetAccountConferenceCallingConfig,
+    PutAccountConferenceCallingConfig,
+    DeleteAccountConferenceCallingConfig,
     SwaggerDocsAPI,
     swaggerDoc,
     module Wire.API.Routes.Internal.Brig.EJPD,
@@ -41,7 +41,7 @@ import Data.Schema hiding (swaggerDoc)
 import Data.Swagger (HasInfo (info), HasTitle (title), Swagger)
 import qualified Data.Swagger as S
 import Imports hiding (head)
-import Servant hiding (Handler, JSON, addHeader, respond)
+import Servant hiding (Handler, JSON, WithStatus, addHeader, respond)
 import qualified Servant
 import Servant.Swagger (HasSwagger (toSwagger))
 import Servant.Swagger.Internal.Orphans ()
@@ -56,8 +56,7 @@ import Wire.API.Routes.Internal.Brig.EJPD
 import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi
 import Wire.API.Routes.MultiVerb
 import Wire.API.Routes.Named
-import Wire.API.Team.Feature (TeamFeatureName (TeamFeatureSearchVisibilityInbound))
-import qualified Wire.API.Team.Feature as ApiFt
+import Wire.API.Team.Feature
 import Wire.API.User
 
 type EJPDRequest =
@@ -78,26 +77,26 @@ type EJPDRequest =
     :> Servant.ReqBody '[Servant.JSON] EJPDRequestBody
     :> Post '[Servant.JSON] EJPDResponseBody
 
-type GetAccountFeatureConfig =
+type GetAccountConferenceCallingConfig =
   Summary
     "Read cassandra field 'brig.user.feature_conference_calling'"
     :> "users"
     :> Capture "uid" UserId
     :> "features"
     :> "conferenceCalling"
-    :> Get '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling)
+    :> Get '[Servant.JSON] (WithStatusNoLock ConferenceCallingConfig)
 
-type PutAccountFeatureConfig =
+type PutAccountConferenceCallingConfig =
   Summary
     "Write to cassandra field 'brig.user.feature_conference_calling'"
     :> "users"
     :> Capture "uid" UserId
     :> "features"
     :> "conferenceCalling"
-    :> Servant.ReqBody '[Servant.JSON] (ApiFt.TeamFeatureStatus 'ApiFt.WithoutLockStatus 'ApiFt.TeamFeatureConferenceCalling)
+    :> Servant.ReqBody '[Servant.JSON] (WithStatusNoLock ConferenceCallingConfig)
     :> Put '[Servant.JSON] NoContent
 
-type DeleteAccountFeatureConfig =
+type DeleteAccountConferenceCallingConfig =
   Summary
     "Reset cassandra field 'brig.user.feature_conference_calling' to 'null'"
     :> "users"
@@ -130,9 +129,9 @@ type GetAllConnections =
 
 type EJPD_API =
   ( EJPDRequest
-      :<|> Named "get-account-feature-config" GetAccountFeatureConfig
-      :<|> PutAccountFeatureConfig
-      :<|> DeleteAccountFeatureConfig
+      :<|> Named "get-account-conference-calling-config" GetAccountConferenceCallingConfig
+      :<|> PutAccountConferenceCallingConfig
+      :<|> DeleteAccountConferenceCallingConfig
       :<|> GetAllConnectionsUnqualified
       :<|> GetAllConnections
   )
@@ -260,7 +259,7 @@ type TeamsAPI =
   Named
     "updateSearchVisibilityInbound"
     ( "teams"
-        :> ReqBody '[Servant.JSON] (Multi.TeamStatusUpdate 'TeamFeatureSearchVisibilityInbound)
+        :> ReqBody '[Servant.JSON] (Multi.TeamStatus SearchVisibilityInboundConfig)
         :> Post '[Servant.JSON] ()
     )