[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,29 +21,22 @@ import Test.Hspec (SpecWith, describe, it)
 
 spec :: SpecWith GlobalTestEnvironment
 spec =
-  Fixture.run
+  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.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"
-                    }
+                  ]
               }
           ]
       )

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,24 +69,22 @@ 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
+    server <- spawnServer logger pgUrl hgeBin hgeConfig
+    liftIO $ action (server, a)
+
+-- | 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) <-
@@ -115,15 +124,24 @@ withHge HgeConfig {..} specs = do
               return $ (process, port)
           )
           ( \(process@(_, _, _, ph), port) -> do
+              startTime <- getCurrentTime
               interruptProcessGroupOf ph
               exitCode <- waitForProcess ph
               cleanupProcess process
-                  runLogger logger $ HgeInstanceShutdownMessage port exitCode
+              endTime <- getCurrentTime
+              runLogger logger $ HgeInstanceShutdownMessage port exitCode (diffUTCTime endTime startTime)
           )
       )
   hgeLogRelayThread logger hgeStdOut
   hgeStdErrRelayThread logger hgeStdErr
-      return port
+  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