mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 04:51:35 +03:00
e99f9a2f57
## Description This PR removes `MetadataStorageT`, and cleans up all top-level error handling. In short: this PR changes `MonadMetadataStorage` to explicitly return a bunch of `Either QErr a`, instead of relying on the stack providing a `MonadError QErr`. Since we implement that class on the base monad *below any ExceptT*, this removes a lot of very complicated instances that make assumptions about the shape of the stack. On the back of this, we can remove several layers of ExceptT from the core of the code, including the one in `RunT`, which allows us to remove several instances of `liftEitherM . runExceptT`. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7689 GitOrigin-RevId: 97d600154d690f58c0b93fb4cc2d30fd383fd8b8
132 lines
5.2 KiB
Haskell
132 lines
5.2 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Main (main) where
|
|
|
|
import Control.Concurrent.MVar
|
|
import Control.Natural ((:~>) (..))
|
|
import Data.Aeson qualified as A
|
|
import Data.ByteString.Lazy.Char8 qualified as BL
|
|
import Data.ByteString.Lazy.UTF8 qualified as LBS
|
|
import Data.Environment qualified as Env
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Data.URL.Template
|
|
import Database.PG.Query qualified as PG
|
|
import Hasura.App
|
|
( PGMetadataStorageAppT (..),
|
|
mkMSSQLSourceResolver,
|
|
mkPgSourceResolver,
|
|
)
|
|
import Hasura.Backends.Postgres.Connection.Settings
|
|
import Hasura.Backends.Postgres.Execute.Types
|
|
import Hasura.Base.Error
|
|
import Hasura.EventTriggerCleanupSuite qualified as EventTriggerCleanupSuite
|
|
import Hasura.GraphQL.Schema.Options qualified as Options
|
|
import Hasura.Logging
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.DDL.Schema.Cache
|
|
import Hasura.RQL.DDL.Schema.Cache.Common
|
|
import Hasura.RQL.Types.Common
|
|
import Hasura.RQL.Types.Metadata (emptyMetadataDefaults)
|
|
import Hasura.RQL.Types.ResizePool
|
|
import Hasura.RQL.Types.SchemaCache.Build
|
|
import Hasura.Server.Init
|
|
import Hasura.Server.Init.FeatureFlag as FF
|
|
import Hasura.Server.Migrate
|
|
import Hasura.Server.MigrateSuite qualified as MigrateSuite
|
|
import Hasura.Server.Types
|
|
import Hasura.StreamingSubscriptionSuite qualified as StreamingSubscriptionSuite
|
|
import Network.HTTP.Client qualified as HTTP
|
|
import Network.HTTP.Client.TLS qualified as HTTP
|
|
import System.Environment (getEnvironment)
|
|
import System.Exit (exitFailure)
|
|
import Test.Hspec
|
|
|
|
main :: IO ()
|
|
main = do
|
|
env <- getEnvironment
|
|
let envMap = Env.mkEnvironment env
|
|
|
|
pgUrlText <- flip onLeft printErrExit $
|
|
runWithEnv env $ do
|
|
let envVar = _envVar databaseUrlOption
|
|
maybeV <- considerEnv envVar
|
|
onNothing maybeV $
|
|
throwError $
|
|
"Expected: " <> envVar
|
|
|
|
let pgConnInfo = PG.ConnInfo 1 $ PG.CDDatabaseURI $ txtToBs pgUrlText
|
|
urlConf = UrlValue $ InputWebhook $ mkPlainURLTemplate pgUrlText
|
|
sourceConnInfo =
|
|
PostgresSourceConnInfo urlConf (Just setPostgresPoolSettings) True PG.ReadCommitted Nothing
|
|
sourceConfig = PostgresConnConfiguration sourceConnInfo Nothing defaultPostgresExtensionsSchema Nothing mempty
|
|
|
|
pgPool <- PG.initPGPool pgConnInfo PG.defaultConnParams {PG.cpConns = 1} print
|
|
let pgContext = mkPGExecCtx PG.Serializable pgPool NeverResizePool
|
|
|
|
logger :: Logger Hasura = Logger $ \l -> do
|
|
let (logLevel, logType :: EngineLogType Hasura, logDetail) = toEngineLog l
|
|
t <- liftIO $ getFormattedTime Nothing
|
|
liftIO $ putStrLn $ LBS.toString $ A.encode $ EngineLog t logLevel logType logDetail
|
|
|
|
setupCacheRef = do
|
|
httpManager <- HTTP.newManager HTTP.tlsManagerSettings
|
|
let sqlGenCtx =
|
|
SQLGenCtx
|
|
Options.Don'tStringifyNumbers
|
|
Options.Don'tDangerouslyCollapseBooleans
|
|
Options.Don'tOptimizePermissionFilters
|
|
Options.EnableBigQueryStringNumericInput
|
|
maintenanceMode = MaintenanceModeDisabled
|
|
readOnlyMode = ReadOnlyModeDisabled
|
|
serverConfigCtx =
|
|
ServerConfigCtx
|
|
Options.InferFunctionPermissions
|
|
Options.DisableRemoteSchemaPermissions
|
|
sqlGenCtx
|
|
maintenanceMode
|
|
mempty
|
|
EventingEnabled
|
|
readOnlyMode
|
|
(_default defaultNamingConventionOption)
|
|
emptyMetadataDefaults
|
|
(FF.checkFeatureFlag mempty)
|
|
cacheBuildParams = CacheBuildParams httpManager (mkPgSourceResolver print) mkMSSQLSourceResolver serverConfigCtx
|
|
pgLogger = print
|
|
|
|
run :: ExceptT QErr (PGMetadataStorageAppT CacheBuild) a -> IO a
|
|
run =
|
|
runExceptT
|
|
>>> flip runPGMetadataStorageAppT (pgPool, pgLogger)
|
|
>>> runCacheBuild cacheBuildParams
|
|
>>> runExceptT
|
|
>=> flip onLeft printErrJExit
|
|
>=> flip onLeft printErrJExit
|
|
|
|
(metadata, schemaCache) <- run do
|
|
metadata <-
|
|
snd
|
|
<$> (liftEitherM . runExceptT . _pecRunTx pgContext (PGExecCtxInfo (Tx PG.ReadWrite Nothing) InternalRawQuery))
|
|
(migrateCatalog (Just sourceConfig) defaultPostgresExtensionsSchema maintenanceMode =<< liftIO getCurrentTime)
|
|
schemaCache <- lift $ lift $ buildRebuildableSchemaCache logger envMap metadata
|
|
pure (metadata, schemaCache)
|
|
|
|
cacheRef <- newMVar schemaCache
|
|
pure $ NT (run . flip MigrateSuite.runCacheRefT cacheRef . fmap fst . runMetadataT metadata emptyMetadataDefaults)
|
|
|
|
streamingSubscriptionSuite <- StreamingSubscriptionSuite.buildStreamingSubscriptionSuite
|
|
eventTriggerLogCleanupSuite <- EventTriggerCleanupSuite.buildEventTriggerCleanupSuite
|
|
|
|
hspec do
|
|
describe "Migrate suite" $
|
|
beforeAll setupCacheRef $
|
|
describe "Hasura.Server.Migrate" $
|
|
MigrateSuite.suite sourceConfig pgContext pgConnInfo
|
|
describe "Streaming subscription suite" $ streamingSubscriptionSuite
|
|
describe "Event trigger log cleanup suite" $ eventTriggerLogCleanupSuite
|
|
|
|
printErrExit :: String -> IO a
|
|
printErrExit = (*> exitFailure) . putStrLn
|
|
|
|
printErrJExit :: (A.ToJSON a) => a -> IO b
|
|
printErrJExit = (*> exitFailure) . BL.putStrLn . A.encode
|