server/upgrade-tests: Avoid Docker host networking.

Instead, we update the metadata to point to the correct database URL each time we start HGE.

This means we can run the tests on macOS (and any other environment where Docker runs inside a VM).

I was hoping this would solve the issues we're seeing on CI too, but no such luck.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9528
GitOrigin-RevId: 32cbf65430462b4b0e59f5d644260f7c26c7135c

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE NumericUnderscores #-}
+
 -- | Helper functions for HTTP requests.
 module Harness.Http
   ( get_,
@@ -22,6 +24,7 @@ import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import GHC.Stack
 import Hasura.Prelude
+import Network.HTTP.Client.Conduit qualified as Http.Conduit
 import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types qualified as Http
 
@@ -59,9 +62,11 @@ postValue = postValueWithStatus 200
 post :: String -> Http.RequestHeaders -> Value -> IO (Http.Response L8.ByteString)
 post url headers value = do
   let request =
-        Http.setRequestHeaders headers
-          $ Http.setRequestMethod Http.methodPost
-          $ Http.setRequestBodyJSON value (fromString url)
+        fromString url
+          & Http.setRequestHeaders headers
+          & Http.setRequestMethod Http.methodPost
+          & Http.setRequestBodyJSON value
+          & Http.setRequestResponseTimeout (Http.Conduit.responseTimeoutMicro 60_000_000)
   response <- Http.httpLbs request
   unless ("Content-Type" `elem` (fst <$> Http.getResponseHeaders response)) $ error "Missing Content-Type header in response"
   pure response

server/lib/upgrade-tests/src/Hasura/UpgradeTests/Database.hs

@@ -1,7 +1,7 @@
 -- | Starts a database in a Docker container.
 module Hasura.UpgradeTests.Database
   ( Database,
-    DatabaseSchema (..),
+    DatabaseSchema (databaseSchemaUrlForContainer, databaseSchemaUrlForHost),
     dbContainer,
     newSchema,
     runSql,
@@ -22,25 +22,34 @@ type Url = String
 type Sql = Text
 
 -- | Represents a running database.
-newtype Database = Database Url
-  deriving newtype (Show)
+data Database = Database
+  { -- | The connection URL for the database, inside the Docker network.
+    databaseUrlForContainer :: Url,
+    -- | The connection URL for the database, from the host network.
+    databaseUrlForHost :: Url
+  }
+  deriving stock (Show)
 
 -- | Represents an initialized schema on a running database.
-newtype DatabaseSchema = DatabaseSchema
-  { -- | The connection URL for the schema.
-    databaseSchemaUrl :: Url
+data DatabaseSchema = DatabaseSchema
+  { -- | The connection URL for the schema, inside the Docker network.
+    databaseSchemaUrlForContainer :: Url,
+    -- | The connection URL for the schema, from the host network.
+    databaseSchemaUrlForHost :: Url
   }
-  deriving newtype (Show)
+  deriving stock (Show)
 
 -- | This starts a database in a test Docker container.
 --
 -- The database will be cleaned up when leaving the 'TC.TestContainer' monad.
-dbContainer :: TC.TestContainer Database
-dbContainer = do
+dbContainer :: TC.Network -> TC.TestContainer Database
+dbContainer network = do
   container <-
     TC.run
       $ TC.containerRequest (TC.fromTag ("postgis/postgis:15-3.3-alpine"))
       & TC.setSuffixedName "hge-test-upgrade-db"
+      & TC.withNetwork network
+      & TC.withNetworkAlias "db"
       & TC.setCmd ["-F"]
       & TC.setEnv [("POSTGRES_PASSWORD", "password")]
       & TC.setExpose [5432]
@@ -49,16 +58,24 @@ dbContainer = do
   -- shuts it down, then starts it again, so waiting for the port is not enough.
   liftIO $ sleep 5
   -- We provide a URL that can be used from the host.
-  pure . Database $ "postgresql://postgres:password@localhost:" <> show (TC.containerPort container 5432)
+  pure
+    $ Database
+      { databaseUrlForContainer = "postgresql://postgres:password@db",
+        databaseUrlForHost = "postgresql://postgres:password@localhost:" <> show (TC.containerPort container 5432)
+      }
 
 -- | This creates a new, randomly-named schema on the given database.
 --
 -- It is assumed that the schema will be cleaned up when the database is.
 newSchema :: Database -> IO DatabaseSchema
-newSchema (Database url) = do
+newSchema database = do
   schemaName <- replicateM 16 $ randomRIO ('a', 'z')
-  runSql url $ "CREATE DATABASE \"" <> Text.pack schemaName <> "\""
-  pure . DatabaseSchema $ url <> "/" <> schemaName
+  runSql (databaseUrlForHost database) $ "CREATE DATABASE \"" <> Text.pack schemaName <> "\""
+  pure
+    $ DatabaseSchema
+      { databaseSchemaUrlForContainer = databaseUrlForContainer database <> "/" <> schemaName,
+        databaseSchemaUrlForHost = databaseUrlForHost database <> "/" <> schemaName
+      }
 
 -- | Run arbitrary SQL on a given connection URL.
 --

server/lib/upgrade-tests/src/Hasura/UpgradeTests/Server.hs

@@ -10,10 +10,16 @@ where
 
 import Control.Concurrent.Async qualified as Async
 import Control.Exception (bracket)
+import Data.Aeson qualified as J
+import Data.Aeson.KeyMap ((!?))
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Aeson.Types qualified as J
 import Data.Text qualified as Text
+import Data.Vector qualified as Vector
 import Harness.Constants qualified as Constants
 import Harness.GraphqlEngine qualified as GraphqlEngine
 import Harness.Http qualified as Http
+import Hasura.Base.Error (runAesonParser, showQErr)
 import Hasura.Prelude
 import Hasura.Server.Init (ServeOptions (..), unsafePort)
 import Hasura.UpgradeTests.Database
@@ -21,7 +27,6 @@ import Network.Socket qualified as Socket
 import TestContainers qualified as TC
 import TestContainers.Config qualified as TC
 import TestContainers.Monad qualified as TC
-import Unsafe.Coerce (unsafeCoerce)
 
 type Url = String
 
@@ -41,64 +46,94 @@ serverMetadataUrl (Server url) = url <> "/v1/metadata"
 serverQueryUrl :: Server -> Url
 serverQueryUrl (Server url) = url <> "/v2/query"
 
--- | Starts HGE with the given version number, and runs an action.
+-- | Uses Docker to start HGE with the given version number, and runs an action.
 --
 -- It uses the images from Docker Hub, so the version must be released. "latest"
 -- corresponds to the latest released version.
 --
 -- The database will be used as both the metadata and source database.
---
--- The server is run using host networking (and therefore expects a database URL
--- that is host-facing), because 'withCurrentHge' is run as a process directly
--- on the host. These two processes are expected to share a metadata database,
--- and therefore must agree on the source database connection URL.
-withBaseHge :: TC.ImageTag -> DatabaseSchema -> (Server -> IO a) -> IO a
-withBaseHge version (DatabaseSchema schemaUrl) f =
+withBaseHge :: TC.Network -> TC.ImageTag -> DatabaseSchema -> (Server -> IO a) -> IO a
+withBaseHge network version databaseSchema f = do
+  let databaseSchemaUrl = databaseSchemaUrlForContainer databaseSchema
   TC.runTestContainer TC.defaultConfig do
-    port <- liftIO getFreePort
-    _container <-
+    container <-
       TC.run
         $ TC.containerRequest (TC.fromTag ("hasura/graphql-engine:" <> version))
         & TC.setSuffixedName "hge-test-upgrade-base-server"
         & TC.setCmd
           [ "graphql-engine",
             "--database-url",
-            Text.pack schemaUrl,
-            "serve",
-            "--server-port",
-            tshow port
+            Text.pack databaseSchemaUrl,
+            "serve"
           ]
-        & TC.withNetwork hostNetwork
-    let url = "http://localhost:" <> show port
+        & TC.withNetwork network
+        & TC.setExpose [8080]
+    let url = "http://localhost:" <> show (TC.containerPort container 8080)
     liftIO do
       Http.healthCheck $ url <> "/healthz"
+      configureServer url databaseSchemaUrl
       f $ Server url
 
--- | Starts HGE from code, and runs an action.
+-- | Starts HGE in a new thread, and runs an action.
+--
+-- This uses HGE as a library, so the version of HGE is the one that this is
+-- compiled against.
 --
 -- The database will be used as the metadata database. Because this is designed
 -- to be run after 'withBaseHge', it is expected that the metadata is already
 -- configured with a source and some tracked relations.
 withCurrentHge :: DatabaseSchema -> (Server -> IO a) -> IO a
-withCurrentHge (DatabaseSchema schemaUrl) f = do
+withCurrentHge databaseSchema f = do
   port <- getFreePort
+  let databaseSchemaUrl = databaseSchemaUrlForHost databaseSchema
   let serverApp =
         GraphqlEngine.runApp
-          schemaUrl
+          databaseSchemaUrl
           Constants.serveOptions {soPort = unsafePort port}
   Async.withAsync serverApp \_ -> do
     let url = "http://localhost:" <> show port
     Http.healthCheck $ url <> "/healthz"
+    configureServer url databaseSchemaUrl
     f $ Server url
 
--- | This represents the "host" Docker network.
-hostNetwork :: TC.Network
--- Unfortunately, the 'TC.Network' constructor is not exposed, and so we need
--- to cheat to get one. It's a newtype, so it's not too hard.
+-- | Sets the default source's database URL to the given value.
 --
--- A better solution would be to patch the upstream library to expose a
--- 'hostNetwork' function.
-hostNetwork = unsafeCoerce ("host" :: Text)
+-- This leaves the rest of the metadata intact.
+--
+-- This code is incredibly unpleasant. Perhaps it could be improved with Aeson lenses or Autodocodec.
+configureServer :: String -> String -> IO ()
+configureServer serverUrl databaseSchemaUrl = do
+  metadata <- Http.postValue (serverUrl <> "/v1/metadata") mempty $ J.object [("type", "export_metadata"), ("args", J.object mempty)]
+  newMetadata <-
+    either (fail . Text.unpack . showQErr) pure
+      . runExcept
+      $ runAesonParser modifyMetadata metadata
+  void $ Http.postValue (serverUrl <> "/v1/metadata") mempty $ J.object [("type", "replace_metadata"), ("args", J.toJSON newMetadata)]
+  where
+    modifyMetadata :: J.Value -> J.Parser J.Value
+    modifyMetadata metadata = flip (J.withObject "metadata") metadata \metadataObject -> do
+      let sources = fromMaybe (J.Array mempty) (metadataObject !? "sources")
+      -- updating this is unpleasant because it's an array, keyed by a property, not an object
+      newSources <- flip (J.withArray "sources") sources \sourcesArray ->
+        case Vector.findIndex (\case J.Object source -> source !? "name" == Just "default"; _ -> False) sourcesArray of
+          -- if there is a source, update it
+          Just index -> (\newSource -> J.Array $ sourcesArray Vector.// [(index, newSource)]) <$> modifySource (sourcesArray Vector.! index)
+          -- if not, add a new one
+          Nothing -> pure . J.Array $ Vector.snoc sourcesArray defaultSourceValue
+      pure . J.Object $ KeyMap.insert "sources" newSources metadataObject
+
+    modifySource :: J.Value -> J.Parser J.Value
+    modifySource source = flip (J.withObject "source") source \sourceObject ->
+      pure . J.Object $ KeyMap.insert "configuration" configurationValue sourceObject
+
+    configurationValue = J.object [("connection_info", J.object [("database_url", J.String (Text.pack databaseSchemaUrl))])]
+    defaultSourceValue =
+      J.object
+        [ ("name", "default"),
+          ("kind", "postgres"),
+          ("configuration", configurationValue),
+          ("tables", J.Array mempty)
+        ]
 
 -- | Looks for a free port and returns it.
 --

server/lib/upgrade-tests/src/Main.hs

@@ -44,7 +44,12 @@ main = do
   withArgs (optionsHspecArgs options)
     . hspec
     -- we just run a single database container for all tests
-    . aroundAll (TC.withContainers dbContainer)
+    . aroundAll
+      ( TC.withContainers do
+          network <- TC.createNetwork TC.networkRequest
+          database <- dbContainer network
+          pure (network, database)
+      )
     $ spec options
 
 -- | The various tests.
@@ -65,7 +70,7 @@ main = do
 --
 -- This takes a little while, but doesn't require running hordes of queries or
 -- actually loading data, so should be quite reliable.
-spec :: Options -> SpecWith Database
+spec :: Options -> SpecWith (TC.Network, Database)
 spec options = describe "upgrading HGE" do
   let repositoryRoot = optionsRepositoryRoot options
       datasets =
@@ -73,10 +78,10 @@ spec options = describe "upgrading HGE" do
           mkDataset repositoryRoot "huge_schema" 8000
         ]
 
-  it "works with an empty schema" \database -> do
+  it "works with an empty schema" \(network, database) -> do
     databaseSchema <- newSchema database
 
-    baseSchema <- withBaseHge baseVersion databaseSchema \server -> do
+    baseSchema <- withBaseHge network baseVersion databaseSchema \server -> do
       Http.postValue (serverGraphqlUrl server) mempty introspectionQuery
 
     baseSchemaTypeLength <- typeLength baseSchema
@@ -88,14 +93,14 @@ spec options = describe "upgrading HGE" do
     currentSchema `shouldBeYaml` baseSchema
 
   forM_ datasets \dataset -> do
-    it ("works with the " <> show (datasetName dataset) <> " dataset") \database -> do
+    it ("works with the " <> show (datasetName dataset) <> " dataset") \(network, database) -> do
       migrationSql <- datasetMigrationSql dataset
       replaceMetadataCommand <- datasetReplaceMetadataCommand dataset
 
       databaseSchema <- newSchema database
-      runSql (databaseSchemaUrl databaseSchema) migrationSql
+      runSql (databaseSchemaUrlForHost databaseSchema) migrationSql
 
-      baseSchema <- withBaseHge baseVersion databaseSchema \server -> do
+      baseSchema <- withBaseHge network baseVersion databaseSchema \server -> do
         void $ Http.postValue (serverMetadataUrl server) mempty replaceMetadataCommand
         Http.postValue (serverGraphqlUrl server) mempty introspectionQuery
 

server/lib/upgrade-tests/upgrade-tests.cabal

@@ -62,6 +62,7 @@ test-suite upgrade-tests
     , async
     , bytestring
     , file-embed
+    , hasura-base
     , hasura-prelude
     , hspec
     , network