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

@@ -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

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 =

server/lib/test-harness/src/Harness/PassthroughEnvVars.hs

@@ -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)]

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

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}
 

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)

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}

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])

server/lib/test-harness/src/Harness/Services/Metadata.hs

@@ -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
-      |]

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)
 

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