mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 09:22:43 +03:00
275 lines
10 KiB
Haskell
275 lines
10 KiB
Haskell
{-# LANGUAGE TypeApplications #-}
|
|
module Main where
|
|
|
|
import Migrate (migrateCatalog)
|
|
import Ops
|
|
|
|
import Control.Monad.STM (atomically)
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Options.Applicative
|
|
import System.Environment (getEnvironment, lookupEnv)
|
|
import System.Exit (exitFailure)
|
|
|
|
|
|
import qualified Control.Concurrent as C
|
|
import qualified Data.Aeson as A
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.ByteString.Lazy.Char8 as BLC
|
|
import qualified Data.Text as T
|
|
import qualified Data.Time.Clock as Clock
|
|
import qualified Data.Yaml as Y
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Client.TLS as HTTP
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
|
|
import Hasura.Db
|
|
import Hasura.Events.Lib
|
|
import Hasura.Logging
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.DDL.Metadata (fetchMetadata)
|
|
import Hasura.RQL.Types (SQLGenCtx (..), SchemaCache (..),
|
|
adminUserInfo, emptySchemaCache)
|
|
import Hasura.Server.App (SchemaCacheRef (..), getSCFromRef,
|
|
logInconsObjs, mkWaiApp)
|
|
import Hasura.Server.Auth
|
|
import Hasura.Server.CheckUpdates (checkForUpdates)
|
|
import Hasura.Server.Init
|
|
import Hasura.Server.Logging
|
|
import Hasura.Server.Query (peelRun)
|
|
import Hasura.Server.SchemaUpdate
|
|
import Hasura.Server.Telemetry
|
|
import Hasura.Server.Version (currentVersion)
|
|
|
|
import qualified Database.PG.Query as Q
|
|
|
|
printErrExit :: forall a . String -> IO a
|
|
printErrExit = (>> exitFailure) . putStrLn
|
|
|
|
printErrJExit :: A.ToJSON a => forall b . a -> IO b
|
|
printErrJExit = (>> exitFailure) . printJSON
|
|
|
|
parseHGECommand :: Parser RawHGECommand
|
|
parseHGECommand =
|
|
subparser
|
|
( command "serve" (info (helper <*> (HCServe <$> serveOpts))
|
|
( progDesc "Start the GraphQL Engine Server"
|
|
<> footerDoc (Just serveCmdFooter)
|
|
))
|
|
<> command "export" (info (pure HCExport)
|
|
( progDesc "Export graphql-engine's metadata to stdout" ))
|
|
<> command "clean" (info (pure HCClean)
|
|
( progDesc "Clean graphql-engine's metadata to start afresh" ))
|
|
<> command "execute" (info (pure HCExecute)
|
|
( progDesc "Execute a query" ))
|
|
<> command "version" (info (pure HCVersion)
|
|
(progDesc "Prints the version of GraphQL Engine"))
|
|
)
|
|
where
|
|
serveOpts = RawServeOptions
|
|
<$> parseServerPort
|
|
<*> parseServerHost
|
|
<*> parseConnParams
|
|
<*> parseTxIsolation
|
|
<*> (parseAdminSecret <|> parseAccessKey)
|
|
<*> parseWebHook
|
|
<*> parseJwtSecret
|
|
<*> parseUnAuthRole
|
|
<*> parseCorsConfig
|
|
<*> parseEnableConsole
|
|
<*> parseEnableTelemetry
|
|
<*> parseWsReadCookie
|
|
<*> parseStringifyNum
|
|
<*> parseEnabledAPIs
|
|
<*> parseMxRefetchInt
|
|
<*> parseMxBatchSize
|
|
<*> parseFallbackRefetchInt
|
|
<*> parseEnableAllowlist
|
|
|
|
|
|
parseArgs :: IO HGEOptions
|
|
parseArgs = do
|
|
rawHGEOpts <- execParser opts
|
|
env <- getEnvironment
|
|
let eitherOpts = runWithEnv env $ mkHGEOptions rawHGEOpts
|
|
either printErrExit return eitherOpts
|
|
where
|
|
opts = info (helper <*> hgeOpts)
|
|
( fullDesc <>
|
|
header "Hasura GraphQL Engine: Realtime GraphQL API over Postgres with access control" <>
|
|
footerDoc (Just mainCmdFooter)
|
|
)
|
|
hgeOpts = HGEOptionsG <$> parseRawConnInfo <*> parseHGECommand
|
|
|
|
printJSON :: (A.ToJSON a) => a -> IO ()
|
|
printJSON = BLC.putStrLn . A.encode
|
|
|
|
printYaml :: (A.ToJSON a) => a -> IO ()
|
|
printYaml = BC.putStrLn . Y.encode
|
|
|
|
mkPGLogger :: Logger -> Q.PGLogger
|
|
mkPGLogger (Logger logger) (Q.PLERetryMsg msg) =
|
|
logger $ PGLog LevelWarn msg
|
|
|
|
main :: IO ()
|
|
main = do
|
|
(HGEOptionsG rci hgeCmd) <- parseArgs
|
|
-- global http manager
|
|
httpManager <- HTTP.newManager HTTP.tlsManagerSettings
|
|
loggerCtx <- mkLoggerCtx $ defaultLoggerSettings True
|
|
instanceId <- mkInstanceId
|
|
let logger = mkLogger loggerCtx
|
|
pgLogger = mkPGLogger logger
|
|
case hgeCmd of
|
|
HCServe so@(ServeOptions port host cp isoL mAdminSecret mAuthHook
|
|
mJwtSecret mUnAuthRole corsCfg enableConsole
|
|
enableTelemetry strfyNum enabledAPIs lqOpts enableAL) -> do
|
|
let sqlGenCtx = SQLGenCtx strfyNum
|
|
|
|
initTime <- Clock.getCurrentTime
|
|
-- log serve options
|
|
unLogger logger $ serveOptsToLog so
|
|
hloggerCtx <- mkLoggerCtx $ defaultLoggerSettings False
|
|
|
|
authModeRes <- runExceptT $ mkAuthMode mAdminSecret mAuthHook mJwtSecret
|
|
mUnAuthRole httpManager loggerCtx
|
|
|
|
am <- either (printErrExit . T.unpack) return authModeRes
|
|
|
|
ci <- procConnInfo rci
|
|
-- log postgres connection info
|
|
unLogger logger $ connInfoToLog ci
|
|
|
|
pool <- Q.initPGPool ci cp pgLogger
|
|
|
|
-- safe init catalog
|
|
initRes <- initialise pool sqlGenCtx logger httpManager
|
|
|
|
(app, cacheRef, cacheInitTime) <-
|
|
mkWaiApp isoL loggerCtx sqlGenCtx enableAL pool ci httpManager am
|
|
corsCfg enableConsole enableTelemetry instanceId enabledAPIs lqOpts
|
|
|
|
-- log inconsistent schema objects
|
|
inconsObjs <- scInconsistentObjs <$> getSCFromRef cacheRef
|
|
logInconsObjs logger inconsObjs
|
|
|
|
-- start a background thread for schema sync
|
|
startSchemaSync sqlGenCtx pool logger httpManager
|
|
cacheRef instanceId cacheInitTime
|
|
|
|
let warpSettings = Warp.setPort port $ Warp.setHost host Warp.defaultSettings
|
|
|
|
maxEvThrds <- getFromEnv defaultMaxEventThreads "HASURA_GRAPHQL_EVENTS_HTTP_POOL_SIZE"
|
|
evFetchMilliSec <- getFromEnv defaultFetchIntervalMilliSec "HASURA_GRAPHQL_EVENTS_FETCH_INTERVAL"
|
|
logEnvHeaders <- getFromEnv False "LOG_HEADERS_FROM_ENV"
|
|
|
|
-- prepare event triggers data
|
|
prepareEvents pool logger
|
|
eventEngineCtx <- atomically $ initEventEngineCtx maxEvThrds evFetchMilliSec
|
|
let scRef = _scrCache cacheRef
|
|
unLogger logger $
|
|
mkGenericStrLog "event_triggers" "starting workers"
|
|
void $ C.forkIO $ processEventQueue hloggerCtx logEnvHeaders
|
|
httpManager pool scRef eventEngineCtx
|
|
|
|
-- start a background thread to check for updates
|
|
void $ C.forkIO $ checkForUpdates loggerCtx httpManager
|
|
|
|
-- start a background thread for telemetry
|
|
when enableTelemetry $ do
|
|
unLogger logger $ mkGenericStrLog "telemetry" telemetryNotice
|
|
void $ C.forkIO $ runTelemetry logger httpManager scRef initRes
|
|
|
|
finishTime <- Clock.getCurrentTime
|
|
let apiInitTime = realToFrac $ Clock.diffUTCTime finishTime initTime
|
|
unLogger logger $
|
|
mkGenericStrLog "server" $
|
|
"starting API server, took " <> show @Double apiInitTime <> "s"
|
|
Warp.runSettings warpSettings app
|
|
|
|
HCExport -> do
|
|
ci <- procConnInfo rci
|
|
res <- runTx' pgLogger ci fetchMetadata
|
|
either printErrJExit printJSON res
|
|
|
|
HCClean -> do
|
|
ci <- procConnInfo rci
|
|
res <- runTx' pgLogger ci cleanCatalog
|
|
either printErrJExit (const cleanSuccess) res
|
|
|
|
HCExecute -> do
|
|
queryBs <- BL.getContents
|
|
ci <- procConnInfo rci
|
|
let sqlGenCtx = SQLGenCtx False
|
|
pool <- getMinimalPool pgLogger ci
|
|
res <- runAsAdmin pool sqlGenCtx httpManager $ execQuery queryBs
|
|
either printErrJExit BLC.putStrLn res
|
|
|
|
HCVersion -> putStrLn $ "Hasura GraphQL Engine: " ++ T.unpack currentVersion
|
|
where
|
|
|
|
runTx pool tx =
|
|
runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx
|
|
|
|
runTx' pgLogger ci tx = do
|
|
pool <- getMinimalPool pgLogger ci
|
|
runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx
|
|
|
|
runAsAdmin pool sqlGenCtx httpManager m = do
|
|
res <- runExceptT $ peelRun emptySchemaCache adminUserInfo
|
|
httpManager sqlGenCtx (PGExecCtx pool Q.Serializable) m
|
|
return $ fmap fst res
|
|
|
|
procConnInfo rci =
|
|
either (printErrExit . connInfoErrModifier) return $
|
|
mkConnInfo rci
|
|
|
|
getMinimalPool pgLogger ci = do
|
|
let connParams = Q.defaultConnParams { Q.cpConns = 1 }
|
|
Q.initPGPool ci connParams pgLogger
|
|
|
|
initialise pool sqlGenCtx (Logger logger) httpMgr = do
|
|
currentTime <- getCurrentTime
|
|
-- initialise the catalog
|
|
initRes <- runAsAdmin pool sqlGenCtx httpMgr $
|
|
initCatalogSafe currentTime
|
|
either printErrJExit (logger . mkGenericStrLog "db_init") initRes
|
|
|
|
-- migrate catalog if necessary
|
|
migRes <- runAsAdmin pool sqlGenCtx httpMgr $
|
|
migrateCatalog currentTime
|
|
either printErrJExit (logger . mkGenericStrLog "db_migrate") migRes
|
|
|
|
-- generate and retrieve uuids
|
|
getUniqIds pool
|
|
|
|
prepareEvents pool (Logger logger) = do
|
|
logger $ mkGenericStrLog "event_triggers" "preparing data"
|
|
res <- runTx pool unlockAllEvents
|
|
either printErrJExit return res
|
|
|
|
getUniqIds pool = do
|
|
eDbId <- runTx pool getDbId
|
|
dbId <- either printErrJExit return eDbId
|
|
fp <- liftIO generateFingerprint
|
|
return (dbId, fp)
|
|
|
|
getFromEnv :: (Read a) => a -> String -> IO a
|
|
getFromEnv defaults env = do
|
|
mEnv <- lookupEnv env
|
|
let mRes = case mEnv of
|
|
Nothing -> Just defaults
|
|
Just val -> readMaybe val
|
|
eRes = maybe (Left $ "Wrong expected type for environment variable: " <> env) Right mRes
|
|
either printErrExit return eRes
|
|
|
|
cleanSuccess =
|
|
putStrLn "successfully cleaned graphql-engine related data"
|
|
|
|
|
|
telemetryNotice :: String
|
|
telemetryNotice =
|
|
"Help us improve Hasura! The graphql-engine server collects anonymized "
|
|
<> "usage stats which allows us to keep improving Hasura at warp speed. "
|
|
<> "To read more or opt-out, visit https://docs.hasura.io/1.0/graphql/manual/guides/telemetry.html"
|