2018-06-27 16:11:32 +03:00
|
|
|
module Main where
|
|
|
|
|
|
|
|
import Ops
|
|
|
|
|
2018-09-05 14:26:46 +03:00
|
|
|
import Control.Monad.STM (atomically)
|
2018-06-27 16:11:32 +03:00
|
|
|
import Data.Time.Clock (getCurrentTime)
|
|
|
|
import Options.Applicative
|
2018-12-14 06:21:41 +03:00
|
|
|
import System.Environment (getEnvironment, lookupEnv)
|
2018-12-19 14:38:33 +03:00
|
|
|
import System.Exit (exitFailure)
|
2018-06-27 16:11:32 +03:00
|
|
|
|
2018-07-27 12:34:50 +03:00
|
|
|
import qualified Control.Concurrent as C
|
2018-06-27 16:11:32 +03:00
|
|
|
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
|
2018-07-27 12:34:50 +03:00
|
|
|
import qualified Network.HTTP.Client as HTTP
|
|
|
|
import qualified Network.HTTP.Client.TLS as HTTP
|
|
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
2018-06-27 16:11:32 +03:00
|
|
|
|
2018-09-05 14:26:46 +03:00
|
|
|
import Hasura.Events.Lib
|
2018-10-25 21:16:25 +03:00
|
|
|
import Hasura.Logging (defaultLoggerSettings, mkLoggerCtx)
|
2018-06-27 16:11:32 +03:00
|
|
|
import Hasura.Prelude
|
|
|
|
import Hasura.RQL.DDL.Metadata (fetchMetadata)
|
2018-12-19 14:38:33 +03:00
|
|
|
import Hasura.RQL.Types (QErr, adminUserInfo,
|
2018-12-13 10:26:15 +03:00
|
|
|
emptySchemaCache)
|
2018-07-20 10:22:46 +03:00
|
|
|
import Hasura.Server.App (mkWaiApp)
|
2018-09-27 14:22:49 +03:00
|
|
|
import Hasura.Server.Auth
|
2018-07-27 12:34:50 +03:00
|
|
|
import Hasura.Server.CheckUpdates (checkForUpdates)
|
2018-06-27 16:11:32 +03:00
|
|
|
import Hasura.Server.Init
|
2018-12-13 10:26:15 +03:00
|
|
|
import Hasura.Server.Query (peelRun)
|
2018-12-14 06:21:41 +03:00
|
|
|
import Hasura.Server.Version (currentVersion)
|
2018-06-27 16:11:32 +03:00
|
|
|
|
|
|
|
import qualified Database.PG.Query as Q
|
2018-09-05 14:26:46 +03:00
|
|
|
import qualified Network.HTTP.Client.TLS as TLS
|
|
|
|
import qualified Network.Wreq.Session as WrqS
|
2018-06-27 16:11:32 +03:00
|
|
|
|
2018-12-19 14:38:33 +03:00
|
|
|
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 =
|
2018-12-14 06:21:41 +03:00
|
|
|
subparser
|
2018-12-19 14:38:33 +03:00
|
|
|
( command "serve" (info (helper <*> (HCServe <$> serveOpts))
|
2018-12-14 06:21:41 +03:00
|
|
|
( progDesc "Start the GraphQL Engine Server"
|
|
|
|
<> footerDoc (Just serveCmdFooter)
|
|
|
|
))
|
2018-12-19 14:38:33 +03:00
|
|
|
<> command "export" (info (pure HCExport)
|
2018-12-14 06:21:41 +03:00
|
|
|
( progDesc "Export graphql-engine's metadata to stdout" ))
|
2018-12-19 14:38:33 +03:00
|
|
|
<> command "clean" (info (pure HCClean)
|
2018-12-14 06:21:41 +03:00
|
|
|
( progDesc "Clean graphql-engine's metadata to start afresh" ))
|
2018-12-19 14:38:33 +03:00
|
|
|
<> command "execute" (info (pure HCExecute)
|
2018-12-14 06:21:41 +03:00
|
|
|
( progDesc "Execute a query" ))
|
2018-12-19 14:38:33 +03:00
|
|
|
<> command "version" (info (pure HCVersion)
|
2018-12-14 06:21:41 +03:00
|
|
|
(progDesc "Prints the version of GraphQL Engine"))
|
|
|
|
)
|
2018-06-27 16:11:32 +03:00
|
|
|
where
|
2018-12-19 14:38:33 +03:00
|
|
|
serveOpts = RawServeOptions
|
|
|
|
<$> parseServerPort
|
|
|
|
<*> parseConnParams
|
|
|
|
<*> parseTxIsolation
|
|
|
|
<*> parseRootDir
|
|
|
|
<*> parseAccessKey
|
|
|
|
<*> parseWebHook
|
|
|
|
<*> parseJwtSecret
|
|
|
|
<*> parseUnAuthRole
|
|
|
|
<*> parseCorsConfig
|
|
|
|
<*> parseEnableConsole
|
|
|
|
|
|
|
|
parseArgs :: IO HGEOptions
|
|
|
|
parseArgs = do
|
|
|
|
rawHGEOpts <- execParser opts
|
|
|
|
env <- getEnvironment
|
|
|
|
let eitherOpts = runWithEnv env $ mkHGEOptions rawHGEOpts
|
|
|
|
either printErrExit return eitherOpts
|
2018-06-27 16:11:32 +03:00
|
|
|
where
|
2018-12-19 14:38:33 +03:00
|
|
|
opts = info (helper <*> hgeOpts)
|
2018-06-27 16:11:32 +03:00
|
|
|
( fullDesc <>
|
2018-12-14 06:21:41 +03:00
|
|
|
header "Hasura GraphQL Engine: Realtime GraphQL API over Postgres with access control" <>
|
|
|
|
footerDoc (Just mainCmdFooter)
|
|
|
|
)
|
2018-12-19 14:38:33 +03:00
|
|
|
hgeOpts = HGEOptionsG <$> parseRawConnInfo <*> parseHGECommand
|
2018-06-27 16:11:32 +03:00
|
|
|
|
|
|
|
printJSON :: (A.ToJSON a) => a -> IO ()
|
|
|
|
printJSON = BLC.putStrLn . A.encode
|
|
|
|
|
|
|
|
printYaml :: (A.ToJSON a) => a -> IO ()
|
|
|
|
printYaml = BC.putStrLn . Y.encode
|
|
|
|
|
2018-12-19 14:38:33 +03:00
|
|
|
procConnInfo :: RawConnInfo -> IO Q.ConnInfo
|
|
|
|
procConnInfo rci = do
|
|
|
|
ci <- either (printErrExit . connInfoErrModifier)
|
|
|
|
return $ mkConnInfo rci
|
|
|
|
printConnInfo ci
|
|
|
|
return ci
|
2018-10-10 09:46:38 +03:00
|
|
|
where
|
2018-12-19 14:38:33 +03:00
|
|
|
printConnInfo ci =
|
|
|
|
putStrLn $
|
|
|
|
"Postgres connection info:"
|
|
|
|
++ "\n Host: " ++ Q.connHost ci
|
|
|
|
++ "\n Port: " ++ show (Q.connPort ci)
|
|
|
|
++ "\n User: " ++ Q.connUser ci
|
|
|
|
++ "\n Database: " ++ Q.connDatabase ci
|
2018-10-10 09:46:38 +03:00
|
|
|
|
2018-06-27 16:11:32 +03:00
|
|
|
main :: IO ()
|
2018-07-20 10:22:46 +03:00
|
|
|
main = do
|
2018-12-19 14:38:33 +03:00
|
|
|
(HGEOptionsG rci hgeCmd) <- parseArgs
|
|
|
|
-- global http manager
|
2018-07-27 12:34:50 +03:00
|
|
|
httpManager <- HTTP.newManager HTTP.tlsManagerSettings
|
2018-12-19 14:38:33 +03:00
|
|
|
case hgeCmd of
|
|
|
|
HCServe (ServeOptions port cp isoL mRootDir mAccessKey mAuthHook mJwtSecret
|
2018-10-25 21:16:25 +03:00
|
|
|
mUnAuthRole corsCfg enableConsole) -> do
|
2018-12-19 14:38:33 +03:00
|
|
|
loggerCtx <- mkLoggerCtx $ defaultLoggerSettings True
|
|
|
|
hloggerCtx <- mkLoggerCtx $ defaultLoggerSettings False
|
2018-09-27 14:22:49 +03:00
|
|
|
|
2018-12-14 06:21:41 +03:00
|
|
|
authModeRes <- runExceptT $ mkAuthMode mAccessKey mAuthHook mJwtSecret
|
|
|
|
mUnAuthRole httpManager loggerCtx
|
|
|
|
|
2018-12-19 14:38:33 +03:00
|
|
|
am <- either (printErrExit . T.unpack) return authModeRes
|
|
|
|
ci <- procConnInfo rci
|
2018-11-23 16:02:46 +03:00
|
|
|
initialise ci httpManager
|
2018-10-10 09:46:38 +03:00
|
|
|
-- migrate catalog if necessary
|
2018-11-23 16:02:46 +03:00
|
|
|
migrate ci httpManager
|
2018-09-05 14:26:46 +03:00
|
|
|
prepareEvents ci
|
2018-06-27 16:11:32 +03:00
|
|
|
pool <- Q.initPGPool ci cp
|
2018-07-20 10:22:46 +03:00
|
|
|
putStrLn $ "server: running on port " ++ show port
|
2018-10-10 09:46:38 +03:00
|
|
|
(app, cacheRef) <- mkWaiApp isoL mRootDir loggerCtx pool httpManager
|
2018-12-14 06:21:41 +03:00
|
|
|
am corsCfg enableConsole
|
2018-07-20 10:22:46 +03:00
|
|
|
let warpSettings = Warp.setPort port Warp.defaultSettings
|
|
|
|
-- Warp.setHost "*" Warp.defaultSettings
|
2018-07-27 12:34:50 +03:00
|
|
|
|
|
|
|
-- start a background thread to check for updates
|
|
|
|
void $ C.forkIO $ checkForUpdates loggerCtx httpManager
|
|
|
|
|
2018-09-05 14:26:46 +03:00
|
|
|
maxEvThrds <- getFromEnv defaultMaxEventThreads "HASURA_GRAPHQL_EVENTS_HTTP_POOL_SIZE"
|
2018-10-30 18:20:18 +03:00
|
|
|
evFetchMilliSec <- getFromEnv defaultFetchIntervalMilliSec "HASURA_GRAPHQL_EVENTS_FETCH_INTERVAL"
|
2018-10-26 19:28:03 +03:00
|
|
|
logEnvHeaders <- getFromEnv False "LOG_HEADERS_FROM_ENV"
|
2018-09-05 14:26:46 +03:00
|
|
|
|
2018-10-30 18:20:18 +03:00
|
|
|
eventEngineCtx <- atomically $ initEventEngineCtx maxEvThrds evFetchMilliSec
|
2018-09-05 14:26:46 +03:00
|
|
|
httpSession <- WrqS.newSessionControl Nothing TLS.tlsManagerSettings
|
|
|
|
|
2018-10-26 19:28:03 +03:00
|
|
|
void $ C.forkIO $ processEventQueue hloggerCtx logEnvHeaders httpSession pool cacheRef eventEngineCtx
|
2018-09-05 14:26:46 +03:00
|
|
|
|
2018-07-20 10:22:46 +03:00
|
|
|
Warp.runSettings warpSettings app
|
2018-07-27 12:34:50 +03:00
|
|
|
|
2018-12-19 14:38:33 +03:00
|
|
|
HCExport -> do
|
|
|
|
ci <- procConnInfo rci
|
2018-06-27 16:11:32 +03:00
|
|
|
res <- runTx ci fetchMetadata
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit printJSON res
|
|
|
|
HCClean -> do
|
|
|
|
ci <- procConnInfo rci
|
2018-06-27 16:11:32 +03:00
|
|
|
res <- runTx ci cleanCatalog
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit (const cleanSuccess) res
|
|
|
|
HCExecute -> do
|
2018-06-27 16:11:32 +03:00
|
|
|
queryBs <- BL.getContents
|
2018-12-19 14:38:33 +03:00
|
|
|
ci <- procConnInfo rci
|
2018-12-13 10:26:15 +03:00
|
|
|
res <- runAsAdmin ci httpManager $ execQuery queryBs
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit BLC.putStrLn res
|
|
|
|
HCVersion -> putStrLn $ "Hasura GraphQL Engine: " ++ T.unpack currentVersion
|
2018-06-27 16:11:32 +03:00
|
|
|
where
|
2018-12-13 10:26:15 +03:00
|
|
|
runTx :: Q.ConnInfo -> Q.TxE QErr a -> IO (Either QErr a)
|
2018-06-27 16:11:32 +03:00
|
|
|
runTx ci tx = do
|
|
|
|
pool <- getMinimalPool ci
|
|
|
|
runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx
|
2018-12-13 10:26:15 +03:00
|
|
|
|
|
|
|
runAsAdmin ci httpManager m = do
|
|
|
|
pool <- getMinimalPool ci
|
|
|
|
res <- runExceptT $ peelRun emptySchemaCache adminUserInfo
|
|
|
|
httpManager pool Q.Serializable m
|
|
|
|
return $ fmap fst res
|
2018-06-27 16:11:32 +03:00
|
|
|
getMinimalPool ci = do
|
|
|
|
let connParams = Q.defaultConnParams { Q.cpConns = 1 }
|
|
|
|
Q.initPGPool ci connParams
|
2018-11-23 16:02:46 +03:00
|
|
|
initialise ci httpMgr = do
|
2018-06-27 16:11:32 +03:00
|
|
|
currentTime <- getCurrentTime
|
2018-12-13 10:26:15 +03:00
|
|
|
res <- runAsAdmin ci httpMgr $ initCatalogSafe currentTime
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit putStrLn res
|
2018-11-23 16:02:46 +03:00
|
|
|
migrate ci httpMgr = do
|
2018-06-27 16:11:32 +03:00
|
|
|
currentTime <- getCurrentTime
|
2018-12-13 10:26:15 +03:00
|
|
|
res <- runAsAdmin ci httpMgr $ migrateCatalog currentTime
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit putStrLn res
|
2018-09-05 14:26:46 +03:00
|
|
|
prepareEvents ci = do
|
|
|
|
putStrLn "event_triggers: preparing data"
|
|
|
|
res <- runTx ci unlockAllEvents
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrJExit return res
|
2018-11-15 07:55:39 +03:00
|
|
|
|
2018-09-05 14:26:46 +03:00
|
|
|
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
|
2018-10-26 19:28:03 +03:00
|
|
|
eRes = maybe (Left $ "Wrong expected type for environment variable: " <> env) Right mRes
|
2018-12-19 14:38:33 +03:00
|
|
|
either printErrExit return eRes
|
2018-06-27 16:11:32 +03:00
|
|
|
|
2018-07-11 11:24:13 +03:00
|
|
|
cleanSuccess = putStrLn "successfully cleaned graphql-engine related data"
|