graphql-engine/server/src-exec/Main.hs

235 lines
8.6 KiB
Haskell

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.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.Events.Lib
import Hasura.Logging (Logger (..), defaultLoggerSettings,
mkLogger, mkLoggerCtx)
import Hasura.Prelude
import Hasura.RQL.DDL.Metadata (fetchMetadata)
import Hasura.RQL.Types (QErr, adminUserInfo,
emptySchemaCache)
import Hasura.Server.App (mkWaiApp)
import Hasura.Server.Auth
import Hasura.Server.CheckUpdates (checkForUpdates)
import Hasura.Server.Init
import Hasura.Server.Query (peelRun)
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
<*> parseEnabledAPIs
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
main :: IO ()
main = do
(HGEOptionsG rci hgeCmd) <- parseArgs
-- global http manager
httpManager <- HTTP.newManager HTTP.tlsManagerSettings
loggerCtx <- mkLoggerCtx $ defaultLoggerSettings True
let logger = mkLogger loggerCtx
case hgeCmd of
HCServe so@(ServeOptions port host cp isoL mAdminSecret mAuthHook mJwtSecret
mUnAuthRole corsCfg enableConsole enableTelemetry enabledAPIs) -> do
-- 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
-- safe init catalog
initRes <- initialise logger ci httpManager
-- prepare event triggers data
prepareEvents logger ci
pool <- Q.initPGPool ci cp
(app, cacheRef) <- mkWaiApp isoL loggerCtx pool httpManager
am corsCfg enableConsole enableTelemetry enabledAPIs
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"
eventEngineCtx <- atomically $ initEventEngineCtx maxEvThrds evFetchMilliSec
unLogger logger $
mkGenericStrLog "event_triggers" "starting workers"
void $ C.forkIO $ processEventQueue hloggerCtx logEnvHeaders httpManager pool cacheRef 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 cacheRef initRes
unLogger logger $
mkGenericStrLog "server" "starting API server"
Warp.runSettings warpSettings app
HCExport -> do
ci <- procConnInfo rci
res <- runTx ci fetchMetadata
either printErrJExit printJSON res
HCClean -> do
ci <- procConnInfo rci
res <- runTx ci cleanCatalog
either printErrJExit (const cleanSuccess) res
HCExecute -> do
queryBs <- BL.getContents
ci <- procConnInfo rci
res <- runAsAdmin ci httpManager $ execQuery queryBs
either printErrJExit BLC.putStrLn res
HCVersion -> putStrLn $ "Hasura GraphQL Engine: " ++ T.unpack currentVersion
where
runTx :: Q.ConnInfo -> Q.TxE QErr a -> IO (Either QErr a)
runTx ci tx = do
pool <- getMinimalPool ci
runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx
runAsAdmin ci httpManager m = do
pool <- getMinimalPool ci
res <- runExceptT $ peelRun emptySchemaCache adminUserInfo
httpManager pool Q.Serializable m
return $ fmap fst res
procConnInfo rci =
either (printErrExit . connInfoErrModifier) return $
mkConnInfo rci
getMinimalPool ci = do
let connParams = Q.defaultConnParams { Q.cpConns = 1 }
Q.initPGPool ci connParams
initialise (Logger logger) ci httpMgr = do
currentTime <- getCurrentTime
-- initialise the catalog
initRes <- runAsAdmin ci httpMgr $ initCatalogSafe currentTime
either printErrJExit (logger . mkGenericStrLog "db_init") initRes
-- migrate catalog if necessary
migRes <- runAsAdmin ci httpMgr $ migrateCatalog currentTime
either printErrJExit (logger . mkGenericStrLog "db_migrate") migRes
-- generate and retrieve uuids
getUniqIds ci
prepareEvents (Logger logger) ci = do
logger $ mkGenericStrLog "event_triggers" "preparing data"
res <- runTx ci unlockAllEvents
either printErrJExit return res
getUniqIds ci = do
eDbId <- runTx ci 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"