WPB-22959 Refactor TeamFeatureStore

changelog.d/5-internal/WPB-22959

@@ -1 +1,3 @@
-Generalized the migration lock for better reuse
+- Generalized the migration lock for better reuse
+- Move logic from `TeamFeatureStore` interpreter to `FeatureConfigSubsystem` 
+(#4982, #4983)

libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem.hs

@@ -23,26 +23,15 @@ import Data.Id (TeamId, UserId)
 import Data.Qualified (Local)
 import Imports
 import Polysemy
-import Wire.API.Team.Feature (AllTeamFeatures, LockableFeature)
+import Wire.API.Team.Feature (AllTeamFeatures, DbFeature, LockableFeature)
 import Wire.FeaturesConfigSubsystem.Types
 
 data FeaturesConfigSubsystem m a where
-  GetFeature ::
-    forall cfg m.
-    (GetFeatureConfig cfg) =>
-    UserId -> TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
-  GetFeatureForTeam ::
-    forall cfg m.
-    (GetFeatureConfig cfg) =>
-    TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
-  GetFeatureForServer ::
-    forall cfg m.
-    (GetFeatureConfig cfg) =>
-    FeaturesConfigSubsystem m (LockableFeature cfg)
-  GetFeatureForTeamUser ::
-    forall cfg m.
-    (GetFeatureConfig cfg) =>
-    UserId -> Maybe TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
+  GetDbFeatureRawInternal :: forall cfg m. (GetFeatureConfig cfg) => TeamId -> FeaturesConfigSubsystem m (DbFeature cfg)
+  GetFeature :: forall cfg m. (GetFeatureConfig cfg) => UserId -> TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
+  GetFeatureForTeam :: forall cfg m. (GetFeatureConfig cfg) => TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
+  GetFeatureForServer :: forall cfg m. (GetFeatureConfig cfg) => FeaturesConfigSubsystem m (LockableFeature cfg)
+  GetFeatureForTeamUser :: forall cfg m. (GetFeatureConfig cfg) => UserId -> Maybe TeamId -> FeaturesConfigSubsystem m (LockableFeature cfg)
   GetAllTeamFeaturesForTeamMember :: Local UserId -> TeamId -> FeaturesConfigSubsystem m AllTeamFeatures
   GetAllTeamFeaturesForTeam :: TeamId -> FeaturesConfigSubsystem m AllTeamFeatures
   GetAllTeamFeaturesForServer :: FeaturesConfigSubsystem m AllTeamFeatures

libs/wire-subsystems/src/Wire/FeaturesConfigSubsystem/Interpreter.hs

@@ -1,14 +1,19 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# OPTIONS_GHC -Wno-ambiguous-fields #-}
 
 module Wire.FeaturesConfigSubsystem.Interpreter where
 
+import Data.Aeson.Types qualified as A
 import Data.Id
 import Data.Qualified (tUnqualified)
 import Data.SOP
+import Data.Text.Lazy qualified as LT
 import Galley.Types.Teams
 import Imports
 import Polysemy
+import Polysemy.Error
 import Polysemy.Input
 import Wire.API.Error
 import Wire.API.Error.Galley
@@ -20,77 +25,108 @@ import Wire.TeamFeatureStore
 import Wire.TeamSubsystem (TeamSubsystem)
 import Wire.TeamSubsystem qualified as TeamSubsystem
 
+data TeamFeatureStoreError = TeamFeatureStoreErrorInternalError LText
+
 runFeaturesConfigSubsystem ::
   forall r a.
   ( Member TeamFeatureStore r,
     Member TeamSubsystem r,
+    Member (Error TeamFeatureStoreError) r,
     Member (ErrorS 'NotATeamMember) r,
     GetFeatureConfigEffects r
   ) =>
   Sem (FeaturesConfigSubsystem : r) a ->
   Sem r a
 runFeaturesConfigSubsystem = interpret $ \case
+  GetDbFeatureRawInternal tid -> getDbFeatureRawInternalImpl tid
   GetFeature uid tid -> do
     void $ TeamSubsystem.internalGetTeamMember uid tid >>= noteS @'NotATeamMember
-    doGetFeatureForTeam tid
+    getFeatureForTeamImpl tid
   GetFeatureForTeam tid ->
-    doGetFeatureForTeam tid
+    getFeatureForTeamImpl tid
   GetFeatureForServer ->
     resolveServerFeature
   GetFeatureForTeamUser uid mTid ->
-    doGetFeatureForTeamUser uid mTid
+    getFeatureForTeamUserImpl uid mTid
   GetAllTeamFeaturesForTeamMember luid tid -> do
     void $ TeamSubsystem.internalGetTeamMember (tUnqualified luid) tid >>= noteS @'NotATeamMember
-    doGetAllTeamFeatures tid
+    getAllTeamFeaturesImpl tid
   GetAllTeamFeaturesForTeam tid ->
-    doGetAllTeamFeatures tid
+    getAllTeamFeaturesImpl tid
   GetAllTeamFeaturesForServer ->
-    doGetAllTeamFeaturesForServer
+    getAllTeamFeaturesForServerImpl
 
 -- Internal helpers
 
-doGetFeatureForTeam ::
+getFeatureForTeamImpl ::
   forall cfg r.
   ( GetFeatureConfig cfg,
     Member TeamFeatureStore r,
+    Member (Error TeamFeatureStoreError) r,
     GetFeatureConfigEffects r
   ) =>
   TeamId ->
   Sem r (LockableFeature cfg)
-doGetFeatureForTeam tid = do
-  dbFeature <- getDbFeature tid
+getFeatureForTeamImpl tid = do
+  dbFeature <- getDbFeatureRawInternalImpl tid
   defFeature <- resolveServerFeature
   computeFeature tid defFeature dbFeature
 
-doGetFeatureForTeamUser ::
+getFeatureForTeamUserImpl ::
   forall cfg r.
   ( GetFeatureConfig cfg,
     Member TeamFeatureStore r,
+    Member (Error TeamFeatureStoreError) r,
     GetFeatureConfigEffects r
   ) =>
   UserId ->
   Maybe TeamId ->
   Sem r (LockableFeature cfg)
-doGetFeatureForTeamUser uid Nothing = getFeatureForUser uid
-doGetFeatureForTeamUser _uid (Just tid) = doGetFeatureForTeam tid
+getFeatureForTeamUserImpl uid Nothing = getFeatureForUser uid
+getFeatureForTeamUserImpl _uid (Just tid) = getFeatureForTeamImpl tid
 
-doGetAllTeamFeatures ::
+getAllTeamFeaturesImpl ::
   forall r.
   ( Member TeamFeatureStore r,
+    Member (Error TeamFeatureStoreError) r,
     GetFeatureConfigEffects r
   ) =>
   TeamId ->
   Sem r AllTeamFeatures
-doGetAllTeamFeatures tid = do
+getAllTeamFeaturesImpl tid = do
   features <- getAllDbFeatures tid
-  defFeatures <- doGetAllTeamFeaturesForServer
+  defFeatures <- getAllTeamFeaturesForServerImpl
   hsequence' $ hcliftA2 (Proxy @(GetAllFeaturesForServerConstraints r)) compute defFeatures features
   where
-    compute :: forall p. (GetFeatureConfig p) => LockableFeature p -> DbFeature p -> (Sem r :.: LockableFeature) p
-    compute defFeature feat = Comp $ computeFeature tid defFeature feat
+    compute :: forall p. (GetFeatureConfig p) => LockableFeature p -> K (Maybe DbFeaturePatch) p -> (Sem r :.: LockableFeature) p
+    compute defFeature (K mPatch) = Comp $ do
+      dbFeature <- fromMaybe mempty <$> traverse parseDbFeatureOrThrow mPatch
+      computeFeature tid defFeature dbFeature
 
-doGetAllTeamFeaturesForServer :: forall r. (Member (Input FeatureFlags) r) => Sem r AllTeamFeatures
-doGetAllTeamFeaturesForServer =
+getAllTeamFeaturesForServerImpl :: forall r. (Member (Input FeatureFlags) r) => Sem r AllTeamFeatures
+getAllTeamFeaturesForServerImpl =
   hsequence' $
     hcpure (Proxy @GetFeatureConfig) $
       Comp resolveServerFeature
+
+getDbFeatureRawInternalImpl ::
+  forall cfg r.
+  ( IsFeatureConfig cfg,
+    Member (Error TeamFeatureStoreError) r,
+    Member TeamFeatureStore r
+  ) =>
+  TeamId -> Sem r (DbFeature cfg)
+getDbFeatureRawInternalImpl tid =
+  fromMaybe mempty <$> (getDbFeature @cfg tid >>= traverse parseDbFeatureOrThrow)
+
+parseDbFeatureOrThrow ::
+  forall cfg r.
+  ( IsFeatureConfig cfg,
+    Member (Error TeamFeatureStoreError) r
+  ) =>
+  DbFeaturePatch ->
+  Sem r (DbFeature cfg)
+parseDbFeatureOrThrow feat =
+  mapError (TeamFeatureStoreErrorInternalError . LT.pack)
+    . fromEither
+    $ A.parseEither (const (parseDbFeature feat)) ()

libs/wire-subsystems/src/Wire/TeamFeatureStore.hs

@@ -14,19 +14,27 @@
 --
 -- 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 ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Wire.TeamFeatureStore where
 
 import Data.Id
+import Data.SOP (K (..))
+import Imports
 import Polysemy
 import Wire.API.Team.Feature
 
+type DbFeaturePatch = LockableFeaturePatch DbConfig
+
+type AllDbFeaturePatches = AllFeatures (K (Maybe DbFeaturePatch))
+
 data TeamFeatureStore m a where
   -- | Returns all stored feature values excluding lock status.
   GetDbFeature ::
     FeatureSingleton cfg ->
     TeamId ->
-    TeamFeatureStore m (DbFeature cfg)
+    TeamFeatureStore m (Maybe DbFeaturePatch)
   SetDbFeature ::
     FeatureSingleton cfg ->
     TeamId ->
@@ -44,27 +52,30 @@ data TeamFeatureStore m a where
     TeamFeatureStore m ()
   GetAllDbFeatures ::
     TeamId ->
-    TeamFeatureStore m (AllFeatures DbFeature)
+    TeamFeatureStore m AllDbFeaturePatches
 
 getDbFeature ::
+  forall cfg r.
   (Member TeamFeatureStore r, IsFeatureConfig cfg) =>
   TeamId ->
-  Sem r (DbFeature cfg)
-getDbFeature tid = send (GetDbFeature featureSingleton tid)
+  Sem r (Maybe DbFeaturePatch)
+getDbFeature tid = send (GetDbFeature (featureSingleton @cfg) tid)
 
 setDbFeature ::
+  forall cfg r.
   (Member TeamFeatureStore r, IsFeatureConfig cfg) =>
   TeamId ->
   LockableFeature cfg ->
   Sem r ()
-setDbFeature tid feat = send (SetDbFeature featureSingleton tid feat)
+setDbFeature tid feat = send (SetDbFeature (featureSingleton @cfg) tid feat)
 
 patchDbFeature ::
+  forall cfg r.
   (Member TeamFeatureStore r, IsFeatureConfig cfg) =>
   TeamId ->
   (LockableFeaturePatch cfg) ->
   Sem r ()
-patchDbFeature tid featPatch = send (PatchDbFeature featureSingleton tid featPatch)
+patchDbFeature tid featPatch = send (PatchDbFeature (featureSingleton @cfg) tid featPatch)
 
 setFeatureLockStatus ::
   forall cfg r.
@@ -75,5 +86,5 @@ setFeatureLockStatus ::
 setFeatureLockStatus tid lockStatus =
   send (SetFeatureLockStatus (featureSingleton @cfg) tid lockStatus)
 
-getAllDbFeatures :: (Member TeamFeatureStore r) => TeamId -> Sem r (AllFeatures DbFeature)
+getAllDbFeatures :: (Member TeamFeatureStore r) => TeamId -> Sem r AllDbFeaturePatches
 getAllDbFeatures tid = send (GetAllDbFeatures tid)