diff --git a/cabal.project.freeze b/cabal.project.freeze index b8508721cc2..6a6577cb3d8 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -15,6 +15,7 @@ constraints: any.Cabal ==3.6.3.0, any.adjunctions ==4.4.2, any.aeson ==2.1.0.0, any.aeson-casing ==0.2.0.0, + any.aeson-optics ==1.2.0.1, any.aeson-pretty ==0.8.9, any.aeson-qq ==0.8.4, any.alex ==3.2.7.1, @@ -341,6 +342,7 @@ constraints: any.Cabal ==3.6.3.0, any.temporary ==1.3, any.terminal-size ==0.3.3, any.terminfo ==0.4.1.5, + any.testcontainers ==0.5.0.0, any.text ==1.2.5.0, any.text-builder ==0.6.7, any.text-builder-dev ==0.3.3, diff --git a/scripts/make/tests.mk b/scripts/make/tests.mk index b081bef1eed..1f425ccc470 100644 --- a/scripts/make/tests.mk +++ b/scripts/make/tests.mk @@ -225,4 +225,9 @@ test-native-queries-bigquery: remove-tix-file .PHONY: py-tests ## py-tests: run the python-based test suite py-tests: - ./server/tests-py/run-new.sh + ./server/tests-py/run.sh + +.PHONY: upgrade-tests +## upgrade-tests: run the server upgrade tests +upgrade-tests: + cabal run upgrade-tests:test:upgrade-tests diff --git a/server/lib/test-harness/src/Harness/GraphqlEngine.hs b/server/lib/test-harness/src/Harness/GraphqlEngine.hs index a474e807037..1c9fba54f27 100644 --- a/server/lib/test-harness/src/Harness/GraphqlEngine.hs +++ b/server/lib/test-harness/src/Harness/GraphqlEngine.hs @@ -38,6 +38,7 @@ module Harness.GraphqlEngine -- * Server Setup startServerThread, + runApp, -- * Re-exports serverUrl, @@ -379,6 +380,7 @@ startServerThread = do thread <- Async.async ( runApp + Constants.postgresqlMetadataConnectionString Constants.serveOptions { soPort = unsafePort port, soMetadataDefaults = backendConfigs @@ -391,17 +393,16 @@ startServerThread = do ------------------------------------------------------------------------------- -- | Run the graphql-engine server. -runApp :: ServeOptions Hasura.Logging.Hasura -> IO () -runApp serveOptions = do +runApp :: String -> ServeOptions Hasura.Logging.Hasura -> IO () +runApp metadataDbUrl serveOptions = do let rci = PostgresConnInfo { _pciDatabaseConn = Nothing, _pciRetries = Nothing } - metadataDbUrl = Just Constants.postgresqlMetadataConnectionString env <- Env.getEnvironment initTime <- liftIO getCurrentTime - metadataConnectionInfo <- App.initMetadataConnectionInfo env metadataDbUrl rci + metadataConnectionInfo <- App.initMetadataConnectionInfo env (Just metadataDbUrl) rci let defaultConnInfo = App.BasicConnectionInfo metadataConnectionInfo Nothing (ekgStore, serverMetrics) <- liftIO $ do diff --git a/server/lib/test-harness/src/Harness/Http.hs b/server/lib/test-harness/src/Harness/Http.hs index d392d46bf44..c1ec423a65a 100644 --- a/server/lib/test-harness/src/Harness/Http.hs +++ b/server/lib/test-harness/src/Harness/Http.hs @@ -135,7 +135,7 @@ healthCheck' url = loop [] httpHealthCheckAttempts -- * HTTP health checks httpHealthCheckAttempts :: Int -httpHealthCheckAttempts = 5 +httpHealthCheckAttempts = 15 httpHealthCheckIntervalSeconds :: DiffTime httpHealthCheckIntervalSeconds = 1 diff --git a/server/lib/upgrade-tests/introspection.gql b/server/lib/upgrade-tests/introspection.gql new file mode 100644 index 00000000000..d17da75f352 --- /dev/null +++ b/server/lib/upgrade-tests/introspection.gql @@ -0,0 +1,99 @@ +query IntrospectionQuery { + __schema { + queryType { + name + } + mutationType { + name + } + subscriptionType { + name + } + types { + ...FullType + } + directives { + name + description + locations + args { + ...InputValue + } + } + } +} + +fragment FullType on __Type { + kind + name + description + fields(includeDeprecated: true) { + name + description + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + description + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + description + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Database.hs b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Database.hs new file mode 100644 index 00000000000..dedeb08dc88 --- /dev/null +++ b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Database.hs @@ -0,0 +1,85 @@ +-- | Starts a database in a Docker container. +module Hasura.UpgradeTests.Database + ( Database, + DatabaseSchema (..), + dbContainer, + newSchema, + runSql, + ) +where + +import Control.Concurrent.Extended (sleep) +import Control.Exception (bracket) +import Data.ByteString.Char8 qualified as ByteString +import Data.Text qualified as Text +import Database.PG.Query qualified as PG +import Hasura.Prelude +import System.Random (randomRIO) +import TestContainers qualified as TC + +type Url = String + +type Sql = Text + +-- | Represents a running database. +newtype Database = Database Url + deriving newtype (Show) + +-- | Represents an initialized schema on a running database. +newtype DatabaseSchema = DatabaseSchema + { -- | The connection URL for the schema. + databaseSchemaUrl :: Url + } + deriving newtype (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 + container <- + TC.run $ + TC.containerRequest (TC.fromTag ("postgis/postgis:15-3.3-alpine")) + & TC.setSuffixedName "hge-test-upgrade-db" + & TC.setCmd ["-F"] + & TC.setEnv [("POSTGRES_PASSWORD", "password")] + & TC.setExpose [5432] + & TC.setWaitingFor (TC.waitUntilTimeout 30 (TC.waitUntilMappedPortReachable 5432)) + -- The container has a complicated startup script that starts the server, + -- 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) + +-- | 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 + schemaName <- replicateM 16 $ randomRIO ('a', 'z') + runSql url $ "CREATE DATABASE \"" <> Text.pack schemaName <> "\"" + pure . DatabaseSchema $ url <> "/" <> schemaName + +-- | Run arbitrary SQL on a given connection URL. +-- +-- The SQL can contain multiple statements, and is run unprepared. +runSql :: Url -> Sql -> IO () +runSql url sql = runTx url $ PG.multiQE PG.PGExecErrTx (PG.fromText sql) + +-- | Runs an arbitrary transaction on a given connection URL. +runTx :: (PG.FromPGConnErr e, Show e) => Url -> PG.TxET e IO a -> IO a +runTx url tx = do + let connInfo = + PG.ConnInfo + { ciRetries = 0, + ciDetails = PG.CDDatabaseURI (ByteString.pack url) + } + bracket + (PG.initPGPool connInfo PG.defaultConnParams nullPGLogger) + PG.destroyPGPool + \pool -> do + result <- runExceptT (PG.runTx' pool tx) + result `onLeft` (fail . show) + +nullPGLogger :: PG.PGLogger +nullPGLogger = const (pure ()) diff --git a/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Dataset.hs b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Dataset.hs new file mode 100644 index 00000000000..07dd207e51c --- /dev/null +++ b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Dataset.hs @@ -0,0 +1,47 @@ +module Hasura.UpgradeTests.Dataset + ( Dataset, + datasetName, + datasetExpectedTypeCount, + mkDataset, + datasetMigrationSql, + datasetReplaceMetadataCommand, + ) +where + +import Codec.Compression.GZip qualified as GZip +import Data.Aeson qualified as J +import Data.ByteString.Lazy qualified as ByteString +import Data.Text.Lazy qualified as Text +import Data.Text.Lazy.Encoding qualified as Text +import Hasura.Prelude + +-- | A dataset which can be loaded into the database and tracked. +data Dataset = Dataset + { datasetName :: String, + datasetPath :: FilePath, + datasetExpectedTypeCount :: Int + } + +-- | Constructs a new dataset. +mkDataset :: FilePath -> String -> Int -> Dataset +mkDataset repositoryRoot datasetName datasetExpectedTypeCount = Dataset {..} + where + datasetPath = + repositoryRoot + <> "/server/benchmarks/benchmark_sets/" + <> datasetName + +-- | Reads the migration SQL for the given dataset. +datasetMigrationSql :: Dataset -> IO Text +datasetMigrationSql dataset = + Text.toStrict . Text.decodeLatin1 . GZip.decompress <$> ByteString.readFile dumpPath + where + dumpPath = datasetPath dataset <> "/dump.sql.gz" + +-- | Reads the replace metadata JSON for the given dataset. +datasetReplaceMetadataCommand :: Dataset -> IO J.Value +datasetReplaceMetadataCommand dataset = + (J.decode <$> ByteString.readFile metadataJsonPath) + >>= (`onNothing` (fail "Invalid metadata JSON")) + where + metadataJsonPath = datasetPath dataset <> "/replace_metadata.json" diff --git a/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Options.hs b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Options.hs new file mode 100644 index 00000000000..96e0ec10e8e --- /dev/null +++ b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Options.hs @@ -0,0 +1,53 @@ +module Hasura.UpgradeTests.Options + ( Options (..), + parseOptions, + ) +where + +import Hasura.Prelude +import Options.Applicative + +-- | Test suite options. +data Options = Options + { -- | The path to the root of the HGE repository + -- (default: the current working directory). + optionsRepositoryRoot :: FilePath, + -- | The version of HGE to upgrade from (default: "latest"). + -- This is a Docker image tag. + optionsBaseVersion :: Text, + -- | Any further arguments, to be passed directly to Hspec. + optionsHspecArgs :: [String] + } + deriving stock (Show) + +-- | Parse 'Options' from the command-line arguments. +parseOptions :: IO Options +parseOptions = execParser optionsParserInfo + +optionsParser :: Parser Options +optionsParser = + Options + <$> strOption + ( long "repository-root" + <> metavar "PATH" + <> value "." + <> showDefault + <> help "the path to the root of the HGE repository" + ) + <*> strOption + ( long "base-version" + <> metavar "VERSION" + <> value "latest" + <> showDefault + <> help "the version of HGE to upgrade from" + ) + <*> many (strArgument (metavar "ARG" <> help "arguments to Hspec")) + +optionsParserInfo :: ParserInfo Options +optionsParserInfo = + info + (optionsParser <**> helper) + ( fullDesc + <> progDesc "Test that upgrading HGE from the last released version works" + <> forwardOptions + ) diff --git a/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Server.hs b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Server.hs new file mode 100644 index 00000000000..4ba7cda9e30 --- /dev/null +++ b/server/lib/upgrade-tests/src/Hasura/UpgradeTests/Server.hs @@ -0,0 +1,112 @@ +module Hasura.UpgradeTests.Server + ( Server, + serverGraphqlUrl, + serverMetadataUrl, + serverQueryUrl, + withBaseHge, + withCurrentHge, + ) +where + +import Control.Concurrent.Async qualified as Async +import Control.Exception (bracket) +import Data.Text qualified as Text +import Harness.Constants qualified as Constants +import Harness.GraphqlEngine qualified as GraphqlEngine +import Harness.Http qualified as Http +import Hasura.Prelude +import Hasura.Server.Init (ServeOptions (..), unsafePort) +import Hasura.UpgradeTests.Database +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 + +-- | Represents a running HGE server. +newtype Server = Server Url + deriving newtype (Show) + +-- | Constructs a GraphQL endpoint for the given server. +serverGraphqlUrl :: Server -> Url +serverGraphqlUrl (Server url) = url <> "/v1/graphql" + +-- | Constructs a metadata endpoint for the given server. +serverMetadataUrl :: Server -> Url +serverMetadataUrl (Server url) = url <> "/v1/metadata" + +-- | Constructs a query endpoint for the given server. +serverQueryUrl :: Server -> Url +serverQueryUrl (Server url) = url <> "/v2/query" + +-- | Starts 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 = + TC.runTestContainer TC.defaultConfig do + port <- liftIO getFreePort + _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 + ] + & TC.withNetwork hostNetwork + let url = "http://localhost:" <> show port + liftIO do + Http.healthCheck $ url <> "/healthz" + f $ Server url + +-- | Starts HGE from code, and runs an action. +-- +-- 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 + port <- getFreePort + let serverApp = + GraphqlEngine.runApp + schemaUrl + Constants.serveOptions {soPort = unsafePort port} + Async.withAsync serverApp \_ -> do + let url = "http://localhost:" <> show port + Http.healthCheck $ url <> "/healthz" + 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. +-- +-- A better solution would be to patch the upstream library to expose a +-- 'hostNetwork' function. +hostNetwork = unsafeCoerce ("host" :: Text) + +-- | Looks for a free port and returns it. +-- +-- The port is not locked in anyway, so theoretically, it could be acquired by +-- something else before we get a chance to use it. In practice, this is +-- unlikely, as these tests run sequentially. +getFreePort :: IO Int +getFreePort = bracket (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) Socket.close \sock -> do + Socket.bind sock (Socket.SockAddrInet Socket.defaultPort 0) + port <- Socket.socketPort sock + pure $ fromIntegral port diff --git a/server/lib/upgrade-tests/src/Main.hs b/server/lib/upgrade-tests/src/Main.hs new file mode 100644 index 00000000000..e92d1657797 --- /dev/null +++ b/server/lib/upgrade-tests/src/Main.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | These tests ensure that upgrading HGE preserves the GraphQL schema. +-- +-- They do this by running two different versions of HGE against the sme +-- metadata, and ensuring that the GraphQL schema doesn't change. +-- +-- We might find that in the future, we make an additive change that makes these +-- tests fail. Improving the tests to allow for this is left as an exercise to +-- whoever triggers it. (Sorry.) +-- +-- Currently, we do this with: +-- +-- * an empty database (zero tracked relations) +-- * the Chinook dataset +-- * the "huge schema" dataset +-- +-- The base version of HGE tested against can be overridden with an option. The +-- version must be available on Docker Hub. +module Main (main) where + +import Data.Aeson ((.=)) +import Data.Aeson qualified as J +import Data.Aeson.KeyMap qualified as J.KeyMap +import Data.ByteString.Lazy qualified as ByteString +import Data.ByteString.Lazy.Char8 qualified as ByteString.Char8 +import Data.FileEmbed (embedFile, makeRelativeToProject) +import Data.Text.Lazy.Encoding qualified as Text +import Data.Vector qualified as Vector +import Harness.Http qualified as Http +import Harness.Yaml (shouldBeYaml) +import Hasura.Prelude +import Hasura.UpgradeTests.Database +import Hasura.UpgradeTests.Dataset +import Hasura.UpgradeTests.Options +import Hasura.UpgradeTests.Server +import System.Environment (withArgs) +import Test.Hspec +import TestContainers.Hspec qualified as TC + +main :: IO () +main = do + options <- parseOptions + withArgs (optionsHspecArgs options) + . hspec + -- we just run a single database container for all tests + . aroundAll (TC.withContainers dbContainer) + $ spec options + +-- | The various tests. +-- +-- They do the following: +-- +-- 1. Start a PostgreSQL database to act as the metadata and source database. +-- 2. Add some relations to the database (using the benchmark sets). +-- 3. Spin up the latest released version of HGE as a Docker container, +-- pointing to this database. +-- 4. Track the aforementioned relations. +-- 5. Dump the full GraphQL schema using introspection.gql. +-- 6. Check that there are enough types in the schema, to make sure metadata +-- has loaded correctly. +-- 7. Shut down HGE and start the current version, using the test harness. +-- 8. Dump the schema again. +-- 9. Ensure the two GraphQL schemas match. +-- +-- 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 = describe "upgrading HGE" do + let repositoryRoot = optionsRepositoryRoot options + datasets = + [ mkDataset repositoryRoot "chinook" 400, + mkDataset repositoryRoot "huge_schema" 8000 + ] + + it "works with an empty schema" \database -> do + databaseSchema <- newSchema database + + baseSchema <- withBaseHge baseVersion databaseSchema \server -> do + Http.postValue (serverGraphqlUrl server) mempty introspectionQuery + + baseSchemaTypeLength <- typeLength baseSchema + baseSchemaTypeLength `shouldSatisfy` (> 10) + + currentSchema <- withCurrentHge databaseSchema \server -> do + Http.postValue (serverGraphqlUrl server) mempty introspectionQuery + + currentSchema `shouldBeYaml` baseSchema + + forM_ datasets \dataset -> do + it ("works with the " <> show (datasetName dataset) <> " dataset") \database -> do + migrationSql <- datasetMigrationSql dataset + replaceMetadataCommand <- datasetReplaceMetadataCommand dataset + + databaseSchema <- newSchema database + runSql (databaseSchemaUrl databaseSchema) migrationSql + + baseSchema <- withBaseHge baseVersion databaseSchema \server -> do + void $ Http.postValue (serverMetadataUrl server) mempty replaceMetadataCommand + Http.postValue (serverGraphqlUrl server) mempty introspectionQuery + + baseSchemaTypeLength <- typeLength baseSchema + baseSchemaTypeLength `shouldSatisfy` (> datasetExpectedTypeCount dataset) + + currentSchema <- withCurrentHge databaseSchema \server -> do + Http.postValue (serverGraphqlUrl server) mempty introspectionQuery + + currentSchema `shouldBeYaml` baseSchema + where + baseVersion = optionsBaseVersion options + +-- | The contents of /introspection.gql/, wrapped in a GraphQL JSON query. +introspectionQuery :: J.Value +introspectionQuery = J.object ["query" .= Text.decodeUtf8 rawQuery] + where + rawQuery = ByteString.fromStrict $(makeRelativeToProject "introspection.gql" >>= embedFile) + +-- | Gets the length of @.data.__schema.types@ from an introspected schema. +-- +-- We use this to ensure that the metadata looks correct. +typeLength :: forall m. MonadFail m => J.Value -> m Int +typeLength schema = do + types <- getProperty "data" schema >>= getProperty "__schema" >>= getProperty "types" + case types of + J.Array elements -> pure $ Vector.length elements + _ -> fail $ "Expected types to be an array, but got: " <> serialize types + where + getProperty :: J.Key -> J.Value -> m J.Value + getProperty key value@(J.Object properties) = + (J.KeyMap.lookup key properties) + `onNothing` fail ("Could not find key " <> show key <> " in object " <> serialize value) + getProperty _ value = fail $ "Expected an object, but got: " <> serialize value + serialize :: J.Value -> String + serialize value = ByteString.Char8.unpack (J.encode value) diff --git a/server/lib/upgrade-tests/upgrade-tests.cabal b/server/lib/upgrade-tests/upgrade-tests.cabal new file mode 100644 index 00000000000..28194e7f788 --- /dev/null +++ b/server/lib/upgrade-tests/upgrade-tests.cabal @@ -0,0 +1,80 @@ +cabal-version: 2.2 +name: upgrade-tests +version: 1.0.0 +build-type: Simple +copyright: Hasura Inc. +extra-source-files: + introspection.gql + +common common-all + default-extensions: + BlockArguments + DataKinds + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + NumericUnderscores + OverloadedStrings + PatternGuards + QuasiQuotes + RecordWildCards + ScopedTypeVariables + TypeApplications + TypeFamilies + + ghc-options: + -Werror + -- Taken from https://medium.com/mercury-bank/enable-all-the-warnings-a0517bc081c3 + -Weverything + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-missed-specialisations + -Wno-all-missed-specialisations + -Wno-unsafe + -Wno-safe + -Wno-missing-local-signatures + -Wno-monomorphism-restriction + -Wno-missing-kind-signatures + -Wno-missing-safe-haskell-mode + +test-suite upgrade-tests + import: common-all + type: exitcode-stdio-1.0 + hs-source-dirs: src + main-is: Main.hs + other-modules: + Hasura.UpgradeTests.Database + Hasura.UpgradeTests.Dataset + Hasura.UpgradeTests.Options + Hasura.UpgradeTests.Server + + build-depends: + base + , graphql-engine + , pg-client + , test-harness + , aeson + , async + , bytestring + , file-embed + , hasura-prelude + , hspec + , network + , optparse-applicative + , random + , testcontainers + , text + , vector + , zlib + + -- Turning off optimizations is intentional; tests aren't + -- performance sensitive and waiting for compilation is a problem. + ghc-options: + -O0 + -threaded + -rtsopts "-with-rtsopts=-N4"