server: refactor Hasura.Metadata.Class

- Remove `MonadMetadataStorageQueryAPI` which was only implemented by a default implementation - Introduce `TransT` which can be used to easily derive `lift`ing implementations for `MonadBlaBlaBla` classes PR-URL: hasura/graphql-engine-mono#8579 GitOrigin-RevId: 4f804fda7e2de5c9d75ee4df269f500ebd46b8c9
hasura · Apr 3, 2023 · 7cc33dd · 7cc33dd
1 parent ed4f3b7
commit 7cc33dd
Show file tree

Hide file tree

Showing 12 changed files with 103 additions and 280 deletions.
diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal
@@ -490,6 +490,7 @@ library
                      , Control.Monad.Circular
                      , Control.Monad.Memoize
                      , Control.Monad.Stateless
+                     , Control.Monad.Trans.Extended
                      , Control.Monad.Trans.Managed
                      , Data.Aeson.Extended
                      , Data.Aeson.Kriti.Functions

diff --git a/server/src-lib/Control/Monad/Trans/Extended.hs b/server/src-lib/Control/Monad/Trans/Extended.hs
@@ -0,0 +1,21 @@
+module Control.Monad.Trans.Extended
+  ( TransT (..),
+  )
+where
+
+import Control.Monad.Morph
+import Data.Kind
+import Prelude
+
+-- | Utility newtype that can be used to derive type class instances just using
+-- `MonadTrans`.
+--
+-- We often derive some `MonadBlaBla` instance for `ReaderT` by using `lift`
+-- from `MonadTrans`.  Which is fine, but it gets laborious if you do the same
+-- for `ExceptT`, `StateT` and `WriterT`, even though the method implementations
+-- are exactly the same.  `TransT` allows you to write one `MonadTrans`-based
+-- instance, which can then be used with `DerivingVia` to use that one
+-- implementation for all monad transformers that use that same lifting
+-- implementation.
+newtype TransT t (m :: Type -> Type) a = TransT (t m a)
+  deriving (Functor, Applicative, Monad, MonadTrans, MFunctor, MMonad)
diff --git a/server/src-lib/Hasura/App.hs b/server/src-lib/Hasura/App.hs
@@ -804,8 +804,6 @@ instance MonadMetadataStorage AppM where
   clearActionData = runInSeparateTx . clearActionDataTx
   setProcessingActionLogsToPending = runInSeparateTx . setProcessingActionLogsToPendingTx
 
-instance MonadMetadataStorageQueryAPI AppM
-
 --------------------------------------------------------------------------------
 -- misc
 
@@ -891,7 +889,7 @@ runHGEServer ::
     WS.MonadWSLog m,
     MonadExecuteQuery m,
     HasResourceLimits m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadQueryTags m,
     MonadEventLogCleanup m,
@@ -983,7 +981,7 @@ mkHGEServer ::
     WS.MonadWSLog m,
     MonadExecuteQuery m,
     HasResourceLimits m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadQueryTags m,
     MonadEventLogCleanup m,

diff --git a/server/src-lib/Hasura/Metadata/Class.hs b/server/src-lib/Hasura/Metadata/Class.hs
diff --git a/server/src-lib/Hasura/RQL/DDL/Action.hs b/server/src-lib/Hasura/RQL/DDL/Action.hs
@@ -261,7 +261,7 @@ runDropAction ::
   ( MonadError QErr m,
     CacheRWM m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   DropAction ->
   m EncJSON

diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs
@@ -122,7 +122,7 @@ runClearMetadata ::
   ( MonadIO m,
     CacheRWM m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadBaseControl IO m,
     MonadReader r m,
     MonadError QErr m,
@@ -195,7 +195,7 @@ runReplaceMetadata ::
     MetadataM m,
     MonadIO m,
     MonadBaseControl IO m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadReader r m,
     MonadError QErr m,
     Has (HL.Logger HL.Hasura) r,
@@ -213,7 +213,7 @@ runReplaceMetadataV1 ::
     MetadataM m,
     MonadIO m,
     MonadBaseControl IO m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadReader r m,
     MonadError QErr m,
     Has (HL.Logger HL.Hasura) r,
@@ -231,7 +231,7 @@ runReplaceMetadataV2 ::
     MetadataM m,
     MonadIO m,
     MonadBaseControl IO m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadReader r m,
     MonadError QErr m,
     Has (HL.Logger HL.Hasura) r,
@@ -255,7 +255,7 @@ runReplaceMetadataV2' ::
     MetadataM m,
     MonadIO m,
     MonadBaseControl IO m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadReader r m,
     MonadError QErr m,
     Has (HL.Logger HL.Hasura) r,
@@ -760,12 +760,12 @@ purgeMetadataObj = \case
                 }
 
 runGetCatalogState ::
-  (MonadMetadataStorageQueryAPI m, MonadError QErr m) => GetCatalogState -> m EncJSON
+  (MonadMetadataStorage m, MonadError QErr m) => GetCatalogState -> m EncJSON
 runGetCatalogState _ =
   encJFromJValue <$> liftEitherM fetchCatalogState
 
 runSetCatalogState ::
-  (MonadMetadataStorageQueryAPI m, MonadError QErr m) => SetCatalogState -> m EncJSON
+  (MonadMetadataStorage m, MonadError QErr m) => SetCatalogState -> m EncJSON
 runSetCatalogState SetCatalogState {..} = do
   liftEitherM $ updateCatalogState _scsType _scsState
   pure successMsg

diff --git a/server/src-lib/Hasura/RQL/DDL/ScheduledTrigger.hs b/server/src-lib/Hasura/RQL/DDL/ScheduledTrigger.hs
@@ -36,7 +36,7 @@ import System.Cron.Types (CronSchedule)
 populateInitialCronTriggerEvents ::
   ( MonadIO m,
     MonadError QErr m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   CronSchedule ->
   TriggerName ->
@@ -54,7 +54,7 @@ runCreateCronTrigger ::
     CacheRWM m,
     MonadIO m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   CreateCronTrigger ->
   m EncJSON
@@ -128,7 +128,7 @@ updateCronTrigger ::
     CacheRWM m,
     MonadIO m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   CronTriggerMetadata ->
   m EncJSON
@@ -148,7 +148,7 @@ runDeleteCronTrigger ::
   ( MonadError QErr m,
     CacheRWM m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   ScheduledTriggerName ->
   m EncJSON
@@ -165,7 +165,7 @@ dropCronTriggerInMetadata name =
   MetadataModifier $ metaCronTriggers %~ OMap.delete name
 
 runCreateScheduledEvent ::
-  (MonadError QErr m, MonadMetadataStorageQueryAPI m) =>
+  (MonadError QErr m, MonadMetadataStorage m) =>
   CreateScheduledEvent ->
   m EncJSON
 runCreateScheduledEvent scheduledEvent = do
@@ -181,15 +181,15 @@ checkExists name = do
         "cron trigger with name: " <> triggerNameToTxt name <> " does not exist"
 
 runDeleteScheduledEvent ::
-  (MonadMetadataStorageQueryAPI m, MonadError QErr m) => DeleteScheduledEvent -> m EncJSON
+  (MonadMetadataStorage m, MonadError QErr m) => DeleteScheduledEvent -> m EncJSON
 runDeleteScheduledEvent DeleteScheduledEvent {..} = do
   liftEitherM $ dropEvent _dseEventId _dseType
   pure successMsg
 
 runGetScheduledEvents ::
   ( MonadError QErr m,
     CacheRM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   GetScheduledEvents ->
   m EncJSON
@@ -202,7 +202,7 @@ runGetScheduledEvents gse = do
 runGetScheduledEventInvocations ::
   ( MonadError QErr m,
     CacheRM m,
-    MonadMetadataStorageQueryAPI m
+    MonadMetadataStorage m
   ) =>
   GetScheduledEventInvocations ->
   m EncJSON

diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
@@ -185,7 +185,6 @@ newtype CacheRWT m a
       MonadError e,
       UserInfoM,
       MonadMetadataStorage,
-      MonadMetadataStorageQueryAPI,
       Tracing.MonadTrace,
       MonadBase b,
       MonadBaseControl b,

diff --git a/server/src-lib/Hasura/Server/API/Metadata.hs b/server/src-lib/Hasura/Server/API/Metadata.hs
@@ -391,7 +391,7 @@ runMetadataQuery ::
     MonadBaseControl IO m,
     HasAppEnv m,
     Tracing.MonadTrace m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadEventLogCleanup m,
     ProvidesHasuraServices m,
@@ -610,7 +610,7 @@ runMetadataQueryM ::
     Tracing.MonadTrace m,
     UserInfoM m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     HasServerConfigCtx m,
     MonadReader r m,
     Has (L.Logger L.Hasura) r,
@@ -642,7 +642,7 @@ runMetadataQueryV1M ::
     Tracing.MonadTrace m,
     UserInfoM m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     HasServerConfigCtx m,
     MonadReader r m,
     Has (L.Logger L.Hasura) r,
@@ -819,7 +819,7 @@ runMetadataQueryV2M ::
     CacheRWM m,
     MonadBaseControl IO m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadReader r m,
     Has (L.Logger L.Hasura) r,
     MonadError QErr m,

diff --git a/server/src-lib/Hasura/Server/API/Query.hs b/server/src-lib/Hasura/Server/API/Query.hs
@@ -182,7 +182,7 @@ runQuery ::
     HasAppEnv m,
     Tracing.MonadTrace m,
     MonadBaseControl IO m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadQueryTags m,
     MonadEventLogCleanup m,
@@ -394,7 +394,7 @@ runQueryM ::
     HasServerConfigCtx m,
     Tracing.MonadTrace m,
     MetadataM m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadQueryTags m,
     MonadReader r m,
     MonadError QErr m,

diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs
@@ -144,7 +144,6 @@ newtype Handler m a = Handler (ReaderT HandlerCtx (ExceptT QErr m) a)
       GH.MonadExecuteQuery,
       MonadMetadataApiAuthorization,
       MonadMetadataStorage,
-      MonadMetadataStorageQueryAPI,
       ProvidesNetwork,
       MonadGetApiTimeLimit
     )
@@ -421,7 +420,7 @@ v1QueryHandler ::
     MonadMetadataApiAuthorization m,
     MonadTrace m,
     MonadReader HandlerCtx m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     HasAppEnv m,
     MonadQueryTags m,
@@ -453,7 +452,7 @@ v1MetadataHandler ::
     MonadBaseControl IO m,
     MonadReader HandlerCtx m,
     MonadTrace m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadMetadataApiAuthorization m,
     MonadEventLogCleanup m,
@@ -724,7 +723,7 @@ mkWaiApp ::
     MonadTrace m,
     GH.MonadExecuteQuery m,
     HasResourceLimits m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadResolveSource m,
     MonadQueryTags m,
     MonadEventLogCleanup m,
@@ -768,7 +767,7 @@ httpApp ::
     MonadExecutionLog m,
     MonadTrace m,
     GH.MonadExecuteQuery m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     HasResourceLimits m,
     MonadResolveSource m,
     MonadQueryTags m,

diff --git a/server/test-postgres/Test/Hasura/Server/MigrateSuite.hs b/server/test-postgres/Test/Hasura/Server/MigrateSuite.hs
@@ -51,7 +51,6 @@ newtype CacheRefT m a = CacheRefT {runCacheRefT :: (ServerConfigCtx, MVar Rebuil
       MonadTx,
       UserInfoM,
       MonadMetadataStorage,
-      MonadMetadataStorageQueryAPI,
       MonadResolveSource,
       ProvidesNetwork,
       MonadGetApiTimeLimit
@@ -112,7 +111,7 @@ suite ::
     MonadError QErr m,
     MonadBaseControl IO m,
     MonadResolveSource m,
-    MonadMetadataStorageQueryAPI m,
+    MonadMetadataStorage m,
     MonadEventLogCleanup m,
     ProvidesNetwork m,
     MonadGetApiTimeLimit m