[server/tests] make useHge work with Fixtures

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7560
GitOrigin-RevId: 370e5b3ee4d508e7ca5eea426886bf6c82d0cde9

server/lib/api-tests/src/Test/Schema/ConflictsSpec.hs

@@ -21,33 +21,26 @@ import Test.Hspec (SpecWith, describe, it)
 
 spec :: SpecWith GlobalTestEnvironment
 spec =
-  Fixture.run
-    ( NE.fromList
-        [ (Fixture.fixture $ Fixture.Backend Postgres.backendTypeMetadata)
-            { Fixture.setupTeardown = \(testEnvironment, _) ->
-                [ Postgres.setupTablesAction schema testEnvironment
-                ],
-              Fixture.customOptions =
-                Just $
-                  Fixture.defaultOptions
-                    { Fixture.skipTests =
-                        Just "Disabled until we can dynamically change server settings per test. To test, add EFHideUpdateManyFields to soSubscriptions in Harness.Constants -> serveOptions"
-                    }
-            },
-          (Fixture.fixture $ Fixture.Backend Cockroach.backendTypeMetadata)
-            { Fixture.setupTeardown = \(testEnv, _) ->
-                [ Cockroach.setupTablesAction schema testEnv
-                ],
-              Fixture.customOptions =
-                Just $
-                  Fixture.defaultOptions
-                    { Fixture.skipTests =
-                        Just "Disabled until we can dynamically change server settings per test. To test, add EFHideUpdateManyFields to soSubscriptions in Harness.Constants -> serveOptions"
-                    }
-            }
-        ]
-    )
-    tests
+  Fixture.hgeWithEnv
+    [ ( "HASURA_GRAPHQL_EXPERIMENTAL_FEATURES",
+        "hide_update_many_fields"
+      )
+    ]
+    $ Fixture.run
+      ( NE.fromList
+          [ (Fixture.fixture $ Fixture.Backend Postgres.backendTypeMetadata)
+              { Fixture.setupTeardown = \(testEnvironment, _) ->
+                  [ Postgres.setupTablesAction schema testEnvironment
+                  ]
+              },
+            (Fixture.fixture $ Fixture.Backend Cockroach.backendTypeMetadata)
+              { Fixture.setupTeardown = \(testEnv, _) ->
+                  [ Cockroach.setupTablesAction schema testEnv
+                  ]
+              }
+          ]
+      )
+      tests
 
 --------------------------------------------------------------------------------
 -- Schema

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

@@ -2,8 +2,11 @@
 -- with Graphql Engine.
 module Harness.Services.GraphqlEngine
   ( HgeBinPath (..),
-    HgeServerInstance (getHgeServerInstanceUrl),
+    HgeServerInstance (..),
+    getHgeServerInstanceUrl,
+    HgeConfig (..),
     withHge,
+    spawnServer,
     emptyHgeConfig,
   )
 where
@@ -17,6 +20,7 @@ import Data.Has
 import Data.IORef
 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
@@ -38,7 +42,14 @@ data HgeConfig = HgeConfig
   { hgeConfigEnvironmentVars :: [(String, String)]
   }
 
-newtype HgeServerInstance = HgeServerInstance {getHgeServerInstanceUrl :: Text}
+data HgeServerInstance = HgeServerInstance
+  { hgeServerHost :: Text,
+    hgeServerPort :: Int
+  }
+
+getHgeServerInstanceUrl :: HgeServerInstance -> Text
+getHgeServerInstanceUrl (HgeServerInstance {hgeServerHost, hgeServerPort}) =
+  "http://" <> hgeServerHost <> ":" <> tshow hgeServerPort <> "/"
 
 emptyHgeConfig :: HgeConfig
 emptyHgeConfig = HgeConfig []
@@ -58,72 +69,79 @@ withHge ::
   HgeConfig ->
   SpecWith (HgeServerInstance, a) ->
   SpecWith a
-withHge HgeConfig {..} specs = do
+withHge hgeConfig specs = do
   flip aroundWith specs \action a -> runManaged do
     let hgeBin = getter a
         pgUrl = getter a
     let logger = getter @Logger a
-    port <- spawnServer logger pgUrl hgeBin
-    liftIO do
-      let urlPrefix = "http://127.0.0.1"
-      let server = HgeServerInstance (urlPrefix <> ":" <> tshow port <> "/")
-      result <- Http.healthCheck' (T.unpack $ getHgeServerInstanceUrl server)
-      case result of
-        Http.Healthy -> action (server, a)
-        Http.Unhealthy failures -> do
-          runLogger logger $ HgeInstanceFailedHealthcheckMessage failures
-          error "Graphql-Engine failed http healthcheck."
-  where
-    spawnServer :: Logger -> PostgresServerUrl -> HgeBinPath -> Managed Warp.Port
-    spawnServer logger pgUrl (HgeBinPath hgeBinPath) = do
-      freshDb <- mkFreshPostgresDb logger pgUrl
-      let metadataDbUrl = mkFreshDbConnectionString pgUrl freshDb
-      ((_, Just hgeStdOut, Just hgeStdErr, _), port) <-
-        managed
-          ( bracket
-              ( do
-                  port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst)
-                  runLogger logger $ HgeInstanceStartMessage port
+    server <- spawnServer logger pgUrl hgeBin hgeConfig
+    liftIO $ action (server, a)
 
-                  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")
-                                : hgeConfigEnvironmentVars,
-                          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) -> do
-                  interruptProcessGroupOf ph
-                  exitCode <- waitForProcess ph
-                  cleanupProcess process
-                  runLogger logger $ HgeInstanceShutdownMessage port exitCode
-              )
+-- | spin up a Manager HGE instance and check it is healthy
+spawnServer ::
+  Logger ->
+  PostgresServerUrl ->
+  HgeBinPath ->
+  HgeConfig ->
+  Managed HgeServerInstance
+spawnServer logger pgUrl (HgeBinPath hgeBinPath) (HgeConfig {hgeConfigEnvironmentVars}) = do
+  freshDb <- mkFreshPostgresDb logger pgUrl
+  let metadataDbUrl = mkFreshDbConnectionString pgUrl freshDb
+  ((_, Just hgeStdOut, Just hgeStdErr, _), port) <-
+    managed
+      ( bracket
+          ( do
+              port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst)
+              runLogger logger $ 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")
+                            : hgeConfigEnvironmentVars,
+                      std_out = CreatePipe,
+                      std_err = CreatePipe,
+                      create_group = True
+                    }
+                  `catchAny` ( \exn ->
+                                 error $
+                                   unlines
+                                     [ "Failed to spawn Graphql-Engine process:",
+                                       show exn
+                                     ]
+                             )
+              return $ (process, port)
           )
-      hgeLogRelayThread logger hgeStdOut
-      hgeStdErrRelayThread logger hgeStdErr
-      return port
+          ( \(process@(_, _, _, ph), port) -> do
+              startTime <- getCurrentTime
+              interruptProcessGroupOf ph
+              exitCode <- waitForProcess ph
+              cleanupProcess process
+              endTime <- getCurrentTime
+              runLogger logger $ HgeInstanceShutdownMessage port exitCode (diffUTCTime endTime startTime)
+          )
+      )
+  hgeLogRelayThread logger hgeStdOut
+  hgeStdErrRelayThread logger hgeStdErr
+  liftIO do
+    let server = HgeServerInstance "127.0.0.1" port
+    result <- Http.healthCheck' (T.unpack $ getHgeServerInstanceUrl server)
+    case result of
+      Http.Healthy -> pure server
+      Http.Unhealthy failures -> do
+        runLogger logger $ HgeInstanceFailedHealthcheckMessage failures
+        error "Graphql-Engine failed http healthcheck."
 
 -- | Log message type used to indicate a HGE server instance has started.
 data HgeInstanceStartMessage = HgeInstanceStartMessage {hiStartPort :: Int}
@@ -150,7 +168,8 @@ instance LoggableMessage HgeInstanceFailedHealthcheckMessage where
 -- | Log message type used to indicate a HGE server instance has shutdown.
 data HgeInstanceShutdownMessage = HgeInstanceShutdownMessage
   { hiShutdownPort :: Int,
-    hiShutdownExitCode :: ExitCode
+    hiShutdownExitCode :: ExitCode,
+    hiShutdownDuration :: NominalDiffTime
   }
 
 instance LoggableMessage HgeInstanceShutdownMessage where
@@ -158,6 +177,7 @@ instance LoggableMessage HgeInstanceShutdownMessage where
     object
       [ ("type", String "HgeInstanceShutdownMessage"),
         ("port", Number (fromIntegral hiShutdownPort)),
+        ("duration", Number (realToFrac hiShutdownDuration)),
         ("exit-code", String (tshow hiShutdownExitCode))
       ]
 

server/lib/test-harness/src/Harness/Test/Fixture.hs

@@ -10,6 +10,7 @@ module Harness.Test.Fixture
     runWithLocalTestEnvironment,
     runWithLocalTestEnvironmentSingleSetup,
     runWithLocalTestEnvironmentInternal,
+    hgeWithEnv,
     createDatabases,
     Fixture (..),
     fixture,
@@ -31,8 +32,10 @@ module Harness.Test.Fixture
   )
 where
 
+import Control.Concurrent.Async qualified as Async
 import Control.Monad.Managed (Managed, runManaged, with)
 import Data.Aeson (Value)
+import Data.Has (getter)
 import Data.Set qualified as S
 import Data.Text qualified as T
 import Data.UUID.V4 (nextRandom)
@@ -42,6 +45,7 @@ import Harness.Backend.Postgres qualified as Postgres
 import Harness.Backend.Sqlserver qualified as Sqlserver
 import Harness.Exceptions
 import Harness.Logging
+import Harness.Services.GraphqlEngine
 import Harness.Test.BackendType
 import Harness.Test.CustomOptions
 import Harness.Test.FixtureName
@@ -49,7 +53,7 @@ import Harness.Test.SetupAction (SetupAction (..))
 import Harness.Test.SetupAction qualified as SetupAction
 import Harness.TestEnvironment
   ( GlobalTestEnvironment (..),
-    Server,
+    Server (..),
     TestEnvironment (..),
     TestingMode (..),
     UniqueTestId (..),
@@ -86,7 +90,34 @@ import Test.Hspec
 run :: NonEmpty (Fixture ()) -> (Options -> SpecWith TestEnvironment) -> SpecWith GlobalTestEnvironment
 run = runSingleSetup
 
--- runWithLocalTestEnvironment fixtures (\opts -> beforeWith (\(te, ()) -> return te) (tests opts))
+-- given a fresh HgeServerInstance, add it in our `TestEnvironment`
+useHgeInTestEnvironment :: GlobalTestEnvironment -> HgeServerInstance -> IO GlobalTestEnvironment
+useHgeInTestEnvironment globalTestEnvironment (HgeServerInstance {hgeServerHost, hgeServerPort}) = do
+  serverThreadIrrelevant <- Async.async (return ())
+  let server =
+        Server
+          { port = fromIntegral hgeServerPort,
+            urlPrefix = "http://" <> T.unpack hgeServerHost,
+            thread = serverThreadIrrelevant
+          }
+  pure $ globalTestEnvironment {server = server}
+
+-- | Start an instance of HGE which has certain environment variables defined
+-- and pass it around inside the `GlobalTestEnvironment`
+hgeWithEnv :: [(String, String)] -> SpecWith GlobalTestEnvironment -> SpecWith GlobalTestEnvironment
+hgeWithEnv env = do
+  let hgeConfig = emptyHgeConfig {hgeConfigEnvironmentVars = env}
+
+  aroundAllWith
+    ( \specs globalTestEnvironment -> runManaged $ do
+        hgeServerInstance <-
+          spawnServer
+            (getter globalTestEnvironment)
+            (getter globalTestEnvironment)
+            (getter globalTestEnvironment)
+            hgeConfig
+        liftIO $ useHgeInTestEnvironment globalTestEnvironment hgeServerInstance >>= specs
+    )
 
 {-# DEPRECATED runSingleSetup "runSingleSetup lets all specs in aFixture share a single database environment, which impedes parallelisation and out-of-order execution." #-}
 runSingleSetup :: NonEmpty (Fixture ()) -> (Options -> SpecWith TestEnvironment) -> SpecWith GlobalTestEnvironment
@@ -273,10 +304,6 @@ runSetupActions logger acts = go acts []
       [] -> return (rethrowAll cleanupAcc)
       SetupAction {setupAction, teardownAction} : rest -> do
         a <- try setupAction
-        -- It would be nice to be able to log the execution of setup actions
-        -- into a logfile or similar.  Using `putStrLn` interferes with the
-        -- default Hspec test runner's output, so the lines below have been left
-        -- commented out.
         case a of
           Left (exn :: SomeException) -> do
             log $ LogFixtureSetupFailed (length cleanupAcc)

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

@@ -183,6 +183,9 @@ data Server = Server
     thread :: Async ()
   }
 
+instance Show Server where
+  show = serverUrl
+
 -- | Retrieve the 'Server' associated with some 'TestEnvironment'.
 getServer :: TestEnvironment -> Server
 getServer TestEnvironment {globalEnvironment} = server globalEnvironment