From e73f9972842eed9491c729144a6c0e54dc252a53 Mon Sep 17 00:00:00 2001 From: Philip Lykke Carlsen Date: Tue, 16 May 2023 12:03:44 +0200 Subject: [PATCH] feat(test-harness): Maintain pools of hge processes PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9158 GitOrigin-RevId: 243e2d771cd8c31852b8b1959b006f27440f079d --- server/lib/api-tests/src/SpecHook.hs | 19 +- .../src/Harness/GlobalTestEnvironment.hs | 15 +- .../src/Harness/PassthroughEnvVars.hs | 12 - .../src/Harness/Services/Composed.hs | 40 +- .../src/Harness/Services/Database/Postgres.hs | 4 + .../Services/ExternalProcess/GraphqlEngine.hs | 390 ++++++++++++++++++ .../src/Harness/Services/GraphqlEngine.hs | 330 ++------------- .../src/Harness/Services/GraphqlEngine/API.hs | 99 +++++ .../src/Harness/Services/Metadata.hs | 38 -- .../src/Harness/TestEnvironment.hs | 3 +- server/lib/test-harness/test-harness.cabal | 5 +- 11 files changed, 577 insertions(+), 378 deletions(-) delete mode 100644 server/lib/test-harness/src/Harness/PassthroughEnvVars.hs create mode 100644 server/lib/test-harness/src/Harness/Services/ExternalProcess/GraphqlEngine.hs create mode 100644 server/lib/test-harness/src/Harness/Services/GraphqlEngine/API.hs delete mode 100644 server/lib/test-harness/src/Harness/Services/Metadata.hs diff --git a/server/lib/api-tests/src/SpecHook.hs b/server/lib/api-tests/src/SpecHook.hs index 573a9629391..14684124b6f 100644 --- a/server/lib/api-tests/src/SpecHook.hs +++ b/server/lib/api-tests/src/SpecHook.hs @@ -14,16 +14,15 @@ import Data.Char qualified as Char import Data.IORef import Data.List qualified as List import Database.PostgreSQL.Simple.Options qualified as Options -import Harness.Constants qualified as Constants import Harness.Exceptions import Harness.GraphqlEngine (startServerThread) import Harness.Logging import Harness.Services.Composed (mkTestServicesConfig) import Harness.Test.BackendType (BackendType (..)) -import Harness.TestEnvironment (GlobalTestEnvironment (..), PassthroughEnvVars (..), Protocol (..), TestingMode (..), stopServer) +import Harness.TestEnvironment (GlobalTestEnvironment (..), Protocol (..), TestingMode (..), stopServer) import Hasura.Prelude import System.Directory -import System.Environment (getEnvironment, lookupEnv) +import System.Environment (getEnvironment) import System.FilePath import System.IO.Unsafe (unsafePerformIO) import System.Log.FastLogger qualified as FL @@ -76,8 +75,7 @@ parseBackendType backendType = setupTestEnvironment :: TestingMode -> Logger -> IO GlobalTestEnvironment setupTestEnvironment testingMode logger = do server <- startServerThread - servicesConfig <- mkTestServicesConfig - passthroughEnvVars <- mkPassthroughEnv + servicesConfig <- mkTestServicesConfig logger pure GlobalTestEnvironment {requestProtocol = HTTP, ..} -- | tear down the shared server @@ -144,14 +142,3 @@ globalConfigRef = unsafePerformIO $ newIORef Nothing setupGlobalConfig :: TestingMode -> (Logger, IO ()) -> IO () setupGlobalConfig testingMode loggerCleanup = writeIORef globalConfigRef $ Just (testingMode, loggerCleanup) - -envToPassthrough :: [String] -envToPassthrough = [Constants.bigqueryServiceKeyVar] - --- | grab items from env to pass through to new HGE instances -mkPassthroughEnv :: IO PassthroughEnvVars -mkPassthroughEnv = - let lookup' env = do - value <- fromMaybe "" <$> lookupEnv env - pure (env, value) - in PassthroughEnvVars <$> traverse lookup' envToPassthrough diff --git a/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs b/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs index 6f1c24fa838..72fdecbf435 100644 --- a/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs +++ b/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs @@ -7,7 +7,6 @@ module Harness.GlobalTestEnvironment Protocol (..), Server (..), TestingMode (..), - PassthroughEnvVars (..), serverUrl, ) where @@ -18,7 +17,6 @@ import Data.Text qualified as T import Data.Word import Database.PostgreSQL.Simple.Options (Options) import Harness.Logging.Messages -import Harness.PassthroughEnvVars import Harness.Services.Composed qualified as Services import Harness.Test.BackendType import Hasura.Prelude @@ -35,9 +33,6 @@ data GlobalTestEnvironment = GlobalTestEnvironment server :: Server, -- | The protocol with which we make server requests. requestProtocol :: Protocol, - -- | Any environment variable names we wish to pass through to any new HGE - -- instance - passthroughEnvVars :: PassthroughEnvVars, servicesConfig :: Services.TestServicesConfig } @@ -57,9 +52,13 @@ instance Has Services.PostgresServerUrl GlobalTestEnvironment where getter = getter . getter @Services.TestServicesConfig modifier f = modifier (modifier @_ @Services.TestServicesConfig f) -instance Has PassthroughEnvVars GlobalTestEnvironment where - getter = passthroughEnvVars - modifier f x = x {passthroughEnvVars = f (passthroughEnvVars x)} +instance Has Services.PassthroughEnvVars GlobalTestEnvironment where + getter = getter . getter @Services.TestServicesConfig + modifier f = modifier (modifier @_ @Services.TestServicesConfig f) + +instance Has Services.HgePool GlobalTestEnvironment where + getter = getter . getter @Services.TestServicesConfig + modifier f = modifier (modifier @_ @Services.TestServicesConfig f) instance Has Services.HgeServerInstance GlobalTestEnvironment where getter ge = diff --git a/server/lib/test-harness/src/Harness/PassthroughEnvVars.hs b/server/lib/test-harness/src/Harness/PassthroughEnvVars.hs deleted file mode 100644 index 2a3e63f79d4..00000000000 --- a/server/lib/test-harness/src/Harness/PassthroughEnvVars.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | PassthroughEnvVars separated into own file for circular dep reasons -module Harness.PassthroughEnvVars - ( PassthroughEnvVars (..), - ) -where - -import Hasura.Prelude - --- | When spawning new HGE instances from a binary, we may want to pass through --- some environment variables (for database credentials, for instance). -newtype PassthroughEnvVars - = PassthroughEnvVars [(String, String)] diff --git a/server/lib/test-harness/src/Harness/Services/Composed.hs b/server/lib/test-harness/src/Harness/Services/Composed.hs index a2e5bd75cb1..a23c2eaa83a 100644 --- a/server/lib/test-harness/src/Harness/Services/Composed.hs +++ b/server/lib/test-harness/src/Harness/Services/Composed.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + module Harness.Services.Composed ( module I, TestServicesConfig (..), @@ -7,8 +9,12 @@ where import Data.Has import Data.Text qualified as T +import Harness.Constants qualified as Constants +import Harness.Logging import Harness.Services.Database.Postgres as I +import Harness.Services.ExternalProcess.GraphqlEngine as I import Harness.Services.GraphqlEngine as I +import Harness.Services.GraphqlEngine.API as I import Harness.Services.Schema as I import Harness.Services.Source.Postgres as I import Hasura.Prelude @@ -18,11 +24,17 @@ import System.Environment -- | Keys/addresses to all resources managed externally to the test harness. data TestServicesConfig = TestServicesConfig { tscHgeBinPath :: HgeBinPath, + tscHgePool :: HgePool, + tscPassthroughEnvVars :: PassthroughEnvVars, tscPostgresServerUrl :: PostgresServerUrl -- Cockroach/Citus/... -- Bigquery credentials? } +instance Has HgePool TestServicesConfig where + getter = tscHgePool + modifier f x = x {tscHgePool = f (tscHgePool x)} + instance Has HgeBinPath TestServicesConfig where getter = tscHgeBinPath modifier f x = x {tscHgeBinPath = f (tscHgeBinPath x)} @@ -31,21 +43,45 @@ instance Has PostgresServerUrl TestServicesConfig where getter = tscPostgresServerUrl modifier f x = x {tscPostgresServerUrl = f (tscPostgresServerUrl x)} -mkTestServicesConfig :: IO TestServicesConfig -mkTestServicesConfig = do +instance Has PassthroughEnvVars TestServicesConfig where + getter = tscPassthroughEnvVars + modifier f x = x {tscPassthroughEnvVars = f (tscPassthroughEnvVars x)} + +mkTestServicesConfig :: Logger -> IO TestServicesConfig +mkTestServicesConfig logger = do let var = "GRAPHQL_ENGINE" hgeBinPath <- lookupEnv var `onNothingM` error ("Environment variable '" ++ var ++ "' not specified.") let tscHgeBinPath = HgeBinPath hgeBinPath + tscHgePool <- mkHgeInstancePool logger + exists <- doesFileExist hgeBinPath unless exists $ error ("(" ++ var ++ ") The file '" ++ hgeBinPath ++ "' does not exist.") permissions <- getPermissions hgeBinPath unless (executable permissions) $ error ("(" ++ var ++ ") The file '" ++ hgeBinPath ++ "' is not executable.") + tscPassthroughEnvVars <- mkPassthroughEnv + let tscPostgresServerUrl = PostgresServerUrl $ T.pack postgresqlInitialConnectionString pure TestServicesConfig {..} postgresqlInitialConnectionString :: String postgresqlInitialConnectionString = "postgres://hasura:hasura@127.0.0.1:65002/hasura_metadata" + +-- | when running HGE via a binary, what should we pass through from the test's +-- environment into the fresh HGE? +envToPassthrough :: [String] +envToPassthrough = + [ Constants.bigqueryServiceKeyVar, + "HASURA_GRAPHQL_EE_LICENSE_KEY" + ] + +-- | grab items from env to pass through to new HGE instances +mkPassthroughEnv :: IO PassthroughEnvVars +mkPassthroughEnv = + let lookup' env = do + value <- fromMaybe "" <$> lookupEnv env + pure (env, value) + in PassthroughEnvVars <$> traverse lookup' envToPassthrough diff --git a/server/lib/test-harness/src/Harness/Services/Database/Postgres.hs b/server/lib/test-harness/src/Harness/Services/Database/Postgres.hs index 5ef8a4ec953..8ddcb736cc1 100644 --- a/server/lib/test-harness/src/Harness/Services/Database/Postgres.hs +++ b/server/lib/test-harness/src/Harness/Services/Database/Postgres.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE QuasiQuotes #-} -- | This module houses low-level functions and types to help access and work @@ -42,6 +43,9 @@ import Test.Hspec newtype PostgresServerUrl = PostgresServerUrl {getPostgresServerUrl :: Text} deriving newtype (ToJSON) + deriving (Eq, Generic) + +instance Hashable PostgresServerUrl newtype FreshPostgresDb = FreshPostgresDb {freshDbName :: Text} diff --git a/server/lib/test-harness/src/Harness/Services/ExternalProcess/GraphqlEngine.hs b/server/lib/test-harness/src/Harness/Services/ExternalProcess/GraphqlEngine.hs new file mode 100644 index 00000000000..0fe8a650f6a --- /dev/null +++ b/server/lib/test-harness/src/Harness/Services/ExternalProcess/GraphqlEngine.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module houses low-level functions and types to help access and work +-- with Graphql Engine. +module Harness.Services.ExternalProcess.GraphqlEngine + ( -- * Types + HgeBinPath (..), + HgeConfig (..), + emptyHgeConfig, + PassthroughEnvVars (..), + + -- * Direct spawning + spawnServer, + + -- * Pooled access + HgePool, + mkHgeInstancePool, + drawFromPool, + ) +where + +import Control.Concurrent (forkIO) +import Control.Concurrent.Async qualified as Async +import Control.Concurrent.MVar +import Control.Lens +import Control.Monad.Managed +import Data.Aeson qualified as J +import Data.Attoparsec.ByteString as Atto +import Data.ByteString qualified as BS +import Data.Has +import Data.HashMap.Strict qualified as HashMap +import Data.IORef +import Data.Pool +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8) +import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) +import Data.Vector (fromList) +import Harness.Exceptions +import Harness.Http qualified as Http +import Harness.Logging +import Harness.Services.Database.Postgres +import Harness.Services.GraphqlEngine.API +import Hasura.Prelude +import Network.HTTP.Simple qualified as Http +import Network.Socket qualified as Socket +import Network.Wai.Handler.Warp qualified as Warp +import System.Exit (ExitCode) +import System.IO +import System.Process + +-- | The path to the 'graphql-engine' executable. +newtype HgeBinPath = HgeBinPath FilePath + deriving (Eq, Generic) + +instance Hashable HgeBinPath + +data HgeConfig = HgeConfig + { hgeConfigEnvironmentVars :: [(String, String)] + } + deriving (Eq, Generic) + +instance Hashable HgeConfig + +-- | When spawning new HGE instances from a binary, we may want to pass through +-- some environment variables (for database credentials, for instance). +newtype PassthroughEnvVars + = PassthroughEnvVars [(String, String)] + deriving (Eq, Generic) + +instance Hashable PassthroughEnvVars + +emptyHgeConfig :: HgeConfig +emptyHgeConfig = HgeConfig [] + +data HgePoolArguments = HgePoolArguments + { _hpaConfig :: HgeConfig, + _hpaPostgresServerUrl :: PostgresServerUrl, + _hpaBinPath :: HgeBinPath, + _hpaPassthroughEnvVars :: PassthroughEnvVars + } + deriving (Eq, Generic) + +instance Hashable HgePoolArguments + +$(makeLenses ''HgePoolArguments) + +instance Has HgeConfig HgePoolArguments where + hasLens = hpaConfig + +instance Has PostgresServerUrl HgePoolArguments where + hasLens = hpaPostgresServerUrl + +instance Has HgeBinPath HgePoolArguments where + hasLens = hpaBinPath + +instance Has PassthroughEnvVars HgePoolArguments where + hasLens = hpaPassthroughEnvVars + +data HgeServerHandle = HgeServerHandle + { hshInstance :: HgeServerInstance, + hshDestroy :: IO () + } + +newtype HgePool = HgePool {getHgePool :: HgePoolArguments -> IO (Pool HgeServerHandle)} + +mkHgeInstancePool :: Logger -> IO HgePool +mkHgeInstancePool logger = do + poolsMVar <- newMVar (mempty :: HashMap.HashMap HgePoolArguments (Pool HgeServerHandle)) + return $ HgePool \args -> do + pools <- takeMVar poolsMVar + case HashMap.lookup args pools of + Nothing -> do + pool <- createPool (serverHandle args) hshDestroy 1 60.0 5 + putMVar poolsMVar (HashMap.insert args pool pools) + return pool + Just pool -> do + putMVar poolsMVar pools + return pool + where + serverHandle :: HgePoolArguments -> IO HgeServerHandle + serverHandle args = do + (hge, cleanup) <- unmanage (spawnServer (logger, args) (_hpaConfig args)) + return $ HgeServerHandle hge cleanup + +unmanage :: Managed a -> IO (a, IO ()) +unmanage act = do + resMVar <- newEmptyMVar + cleanupMVar <- newEmptyMVar + _ <- forkIO $ runManaged $ do + res <- act + liftIO $ do + putMVar resMVar res + takeMVar cleanupMVar + + res <- takeMVar resMVar + return (res, putMVar cleanupMVar ()) + +withPool :: + Has Logger testEnvironment => + testEnvironment -> + HgePool -> + HgePoolArguments -> + (HgeServerInstance -> IO a) -> + IO a +withPool env mkPool args k = do + pool <- getHgePool mkPool args + withResource + pool + ( \h -> do + metadata <- export_metadata (hshInstance h, env) + k (hshInstance h) + `finally` void (replace_metadata (hshInstance h, env) metadata) + ) + +drawFromPool :: + ( Has PostgresServerUrl testEnvironment, + Has Logger testEnvironment, + Has HgeBinPath testEnvironment, + Has PassthroughEnvVars testEnvironment, + Has HgePool testEnvironment + ) => + testEnvironment -> + HgeConfig -> + Managed HgeServerInstance +drawFromPool env config = + managed + ( withPool + env + (getter env) + HgePoolArguments + { _hpaConfig = config, + _hpaPostgresServerUrl = getter env, + _hpaBinPath = getter env, + _hpaPassthroughEnvVars = getter env + } + ) + +-- | spin up a Manager HGE instance and check it is healthy +spawnServer :: + ( Has PostgresServerUrl testEnvironment, + Has Logger testEnvironment, + Has HgeBinPath testEnvironment, + Has PassthroughEnvVars testEnvironment + ) => + testEnvironment -> + HgeConfig -> + Managed HgeServerInstance +spawnServer testEnv (HgeConfig {hgeConfigEnvironmentVars}) = do + let (HgeBinPath hgeBinPath) = getter testEnv + pgUrl = getter testEnv + (PassthroughEnvVars envVars) = getter testEnv + freshDb <- mkFreshPostgresDb testEnv + let allEnv = hgeConfigEnvironmentVars <> envVars + metadataDbUrl = mkFreshDbConnectionString pgUrl freshDb + ((_, Just hgeStdOut, Just hgeStdErr, _), port) <- + managed + ( bracket + ( do + port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst) + testLogMessage testEnv $ HgeInstanceStartMessage port + + process <- + createProcess + ( proc + hgeBinPath + [ "serve", + "--enable-console", + "--server-port", + show port, + "--metadata-database-url", + T.unpack (getPostgresServerUrl metadataDbUrl) + ] + ) + { env = + Just $ + ("HASURA_GRAPHQL_GRACEFUL_SHUTDOWN_TIMEOUT", "0") + : ("HASURA_GRAPHQL_ADMIN_SECRET", T.unpack adminSecret) + : allEnv, + std_out = CreatePipe, + std_err = CreatePipe, + create_group = True + } + `catchAny` ( \exn -> + error $ + unlines + [ "Failed to spawn Graphql-Engine process:", + show exn + ] + ) + return $ (process, port) + ) + ( \(process@(_, _, _, ph), port) -> forkIO $ do + startTime <- getCurrentTime + interruptProcessGroupOf ph + exitCode <- waitForProcess ph + cleanupProcess process + endTime <- getCurrentTime + testLogMessage testEnv $ HgeInstanceShutdownMessage port exitCode (diffUTCTime endTime startTime) + ) + ) + let logger = getter @Logger testEnv + hgeLogRelayThread logger hgeStdOut + hgeStdErrRelayThread logger hgeStdErr + liftIO do + let server = HgeServerInstance "127.0.0.1" port adminSecret + result <- Http.healthCheck' (T.unpack $ getHgeServerInstanceUrl server <> "/healthz") + case result of + Http.Healthy -> pure server + Http.Unhealthy failures -> do + runLogger logger $ HgeInstanceFailedHealthcheckMessage failures + error "Graphql-Engine failed http healthcheck." + where + adminSecret :: Text + adminSecret = "top-secret" + +-- | Log message type used to indicate a HGE server instance has started. +data HgeInstanceStartMessage = HgeInstanceStartMessage {hiStartPort :: Int} + +instance LoggableMessage HgeInstanceStartMessage where + fromLoggableMessage HgeInstanceStartMessage {..} = + J.object + [ ("type", J.String "HgeInstanceStartMessage"), + ("port", J.Number (fromIntegral hiStartPort)) + ] + +-- | Log message type used to indicate a HGE server instance failed the +-- healthcheck. +data HgeInstanceFailedHealthcheckMessage = HgeInstanceFailedHealthcheckMessage + {hisfFailures :: [Http.HttpException]} + +instance LoggableMessage HgeInstanceFailedHealthcheckMessage where + fromLoggableMessage HgeInstanceFailedHealthcheckMessage {..} = + J.object + [ ("type", J.String "HgeInstanceFailedHealthcheckMessage"), + ("failures", J.Array (fromList (map (J.String . tshow) hisfFailures))) + ] + +-- | Log message type used to indicate a HGE server instance has shutdown. +data HgeInstanceShutdownMessage = HgeInstanceShutdownMessage + { hiShutdownPort :: Int, + hiShutdownExitCode :: ExitCode, + hiShutdownDuration :: NominalDiffTime + } + +instance LoggableMessage HgeInstanceShutdownMessage where + fromLoggableMessage HgeInstanceShutdownMessage {..} = + J.object + [ ("type", J.String "HgeInstanceShutdownMessage"), + ("port", J.Number (fromIntegral hiShutdownPort)), + ("duration", J.Number (realToFrac hiShutdownDuration)), + ("exit-code", J.String (tshow hiShutdownExitCode)) + ] + +-- | Log message type used to indicate a single log-J.object output by a HGE +-- server instance (on StdOut). +data HgeLogMessage = HgeLogMessage {hgeLogMessage :: J.Value} + +instance LoggableMessage HgeLogMessage where + fromLoggableMessage HgeLogMessage {..} = + J.object + [ ("type", J.String "HgeLogMessage"), + ("message", hgeLogMessage) + ] + +-- | Log message type used to indicate a chunk of log output text by a HGE +-- server instance which could not be parsed as a json J.object. +data HgeUnparsableLogMessage = HgeUnparsableLogMessage {hgeUnparsableLogMessage :: Text} + +instance LoggableMessage HgeUnparsableLogMessage where + fromLoggableMessage HgeUnparsableLogMessage {..} = + J.object + [ ("type", J.String "HgeUnparsableLogMessage"), + ("message", J.String hgeUnparsableLogMessage) + ] + +-- | Log message type used to indicate a single line output by a HGE server +-- instance on StdErr. +data HgeStdErrLogMessage = HgeStdErrLogMessage {hgeStdErrLogMessage :: Text} + +instance LoggableMessage HgeStdErrLogMessage where + fromLoggableMessage HgeStdErrLogMessage {..} = + J.object + [ ("type", J.String "HgeStdErrLogMessage"), + ("message", J.String hgeStdErrLogMessage) + ] + +-- | A thread that reads from the engine's StdErr handle and makes one test-log +-- message per line. +hgeStdErrRelayThread :: Logger -> Handle -> Managed () +hgeStdErrRelayThread logger hgeOutput = do + _ <- + managed + ( bracket + ( Async.async $ forever $ do + nextChunk <- BS.hGetLine hgeOutput + runLogger logger $ HgeStdErrLogMessage (decodeUtf8 nextChunk) + ) + Async.cancel + ) + return () + +-- | A thread that reads from the engine's StdOut handle and makes one test-log +-- message per json-J.object, on a best-effort basis. +hgeLogRelayThread :: Logger -> Handle -> Managed () +hgeLogRelayThread logger hgeOutput = do + resultRef <- liftIO $ newIORef (Atto.parse logParser "") + _ <- + managed + ( bracket + ( Async.async $ forever $ do + nextChunk <- (<> "\n") <$> BS.hGetLine hgeOutput + processChunk resultRef nextChunk + ) + ( \threadHandle -> do + Async.cancel threadHandle + processChunk resultRef "" + processChunk resultRef "" + ) + ) + return () + where + processChunk :: IORef (Atto.Result J.Value) -> BS.ByteString -> IO () + processChunk ref nextChunk = do + result <- readIORef ref + result' <- processDone result + case result' of + Atto.Fail {} -> do + runLogger logger $ HgeUnparsableLogMessage (tshow result) + writeIORef ref (Atto.parse logParser "") + processChunk ref nextChunk + Atto.Partial k -> do + result'' <- processDone (k nextChunk) + writeIORef ref result'' + Atto.Done {} -> + runLogger logger $ HgeUnparsableLogMessage "Impossible: Done{}-case in 'processChunk'" + + processDone :: Atto.Result J.Value -> IO (Atto.Result J.Value) + processDone result = + case result of + Atto.Done rest parsed -> do + runLogger logger $ HgeLogMessage parsed + if BS.empty == rest + then return $ Atto.parse logParser "" + else processDone $ Atto.parse logParser rest + _ -> return result + + logParser :: Atto.Parser J.Value + logParser = J.json' <* (option () (void (string "\n")) <|> endOfInput) diff --git a/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs b/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs index 37751cdbb49..c256f59e8d2 100644 --- a/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs +++ b/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs @@ -1,68 +1,26 @@ -- | This module houses low-level functions and types to help access and work -- with Graphql Engine. module Harness.Services.GraphqlEngine - ( HgeBinPath (..), - HgeServerInstance (..), - getHgeServerInstanceUrl, - HgeConfig (..), - withHge, - spawnServer, - emptyHgeConfig, - hgePost, - hgePostGraphql, - PostGraphql (..), + ( withHge, + withHgeSpawn, + module ExternalHge, + module HgeApi, ) where -import Control.Concurrent (forkIO) -import Control.Concurrent.Async qualified as Async import Control.Monad.Managed -import Data.Aeson qualified as J -import Data.Attoparsec.ByteString as Atto -import Data.ByteString qualified as BS import Data.Has -import Data.IORef -import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) -import Data.Vector (fromList) -import Harness.Exceptions -import Harness.Http qualified as Http import Harness.Logging -import Harness.PassthroughEnvVars import Harness.Services.Database.Postgres +import Harness.Services.ExternalProcess.GraphqlEngine as ExternalHge +import Harness.Services.GraphqlEngine.API as HgeApi import Harness.Test.CustomOptions import Harness.Yaml import Hasura.Prelude -import Network.HTTP.Simple qualified as Http -import Network.Socket qualified as Socket -import Network.Wai.Handler.Warp qualified as Warp -import System.Exit (ExitCode) -import System.IO -import System.Process import Test.Hspec --- | The path to the 'graphql-engine' executable. -newtype HgeBinPath = HgeBinPath FilePath - -data HgeConfig = HgeConfig - { hgeConfigEnvironmentVars :: [(String, String)] - } - -data HgeServerInstance = HgeServerInstance - { hgeServerHost :: Text, - hgeServerPort :: Int, - hgeAdminSecret :: Text - } - -getHgeServerInstanceUrl :: HgeServerInstance -> Text -getHgeServerInstanceUrl (HgeServerInstance {hgeServerHost, hgeServerPort}) = - "http://" <> hgeServerHost <> ":" <> tshow hgeServerPort <> "/" - -emptyHgeConfig :: HgeConfig -emptyHgeConfig = HgeConfig [] - --- | Spawn a graphql-engine instance with specific environment variables set. +-- | Draw a graphql-engine instance with specific environment variables set from +-- a pool of instances. -- -- The logs emitted by the engine process are embedded in the test logs. -- @@ -73,12 +31,35 @@ withHge :: ( Has HgeBinPath testEnvironment, Has PostgresServerUrl testEnvironment, Has Logger testEnvironment, - Has PassthroughEnvVars testEnvironment + Has PassthroughEnvVars testEnvironment, + Has HgePool testEnvironment ) => HgeConfig -> SpecWith (PostGraphql, (ShouldReturnYamlF, (HgeServerInstance, testEnvironment))) -> SpecWith testEnvironment withHge hgeConfig specs = do + flip aroundWith specs \action testEnvironment -> runManaged do + server <- drawFromPool testEnvironment hgeConfig + liftIO $ + action + ( PostGraphql (hgePostGraphql (server, testEnvironment)), + (ShouldReturnYamlF (shouldReturnYamlFInternal defaultOptions), (server, testEnvironment)) + ) + +-- | Spawn a fresh graphql-engine instance with specific environment variables set. +-- +-- For efficiency, prefer using 'withHge' instead of this function, unless the +-- pool somehow cannot work for your usecase. +withHgeSpawn :: + ( Has HgeBinPath testEnvironment, + Has PostgresServerUrl testEnvironment, + Has Logger testEnvironment, + Has PassthroughEnvVars testEnvironment + ) => + HgeConfig -> + SpecWith (PostGraphql, (ShouldReturnYamlF, (HgeServerInstance, testEnvironment))) -> + SpecWith testEnvironment +withHgeSpawn hgeConfig specs = do flip aroundWith specs \action testEnvironment -> runManaged do server <- spawnServer testEnvironment hgeConfig liftIO $ @@ -86,250 +67,3 @@ withHge hgeConfig specs = do ( PostGraphql (hgePostGraphql (server, testEnvironment)), (ShouldReturnYamlF (shouldReturnYamlFInternal defaultOptions), (server, testEnvironment)) ) - --- | spin up a Manager HGE instance and check it is healthy -spawnServer :: - ( Has PostgresServerUrl testEnvironment, - Has Logger testEnvironment, - Has HgeBinPath testEnvironment, - Has PassthroughEnvVars testEnvironment - ) => - testEnvironment -> - HgeConfig -> - Managed HgeServerInstance -spawnServer testEnv (HgeConfig {hgeConfigEnvironmentVars}) = do - let (HgeBinPath hgeBinPath) = getter testEnv - pgUrl = getter testEnv - (PassthroughEnvVars envVars) = getter testEnv - freshDb <- mkFreshPostgresDb testEnv - let allEnv = hgeConfigEnvironmentVars <> envVars - metadataDbUrl = mkFreshDbConnectionString pgUrl freshDb - ((_, Just hgeStdOut, Just hgeStdErr, _), port) <- - managed - ( bracket - ( do - port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst) - testLogMessage testEnv $ HgeInstanceStartMessage port - - process <- - createProcess - ( proc - hgeBinPath - [ "serve", - "--enable-console", - "--server-port", - show port, - "--metadata-database-url", - T.unpack (getPostgresServerUrl metadataDbUrl) - ] - ) - { env = - Just $ - ("HASURA_GRAPHQL_GRACEFUL_SHUTDOWN_TIMEOUT", "0") - : ("HASURA_GRAPHQL_ADMIN_SECRET", T.unpack adminSecret) - : allEnv, - std_out = CreatePipe, - std_err = CreatePipe, - create_group = True - } - `catchAny` ( \exn -> - error $ - unlines - [ "Failed to spawn Graphql-Engine process:", - show exn - ] - ) - return $ (process, port) - ) - ( \(process@(_, _, _, ph), port) -> forkIO $ do - startTime <- getCurrentTime - interruptProcessGroupOf ph - exitCode <- waitForProcess ph - cleanupProcess process - endTime <- getCurrentTime - testLogMessage testEnv $ HgeInstanceShutdownMessage port exitCode (diffUTCTime endTime startTime) - ) - ) - let logger = getter @Logger testEnv - hgeLogRelayThread logger hgeStdOut - hgeStdErrRelayThread logger hgeStdErr - liftIO do - let server = HgeServerInstance "127.0.0.1" port adminSecret - result <- Http.healthCheck' (T.unpack $ getHgeServerInstanceUrl server <> "/healthz") - case result of - Http.Healthy -> pure server - Http.Unhealthy failures -> do - runLogger logger $ HgeInstanceFailedHealthcheckMessage failures - error "Graphql-Engine failed http healthcheck." - where - adminSecret :: Text - adminSecret = "top-secret" - --- | Log message type used to indicate a HGE server instance has started. -data HgeInstanceStartMessage = HgeInstanceStartMessage {hiStartPort :: Int} - -instance LoggableMessage HgeInstanceStartMessage where - fromLoggableMessage HgeInstanceStartMessage {..} = - J.object - [ ("type", J.String "HgeInstanceStartMessage"), - ("port", J.Number (fromIntegral hiStartPort)) - ] - --- | Log message type used to indicate a HGE server instance failed the --- healthcheck. -data HgeInstanceFailedHealthcheckMessage = HgeInstanceFailedHealthcheckMessage - {hisfFailures :: [Http.HttpException]} - -instance LoggableMessage HgeInstanceFailedHealthcheckMessage where - fromLoggableMessage HgeInstanceFailedHealthcheckMessage {..} = - J.object - [ ("type", J.String "HgeInstanceFailedHealthcheckMessage"), - ("failures", J.Array (fromList (map (J.String . tshow) hisfFailures))) - ] - --- | Log message type used to indicate a HGE server instance has shutdown. -data HgeInstanceShutdownMessage = HgeInstanceShutdownMessage - { hiShutdownPort :: Int, - hiShutdownExitCode :: ExitCode, - hiShutdownDuration :: NominalDiffTime - } - -instance LoggableMessage HgeInstanceShutdownMessage where - fromLoggableMessage HgeInstanceShutdownMessage {..} = - J.object - [ ("type", J.String "HgeInstanceShutdownMessage"), - ("port", J.Number (fromIntegral hiShutdownPort)), - ("duration", J.Number (realToFrac hiShutdownDuration)), - ("exit-code", J.String (tshow hiShutdownExitCode)) - ] - --- | Log message type used to indicate a single log-J.object output by a HGE --- server instance (on StdOut). -data HgeLogMessage = HgeLogMessage {hgeLogMessage :: J.Value} - -instance LoggableMessage HgeLogMessage where - fromLoggableMessage HgeLogMessage {..} = - J.object - [ ("type", J.String "HgeLogMessage"), - ("message", hgeLogMessage) - ] - --- | Log message type used to indicate a chunk of log output text by a HGE --- server instance which could not be parsed as a json J.object. -data HgeUnparsableLogMessage = HgeUnparsableLogMessage {hgeUnparsableLogMessage :: Text} - -instance LoggableMessage HgeUnparsableLogMessage where - fromLoggableMessage HgeUnparsableLogMessage {..} = - J.object - [ ("type", J.String "HgeUnparsableLogMessage"), - ("message", J.String hgeUnparsableLogMessage) - ] - --- | Log message type used to indicate a single line output by a HGE server --- instance on StdErr. -data HgeStdErrLogMessage = HgeStdErrLogMessage {hgeStdErrLogMessage :: Text} - -instance LoggableMessage HgeStdErrLogMessage where - fromLoggableMessage HgeStdErrLogMessage {..} = - J.object - [ ("type", J.String "HgeStdErrLogMessage"), - ("message", J.String hgeStdErrLogMessage) - ] - --- | A thread that reads from the engine's StdErr handle and makes one test-log --- message per line. -hgeStdErrRelayThread :: Logger -> Handle -> Managed () -hgeStdErrRelayThread logger hgeOutput = do - _ <- - managed - ( bracket - ( Async.async $ forever $ do - nextChunk <- BS.hGetLine hgeOutput - runLogger logger $ HgeStdErrLogMessage (decodeUtf8 nextChunk) - ) - Async.cancel - ) - return () - --- | A thread that reads from the engine's StdOut handle and makes one test-log --- message per json-J.object, on a best-effort basis. -hgeLogRelayThread :: Logger -> Handle -> Managed () -hgeLogRelayThread logger hgeOutput = do - resultRef <- liftIO $ newIORef (Atto.parse logParser "") - _ <- - managed - ( bracket - ( Async.async $ forever $ do - nextChunk <- (<> "\n") <$> BS.hGetLine hgeOutput - processChunk resultRef nextChunk - ) - ( \threadHandle -> do - Async.cancel threadHandle - processChunk resultRef "" - processChunk resultRef "" - ) - ) - return () - where - processChunk :: IORef (Atto.Result J.Value) -> BS.ByteString -> IO () - processChunk ref nextChunk = do - result <- readIORef ref - result' <- processDone result - case result' of - Atto.Fail {} -> do - runLogger logger $ HgeUnparsableLogMessage (tshow result) - writeIORef ref (Atto.parse logParser "") - processChunk ref nextChunk - Atto.Partial k -> do - result'' <- processDone (k nextChunk) - writeIORef ref result'' - Atto.Done {} -> - runLogger logger $ HgeUnparsableLogMessage "Impossible: Done{}-case in 'processChunk'" - - processDone :: Atto.Result J.Value -> IO (Atto.Result J.Value) - processDone result = - case result of - Atto.Done rest parsed -> do - runLogger logger $ HgeLogMessage parsed - if BS.empty == rest - then return $ Atto.parse logParser "" - else processDone $ Atto.parse logParser rest - _ -> return result - - logParser :: Atto.Parser J.Value - logParser = J.json' <* (option () (void (string "\n")) <|> endOfInput) - -hgePost :: - ( Has HgeServerInstance env, - Has Logger env - ) => - env -> - Int -> - Text -> - Http.RequestHeaders -> - J.Value -> - IO J.Value -hgePost env statusCode path headers requestBody = do - let hgeInstance = getter @HgeServerInstance env - let hgeUrl = getHgeServerInstanceUrl hgeInstance - let adminSecret = hgeAdminSecret hgeInstance - let fullUrl = T.unpack $ hgeUrl <> path - testLogMessage env $ LogHGERequest path requestBody - let headersWithAdmin = ("x-hasura-admin-secret", encodeUtf8 adminSecret) : headers - responseBody <- withFrozenCallStack $ Http.postValueWithStatus statusCode fullUrl headersWithAdmin requestBody - testLogMessage env $ LogHGEResponse path responseBody - return responseBody - -hgePostGraphql :: - ( Has HgeServerInstance env, - Has Logger env - ) => - env -> - J.Value -> - IO J.Value -hgePostGraphql env query = do - hgePost env 200 "/v1/graphql" [] (J.object ["query" J..= query]) - --- | Newtype-wrapper which enables late binding of 'postGraphql' on the test environment. --- This makes 'TestEnvironment'-based specs more readily compatible with componontised fixtures. -newtype PostGraphql = PostGraphql {getPostGraphql :: J.Value -> IO J.Value} diff --git a/server/lib/test-harness/src/Harness/Services/GraphqlEngine/API.hs b/server/lib/test-harness/src/Harness/Services/GraphqlEngine/API.hs new file mode 100644 index 00000000000..2e471e24035 --- /dev/null +++ b/server/lib/test-harness/src/Harness/Services/GraphqlEngine/API.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | This module houses low-level functions and types to help access and work +-- with the hge api. +module Harness.Services.GraphqlEngine.API + ( -- * Types + HgeServerInstance (..), + getHgeServerInstanceUrl, + PostGraphql (..), + + -- * Api actions + hgePost, + hgePostGraphql, + export_metadata, + replace_metadata, + ) +where + +import Data.Aeson +import Data.Aeson qualified as J +import Data.Has +import Data.Text qualified as T +import Data.Text.Encoding (encodeUtf8) +import Harness.Exceptions +import Harness.Http qualified as Http +import Harness.Logging.Messages +import Harness.Quoter.Yaml (yaml) +import Hasura.Prelude + +data HgeServerInstance = HgeServerInstance + { hgeServerHost :: Text, + hgeServerPort :: Int, + hgeAdminSecret :: Text + } + +getHgeServerInstanceUrl :: HgeServerInstance -> Text +getHgeServerInstanceUrl (HgeServerInstance {hgeServerHost, hgeServerPort}) = + "http://" <> hgeServerHost <> ":" <> tshow hgeServerPort <> "/" + +-- | Newtype-wrapper which enables late binding of 'postGraphql' on the test environment. +-- This makes 'TestEnvironment'-based specs more readily compatible with componontised fixtures. +newtype PostGraphql = PostGraphql {getPostGraphql :: J.Value -> IO J.Value} + +export_metadata :: (Has Logger env, Has HgeServerInstance env) => env -> IO Value +export_metadata env = do + hgePost + env + 200 + "/v1/metadata" + [] + [yaml| + type: export_metadata + args: null + |] + +replace_metadata :: (Has Logger env, Has HgeServerInstance env) => env -> Value -> IO Value +replace_metadata env newMetadata = do + hgePost + env + 200 + "/v1/metadata" + [] + [yaml| + type: replace_metadata + args: + allow_inconsistent_metadata: true + metadata: *newMetadata + |] + +hgePost :: + ( Has HgeServerInstance env, + Has Logger env + ) => + env -> + Int -> + Text -> + Http.RequestHeaders -> + J.Value -> + IO J.Value +hgePost env statusCode path headers requestBody = do + let hgeInstance = getter @HgeServerInstance env + let hgeUrl = getHgeServerInstanceUrl hgeInstance + let adminSecret = hgeAdminSecret hgeInstance + let fullUrl = T.unpack $ hgeUrl <> path + testLogMessage env $ LogHGERequest path requestBody + let headersWithAdmin = ("x-hasura-admin-secret", encodeUtf8 adminSecret) : headers + responseBody <- withFrozenCallStack $ Http.postValueWithStatus statusCode fullUrl headersWithAdmin requestBody + testLogMessage env $ LogHGEResponse path responseBody + return responseBody + +hgePostGraphql :: + ( Has HgeServerInstance env, + Has Logger env + ) => + env -> + J.Value -> + IO J.Value +hgePostGraphql env query = do + hgePost env 200 "/v1/graphql" [] (J.object ["query" J..= query]) diff --git a/server/lib/test-harness/src/Harness/Services/Metadata.hs b/server/lib/test-harness/src/Harness/Services/Metadata.hs deleted file mode 100644 index 584de0f271a..00000000000 --- a/server/lib/test-harness/src/Harness/Services/Metadata.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - --- | This module houses low-level functions and types to help access and work --- with the hge metadata api. -module Harness.Services.Metadata (export_metadata, replace_metadata) where - -import Data.Aeson -import Data.Has -import Harness.Logging -import Harness.Quoter.Yaml (yaml) -import Harness.Services.GraphqlEngine -import Hasura.Prelude - -export_metadata :: (Has Logger env, Has HgeServerInstance env) => env -> IO Value -export_metadata env = do - hgePost - env - 200 - "/v1/metadata" - [] - [yaml| - type: export_metadata - args: null - |] - -replace_metadata :: (Has Logger env, Has HgeServerInstance env) => env -> Value -> IO Value -replace_metadata env newMetadata = do - hgePost - env - 200 - "/v1/metadata" - [] - [yaml| - type: replace_metadata - args: - allow_inconsistent_metadata: true - metadata: *newMetadata - |] diff --git a/server/lib/test-harness/src/Harness/TestEnvironment.hs b/server/lib/test-harness/src/Harness/TestEnvironment.hs index 67fb1fff9f4..862e9e6986d 100644 --- a/server/lib/test-harness/src/Harness/TestEnvironment.hs +++ b/server/lib/test-harness/src/Harness/TestEnvironment.hs @@ -5,7 +5,6 @@ module Harness.TestEnvironment ( TestEnvironment (..), GlobalTestEnvironment (..), - PassthroughEnvVars (..), Protocol (..), Server (..), TestingMode (..), @@ -107,7 +106,7 @@ instance Has Services.PostgresServerUrl TestEnvironment where getter = getter . getter @GlobalTestEnvironment modifier f = modifier (modifier @_ @GlobalTestEnvironment f) -instance Has PassthroughEnvVars TestEnvironment where +instance Has Services.PassthroughEnvVars TestEnvironment where getter = getter . getter @GlobalTestEnvironment modifier f = modifier (modifier @_ @GlobalTestEnvironment f) diff --git a/server/lib/test-harness/test-harness.cabal b/server/lib/test-harness/test-harness.cabal index f90c63bb0c6..fcc0643f660 100644 --- a/server/lib/test-harness/test-harness.cabal +++ b/server/lib/test-harness/test-harness.cabal @@ -51,6 +51,7 @@ library , pretty-simple , process , refined + , resource-pool , resourcet , safe , safe-exceptions @@ -139,7 +140,6 @@ library Harness.Http Harness.Logging Harness.Logging.Messages - Harness.PassthroughEnvVars Harness.Permissions Harness.PytestPortedCompat Harness.Quoter.Graphql @@ -154,8 +154,9 @@ library Harness.Schema.Table Harness.Services.Composed Harness.Services.Database.Postgres + Harness.Services.ExternalProcess.GraphqlEngine Harness.Services.GraphqlEngine - Harness.Services.Metadata + Harness.Services.GraphqlEngine.API Harness.Services.Schema Harness.Services.Source.Postgres Harness.Subscriptions