improve - server app monad type & metadata storage class description

Author: rakeshkky

server/src-exec/Main.hs

@@ -65,7 +65,7 @@ runApp env (HGEOptionsG rci hgeCmd) =
         Signals.sigTERM
         (Signals.CatchOnce (shutdownGracefully initCtx))
         Nothing
-      flip runReaderT (_icPgPool initCtx) $ unServerAppM $
+      flip runPGMetadataStorageApp (_icPgPool initCtx) $
         runHGEServer env serveOptions initCtx Nothing initTime shutdownApp Nothing ekgStore
 
     HCExport -> do

server/src-lib/Hasura/App.hs

@@ -176,13 +176,14 @@ data Loggers
   , _lsPgLogger  :: !Q.PGLogger
   }
 
-newtype ServerAppM a = ServerAppM { unServerAppM :: ReaderT Q.PGPool IO a }
+-- | An application with Postgres database as a metadata storage
+newtype PGMetadataStorageApp a
+  = PGMetadataStorageApp {runPGMetadataStorageApp :: Q.PGPool -> IO a}
   deriving ( Functor, Applicative, Monad
            , MonadIO, MonadBase IO, MonadBaseControl IO
            , MonadCatch, MonadThrow, MonadMask
-           , MonadReader Q.PGPool
-           , MonadUnique
-           )
+           , MonadUnique, MonadReader Q.PGPool
+           ) via (ReaderT Q.PGPool IO)
 
 -- | this function initializes the catalog and returns an @InitCtx@, based on the command given
 -- - for serve command it creates a proper PG connection pool
@@ -629,12 +630,12 @@ execQuery env queryBs = do
   buildSchemaCacheStrict
   encJToLBS <$> runQueryM env query
 
-instance Tracing.HasReporter ServerAppM
+instance Tracing.HasReporter PGMetadataStorageApp
 
-instance MonadQueryInstrumentation ServerAppM where
+instance MonadQueryInstrumentation PGMetadataStorageApp where
   askInstrumentQuery _ = pure (id, noProfile)
 
-instance HttpLog ServerAppM where
+instance HttpLog PGMetadataStorageApp where
   logHttpError logger userInfoM reqId waiReq req qErr headers =
     unLogger logger $ mkHttpLog $
       mkHttpErrorLogContext userInfoM reqId waiReq req qErr Nothing Nothing headers
@@ -643,57 +644,58 @@ instance HttpLog ServerAppM where
     unLogger logger $ mkHttpLog $
       mkHttpAccessLogContext userInfoM reqId waiReq compressedResponse qTime cType headers
 
-instance MonadExecuteQuery ServerAppM where
+instance MonadExecuteQuery PGMetadataStorageApp where
   cacheLookup _ _ = pure ([], Nothing)
   cacheStore  _ _ = pure ()
 
-instance UserAuthentication (Tracing.TraceT ServerAppM) where
+instance UserAuthentication (Tracing.TraceT PGMetadataStorageApp) where
   resolveUserInfo logger manager headers authMode =
     runExceptT $ getUserInfoWithExpTime logger manager headers authMode
 
-instance MetadataApiAuthorization ServerAppM where
+instance MetadataApiAuthorization PGMetadataStorageApp where
   authorizeMetadataApi query userInfo = do
     let currRole = _uiRole userInfo
     when (requiresAdmin query && currRole /= adminRoleName) $
       withPathK "args" $ throw400 AccessDenied errMsg
     where
       errMsg = "restricted access : admin only"
 
-instance ConsoleRenderer ServerAppM where
+instance ConsoleRenderer PGMetadataStorageApp where
   renderConsole path authMode enableTelemetry consoleAssetsDir =
     return $ mkConsoleHTML path authMode enableTelemetry consoleAssetsDir
 
-instance MonadGQLExecutionCheck ServerAppM where
+instance MonadGQLExecutionCheck PGMetadataStorageApp where
   checkGQLExecution userInfo _ enableAL sc query = runExceptT $ do
     req <- toParsed query
     checkQueryInAllowlist enableAL userInfo req sc
     return req
 
-instance MonadConfigApiHandler ServerAppM where
+instance MonadConfigApiHandler PGMetadataStorageApp where
   runConfigApiHandler = configApiGetHandler
 
-instance MonadQueryLog ServerAppM where
+instance MonadQueryLog PGMetadataStorageApp where
   logQueryLog logger query genSqlM reqId =
     unLogger logger $ QueryLog query genSqlM reqId
 
-instance WS.MonadWSLog ServerAppM where
+instance WS.MonadWSLog PGMetadataStorageApp where
   logWSLog = unLogger
 
-runTxInMetadataStorage :: Q.TxE QErr a -> MetadataStorageT ServerAppM a
-runTxInMetadataStorage tx = do
-  pool <- lift ask
-  liftEitherM $ liftIO $ runExceptT $
-    Q.runTx pool (Q.RepeatableRead, Just Q.ReadWrite) tx
-
-instance MonadMetadataStorage (MetadataStorageT ServerAppM) where
-
-  getDeprivedCronTriggerStats        = runTxInMetadataStorage getDeprivedCronTriggerStatsTx
-  getScheduledEventsForDelivery      = runTxInMetadataStorage getScheduledEventsForDeliveryTx
-  insertScheduledEvent               = runTxInMetadataStorage . insertScheduledEventTx
-  insertScheduledEventInvocation a b = runTxInMetadataStorage $ insertInvocationTx a b
-  setScheduledEventOp a b c          = runTxInMetadataStorage $ setScheduledEventOpTx a b c
-  unlockScheduledEvents a b          = runTxInMetadataStorage $ unlockScheduledEventsTx a b
-  unlockAllLockedScheduledEvents     = runTxInMetadataStorage unlockAllLockedScheduledEventsTx
+instance MonadTx (MetadataStorageT PGMetadataStorageApp) where
+  liftTx tx = do
+    pool <- lift ask
+    -- Each operation in metadata storage is executed in an isolated transaction.
+    -- No two operations are not necessarily executed together.
+    liftEitherM $ liftIO $ runExceptT $ Q.runTx pool (Q.RepeatableRead, Nothing) tx
+
+instance MonadMetadataStorage (MetadataStorageT PGMetadataStorageApp) where
+
+  getDeprivedCronTriggerStats        = liftTx getDeprivedCronTriggerStatsTx
+  getScheduledEventsForDelivery      = liftTx getScheduledEventsForDeliveryTx
+  insertScheduledEvent               = liftTx . insertScheduledEventTx
+  insertScheduledEventInvocation a b = liftTx $ insertInvocationTx a b
+  setScheduledEventOp a b c          = liftTx $ setScheduledEventOpTx a b c
+  unlockScheduledEvents a b          = liftTx $ unlockScheduledEventsTx a b
+  unlockAllLockedScheduledEvents     = liftTx unlockAllLockedScheduledEventsTx
 
 --- helper functions ---
 

server/src-lib/Hasura/Eventing/ScheduledTrigger.hs

@@ -139,10 +139,8 @@ runCronEventsGenerator logger getSC = do
         mapM (withCronTrigger cronTriggersCache) deprivedCronTriggerStats
       insertCronEventsFor cronTriggersForHydrationWithStats
 
-    case eitherRes of
-      Right _ -> pure ()
-      Left err -> L.unLogger logger $
-        ScheduledTriggerInternalErr $ err500 Unexpected (T.pack $ show err)
+    onLeft eitherRes $ L.unLogger logger .
+      ScheduledTriggerInternalErr . err500 Unexpected . T.pack . show
 
     liftIO $ sleep (minutes 1)
     where

server/src-lib/Hasura/Metadata/Class.hs

@@ -1,4 +1,5 @@
 -- | This module has type class and types which implements the Metadata Storage Abstraction
+{-# LANGUAGE UndecidableInstances #-}
 module Hasura.Metadata.Class
   ( MetadataStorageT(..)
   , runMetadataStorageT
@@ -15,6 +16,7 @@ import           Hasura.RQL.Types
 
 import qualified Hasura.Tracing                         as Tracing
 
+-- | Metadata storage transformer that enables raising @'QErr' exceptions.
 newtype MetadataStorageT m a
   = MetadataStorageT {unMetadataStorageT :: ExceptT QErr m a}
   deriving ( Functor, Applicative, Monad
@@ -32,38 +34,49 @@ runMetadataStorageT =
 
 {- Note [Todo: Common interface for eventing sub-system]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Scheduled and Table event triggers have their own implementation
-and tables in Postgres. The core logic for both is same. So it
-is necessary to have a unified interface (maybe via a Postgres extension)
-where all event triggers implementation can extend from. By this we can
-fairly reduce the Postgres schema foot print and interactions to the database.
+Postgres tables' event triggers and scheduled event triggers are similar in the
+core logic. But currently, their implementation is completely isolated and do not share
+a common schema in Postgres. We're having a plan to simplify them via a common interface
+(maybe via a Postgres extension). This will potentially reduce number of interactions made
+to database and schema foot print.
 
 TODO: Reference to open issue or rfc?
 -}
 
 -- | Metadata storage abstraction via a type class.
 --
+-- This type class enables storing and managing Hasura metadata in an isolated
+-- database which will not interfere with user's database where tables/functions
+-- are defined. Hence, it'll enable support for databases of multiple backends
+-- like MySQL, MSSQL etc.
+--
 -- This class has functions broadly related to:
 --
--- 1. Metadata Management (TODO)
--- ---------------------
+-- 1. Metadata Management
+-- ----------------------
+-- TODO
 -- Basic metadata management functions such as retrieving metadata from storage
 -- database and replacing the given metadata.
 --
 -- 2. Scheduled Triggers
 -- ---------------------
 -- Eventing sub-system for scheduled triggers is implemented via metadata storage.
 -- All necessary functions are included in the type class.
--- (TODO):
+-- TODO
 -- This also includes functions to fetch events and their invocations so that the
 -- console can show them in the UI.
 -- For more details, refer description in 'Hasura.Eventing.ScheduledTrigger' module.
 --
--- 3. Async Actions (TODO)
+-- 3. Async Actions
 -- ----------------
+-- TODO
 -- Operations to implement async actions sub-system. This includes recording an
 -- async action event and retreiving the details of action delivery to the webhook.
 -- For more details see Note [Async action architecture] in 'Hasura.GraphQL.Execute.Action' module.
+--
+-- It is believed that all the above three are implemented in a single storage
+-- system (ex: a Postgres database). We can split the functions into appropriate and
+-- specific type classes in future iterations if required.
 
 class (MonadError QErr m) => MonadMetadataStorage m where
 

server/src-lib/Hasura/RQL/Types/ScheduledTrigger.hs

@@ -17,18 +17,14 @@ module Hasura.RQL.Types.ScheduledTrigger
   , scheduledEventStatusToText
   , ScheduledEventType(..)
   , ScheduledEvent(..)
-  , GetInvocationsBy(..)
-  , ScheduledEventPagination(..)
   , ScheduledEventInvocation(..)
-  , GetEventInvocations(..)
   , OneOffScheduledEvent(..)
   , CronEvent(..)
   ) where
 
 import           Data.Aeson
 import           Data.Aeson.Casing
 import           Data.Aeson.TH
-import           Data.Aeson.Types
 import           Data.Time.Clock
 import           Data.Time.Clock.Units
 import           Data.Time.Format.ISO8601
@@ -222,61 +218,6 @@ data ScheduledEvent
   | SECron !TriggerName
   deriving (Show, Eq)
 
-parseScheduledEvent :: Object -> Parser ScheduledEvent
-parseScheduledEvent o = do
-  ty <- o .: "type"
-  case ty of
-    Cron   -> SECron <$> o .: "trigger_name"
-    OneOff -> pure SEOneOff
-
-scheduledEventToPairs :: ScheduledEvent -> [Pair]
-scheduledEventToPairs = \case
-  SEOneOff    -> ["type" .= OneOff]
-  SECron name -> ["type" .= Cron, "trigger_name" .= name]
-
-data ScheduledEventPagination
-  = ScheduledEventPagination
-  { _sepLimit  :: !(Maybe Int)
-  , _sepOffset :: !(Maybe Int)
-  } deriving (Show, Eq)
-
-parseScheduledEventPagination :: Object -> Parser ScheduledEventPagination
-parseScheduledEventPagination o =
-  ScheduledEventPagination
-    <$> o .:? "limit"
-    <*> o .:? "offset"
-
-scheduledEventPaginationToPairs :: ScheduledEventPagination -> [Pair]
-scheduledEventPaginationToPairs ScheduledEventPagination{..} =
-  ["limit" .= _sepLimit, "offset" .= _sepOffset]
-
-data GetInvocationsBy
-  = GIBEventId !EventId !ScheduledEventType
-  | GIBEvent !ScheduledEvent
-  deriving (Show, Eq)
-
-data GetEventInvocations
-  = GetEventInvocations
-  { _geiInvocationsBy :: !GetInvocationsBy
-  , _geiPagination    :: !ScheduledEventPagination
-  } deriving (Eq, Show)
-
-instance FromJSON GetEventInvocations where
-  parseJSON = withObject "Object" $ \o ->
-    GetEventInvocations
-      <$> (parseEventId o <|> (GIBEvent <$> parseScheduledEvent o))
-      <*> parseScheduledEventPagination o
-    where
-      parseEventId o =
-        GIBEventId <$> o .: "event_id" <*> o .: "type"
-
-instance ToJSON GetEventInvocations where
-  toJSON GetEventInvocations{..} =
-    object $ case _geiInvocationsBy of
-             GIBEventId eventId eventType -> ["event_id" .= eventId, "type" .= eventType]
-             GIBEvent event               -> scheduledEventToPairs event
-          <> scheduledEventPaginationToPairs _geiPagination
-
 data CronEventSeed
   = CronEventSeed
   { cesName          :: !TriggerName