server: app init cleanup

- remove an unused return value
- untangle database query logic slightly
- rename printErrExit functions, and use them more consistently
- simplify the top-level exception handling

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3900
GitOrigin-RevId: a6727c6f899aed00e6a04bd822727341fd51acc4

server/src-exec/Main.hs

@@ -27,16 +27,13 @@ import System.Metrics qualified as EKG
 import System.Posix.Signals qualified as Signals
 
 main :: IO ()
-main = do
+main =
-  tryExit $ do
+  catch
-    args <- parseArgs
+    do
-    env <- Env.getEnvironment
+      args <- parseArgs
-    runApp env args
+      env <- Env.getEnvironment
-  where
+      runApp env args
-    tryExit io =
+    (\(ExitException _code msg) -> BC.putStrLn msg >> Sys.exitFailure)
-      try io >>= \case
-        Left (ExitException _code msg) -> BC.putStrLn msg >> Sys.exitFailure
-        Right r -> return r
 
 runApp :: Env.Environment -> HGEOptions Hasura -> IO ()
 runApp env (HGEOptionsG rci metadataDbUrl hgeCmd) = do
@@ -89,11 +86,11 @@ runApp env (HGEOptionsG rci metadataDbUrl hgeCmd) = do
           runHGEServer (const $ pure ()) env serveOptions serveCtx initTime Nothing serverMetrics ekgStore
     HCExport -> do
       res <- runTxWithMinimalPool _gcMetadataDbConnInfo fetchMetadataFromCatalog
-      either (printErrJExit MetadataExportError) printJSON res
+      either (throwErrJExit MetadataExportError) printJSON res
     HCClean -> do
       res <- runTxWithMinimalPool _gcMetadataDbConnInfo dropHdbCatalogSchema
       let cleanSuccessMsg = "successfully cleaned graphql-engine related data"
-      either (printErrJExit MetadataCleanError) (const $ liftIO $ putStrLn cleanSuccessMsg) res
+      either (throwErrJExit MetadataCleanError) (const $ liftIO $ putStrLn cleanSuccessMsg) res
     HCDowngrade opts -> do
       let defaultSourceConfig =
             maybeDefaultPgConnInfo <&> \(dbUrlConf, _) ->
@@ -106,7 +103,7 @@ runApp env (HGEOptionsG rci metadataDbUrl hgeCmd) = do
                       Nothing
                in PostgresConnConfiguration pgSourceConnInfo Nothing
       res <- runTxWithMinimalPool _gcMetadataDbConnInfo $ downgradeCatalog defaultSourceConfig opts initTime
-      either (printErrJExit DowngradeProcessError) (liftIO . print) res
+      either (throwErrJExit DowngradeProcessError) (liftIO . print) res
     HCVersion -> liftIO $ putStrLn $ "Hasura GraphQL Engine: " ++ convertText currentVersion
   where
     runTxWithMinimalPool connInfo tx = lowerManagedT $ do

server/src-lib/Hasura/App.hs

@@ -19,8 +19,8 @@ module Hasura.App
     newShutdownLatch,
     notifySchemaCacheSyncTx,
     parseArgs,
-    printErrExit,
+    throwErrExit,
-    printErrJExit,
+    throwErrJExit,
     printJSON,
     printYaml,
     readTlsAllowlist,
@@ -155,11 +155,11 @@ data ExitException = ExitException
 
 instance Exception ExitException
 
-printErrExit :: (MonadIO m) => forall a. ExitCode -> String -> m a
+throwErrExit :: (MonadIO m) => forall a. ExitCode -> String -> m a
-printErrExit reason = liftIO . throwIO . ExitException reason . BC.pack
+throwErrExit reason = liftIO . throwIO . ExitException reason . BC.pack
 
-printErrJExit :: (A.ToJSON a, MonadIO m) => forall b. ExitCode -> a -> m b
+throwErrJExit :: (A.ToJSON a, MonadIO m) => forall b. ExitCode -> a -> m b
-printErrJExit reason = liftIO . throwIO . ExitException reason . BLC.toStrict . A.encode
+throwErrJExit reason = liftIO . throwIO . ExitException reason . BLC.toStrict . A.encode
 
 parseHGECommand :: EnabledLogTypes impl => Parser (RawHGECommand impl)
 parseHGECommand =
@@ -203,7 +203,7 @@ parseArgs = do
   rawHGEOpts <- execParser opts
   env <- getEnvironment
   let eitherOpts = runWithEnv env $ mkHGEOptions rawHGEOpts
-  onLeft eitherOpts $ printErrExit InvalidEnvironmentVariableOptionsError
+  onLeft eitherOpts $ throwErrExit InvalidEnvironmentVariableOptionsError
   where
     opts =
       info
@@ -260,7 +260,7 @@ initGlobalCtx env metadataDbUrl defaultPgConnInfo = do
 
   case (metadataDbUrl, dbUrlConf) of
     (Nothing, Nothing) ->
-      printErrExit
+      throwErrExit
         InvalidDatabaseConnectionParamsError
         "Fatal Error: Either of --metadata-database-url or --database-url option expected"
     -- If no metadata storage specified consider use default database as
@@ -333,7 +333,7 @@ resolvePostgresConnInfo ::
 resolvePostgresConnInfo env dbUrlConf maybeRetries = do
   dbUrlText <-
     runExcept (resolveUrlConf env dbUrlConf) `onLeft` \err ->
-      liftIO (printErrExit InvalidDatabaseConnectionParamsError (BLC.unpack $ A.encode err))
+      liftIO (throwErrJExit InvalidDatabaseConnectionParamsError err)
   pure $ Q.ConnInfo retries $ Q.CDDatabaseURI $ txtToBs dbUrlText
   where
     retries = fromMaybe 1 maybeRetries
@@ -384,7 +384,7 @@ initialiseServeCtx env GlobalCtx {..} so@ServeOptions {..} serverMetrics = do
           soReadOnlyMode
 
   schemaCacheHttpManager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings
-  (rebuildableSchemaCache, _) <-
+  rebuildableSchemaCache <-
     lift . flip onException (flushLogger loggerCtx) $
       migrateCatalogSchema
         env
@@ -444,7 +444,7 @@ migrateCatalogSchema ::
   ServerConfigCtx ->
   SourceResolver ('Postgres 'Vanilla) ->
   SourceResolver ('MSSQL) ->
-  m (RebuildableSchemaCache, UTCTime)
+  m RebuildableSchemaCache
 migrateCatalogSchema
   env
   logger
@@ -454,11 +454,11 @@ migrateCatalogSchema
   serverConfigCtx
   pgSourceResolver
   mssqlSourceResolver = do
-    currentTime <- liftIO Clock.getCurrentTime
     initialiseResult <- runExceptT $ do
       -- TODO: should we allow the migration to happen during maintenance mode?
       -- Allowing this can be a sanity check, to see if the hdb_catalog in the
       -- DB has been set correctly
+      currentTime <- liftIO Clock.getCurrentTime
       (migrationResult, metadata) <-
         Q.runTx pool (Q.Serializable, Just Q.ReadWrite) $
           migrateCatalog
@@ -482,15 +482,9 @@ migrateCatalogSchema
               slKind = "catalog_migrate",
               slInfo = A.toJSON err
             }
-        liftIO (printErrExit DatabaseMigrationError (BLC.unpack $ A.encode err))
+        liftIO (throwErrJExit DatabaseMigrationError err)
     unLogger logger migrationResult
-    pure (schemaCache, currentTime)
+    pure schemaCache
-
--- | Run a transaction and if an error is encountered, log the error and abort the program
-runTxIO :: Q.PGPool -> Q.TxMode -> Q.TxE QErr a -> IO a
-runTxIO pool isoLevel tx = do
-  eVal <- liftIO $ runExceptT $ Q.runTx pool isoLevel tx
-  onLeft eVal (printErrJExit DatabaseMigrationError)
 
 -- | A latch for the graceful shutdown of a server process.
 newtype ShutdownLatch = ShutdownLatch {unShutdownLatch :: C.MVar ()}
@@ -675,7 +669,7 @@ mkHGEServer setupHook env ServeOptions {..} ServeCtx {..} initTime postPollHook
         _scHttpManager
         logger
 
-  authMode <- onLeft authModeRes (printErrExit AuthConfigurationError . T.unpack)
+  authMode <- onLeft authModeRes (throwErrExit AuthConfigurationError . T.unpack)
 
   HasuraApp app cacheRef actionSubState stopWsServer <-
     lift $
@@ -778,20 +772,21 @@ mkHGEServer setupHook env ServeOptions {..} ServeCtx {..} initTime postPollHook
       liftIO $ checkForUpdates loggerCtx _scHttpManager
 
   -- start a background thread for telemetry
-  dbUidE <- runMetadataStorageT getDatabaseUid
   _telemetryThread <-
     if soEnableTelemetry
       then do
         lift . unLogger logger $ mkGenericStrLog LevelInfo "telemetry" telemetryNotice
 
-        (dbId, pgVersion) <-
+        dbUid <-
-          liftIO $
+          runMetadataStorageT getDatabaseUid
-            runTxIO _scMetadataDbPool (Q.ReadCommitted, Nothing) $
+            >>= (`onLeft` throwErrJExit DatabaseMigrationError)
-              (,) <$> liftEither dbUidE <*> getPgVersion
+        pgVersion <-
+          (liftIO $ runExceptT $ Q.runTx _scMetadataDbPool (Q.ReadCommitted, Nothing) $ getPgVersion)
+            >>= (`onLeft` throwErrJExit DatabaseMigrationError)
 
         telemetryThread <-
           C.forkManagedT "runTelemetry" logger $
-            liftIO $ runTelemetry logger _scHttpManager (getSchemaCache cacheRef) dbId _scInstanceId pgVersion
+            liftIO $ runTelemetry logger _scHttpManager (getSchemaCache cacheRef) dbUid _scInstanceId pgVersion
         return $ Just telemetryThread
       else return Nothing
 
@@ -809,7 +804,7 @@ mkHGEServer setupHook env ServeOptions {..} ServeCtx {..} initTime postPollHook
     prepareScheduledEvents (Logger logger) = do
       liftIO $ logger $ mkGenericStrLog LevelInfo "scheduled_triggers" "preparing data"
       res <- runMetadataStorageT unlockAllLockedScheduledEvents
-      onLeft res $ printErrJExit EventSubSystemError
+      onLeft res $ throwErrJExit EventSubSystemError
 
     getProcessingScheduledEventsCount :: LockedEventsCtx -> IO Int
     getProcessingScheduledEventsCount LockedEventsCtx {..} = do