Feature matrix standalone tester tool

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7120
Co-authored-by: Samir Talwar <47582+SamirTalwar@users.noreply.github.com>
GitOrigin-RevId: 5db7f8e24f22414805b10143248bfacfb5b7a03a

flake.nix

@@ -19,7 +19,7 @@
     };
 
     nixpkgs = {
-       url = github:NixOS/nixpkgs/nixos-22.11;
+      url = github:NixOS/nixpkgs/nixos-22.11;
     };
   };
 

server/lib/api-tests/api-tests.cabal

@@ -1,11 +1,14 @@
 cabal-version: 2.2
 name: api-tests
 version: 1.0.0
-
+build-type: Simple
+copyright: Hasura Inc.
+extra-source-files: README.md
 
 library
   build-tool-depends: hspec-discover:hspec-discover
   hs-source-dirs: src
+  default-language: GHC2021
 
   default-extensions:
     BlockArguments
@@ -25,7 +28,6 @@ library
     TypeApplications
     TypeFamilies
 
-
   build-depends:
     , HUnit
     , aeson
@@ -179,7 +181,6 @@ executable api-tests
     , api-tests
     , base
     , hspec
-  default-language: Haskell2010
 
   -- Turning off optimizations is intentional; tests aren't
   -- performance sensitive and waiting for compilation is a problem.
@@ -189,26 +190,29 @@ executable api-tests
     -threaded
     -rtsopts "-with-rtsopts=-N"
 
+  default-language: GHC2021
   hs-source-dirs: test-runner
   main-is: Main.hs
 
-executable render-feature-matrix
+library feature-matrix
   build-depends:
+    , base
     , aeson
     , attoparsec
-    , base
     , bytestring
     , containers
     , lucid2
     , mtl
     , text
 
+  default-language: GHC2021
   default-extensions:
     BlockArguments
     DataKinds
     DeriveGeneric
     DerivingStrategies
     ImportQualifiedPost
+    LambdaCase
     MultiWayIf
     NamedFieldPuns
     NoImplicitPrelude
@@ -219,8 +223,40 @@ executable render-feature-matrix
     TypeApplications
     TypeFamilies
 
-  hs-source-dirs: src-render-feature-matrix
+  hs-source-dirs: src-feature-matrix
-  default-language: Haskell2010
+
+  exposed-modules:
+      Hasura.FeatureMatrix
+
+  ghc-options:
+    -Wall
+    -Werror
+
+executable render-feature-matrix
+  build-depends:
+    , base
+    , feature-matrix
+    , bytestring
+
+  default-language: GHC2021
+  default-extensions:
+    BlockArguments
+    DataKinds
+    DeriveGeneric
+    DerivingStrategies
+    ImportQualifiedPost
+    LambdaCase
+    MultiWayIf
+    NamedFieldPuns
+    NoImplicitPrelude
+    OverloadedStrings
+    PatternGuards
+    RecordWildCards
+    ScopedTypeVariables
+    TypeApplications
+    TypeFamilies
+
+  hs-source-dirs: app-render-feature-matrix
 
   -- Turning off optimizations is intentional; tests aren't
   -- performance sensitive and waiting for compilation is a problem.
@@ -231,3 +267,42 @@ executable render-feature-matrix
     -rtsopts "-with-rtsopts=-N"
 
   main-is: Main.hs
+
+executable produce-feature-matrix
+  build-depends:
+    , api-tests
+    , base
+    , bytestring
+    , directory
+    , fast-logger
+    , feature-matrix
+    , filepath
+    , hasura-prelude
+    , hspec
+    , optparse-generic
+    , postgres-options
+    , stm
+    , test-harness
+
+  default-language: GHC2021
+  default-extensions:
+    BlockArguments
+    DataKinds
+    LambdaCase
+    NoImplicitPrelude
+    OverloadedStrings
+    ExplicitNamespaces
+    OverloadedRecordDot
+
+  hs-source-dirs: app-produce-feature-matrix
+
+  -- Turning off optimizations is intentional; tests aren't
+  -- performance sensitive and waiting for compilation is a problem.
+  ghc-options:
+    -O0
+    -Wall
+    -Werror
+    -threaded
+    -rtsopts "-with-rtsopts=-N"
+
+  main-is: Main.hs

server/lib/api-tests/app-produce-feature-matrix/Main.hs

@@ -0,0 +1,148 @@
+-- | Generate a feature matrix compatability report from a postgres connection string.
+module Main (main) where
+
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TQueue (flushTQueue, newTQueueIO, writeTQueue)
+import Data.ByteString qualified as BS (ByteString, intercalate, writeFile)
+import Data.Char (toLower)
+import Database.PostgreSQL.Simple.Options qualified as Options
+import Harness.TestEnvironment qualified as TestEnvironment
+import Hasura.FeatureMatrix qualified as FeatureMatrix
+import Hasura.Prelude
+import Options.Generic (ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type (<!>), type (<?>))
+import Spec qualified
+import SpecHook qualified
+import System.Directory qualified as Directory
+import System.Environment qualified as Environment
+import System.FilePath qualified as FilePath
+import System.Log.FastLogger as FL
+import Test.Hspec qualified as Hspec
+
+main :: IO ()
+main = do
+  (options, hspecArgs) <- getOptionsAndHspecArgs
+  checkFileAndDirectory options
+  logs <- runSuite options.connectionString hspecArgs
+  BS.writeFile options.output $ FeatureMatrix.render logs
+  putStrLn $ "Feature matrix output has been written to: file://" <> options.output
+
+-- * Handle arguments
+
+-- | Process cli args and get the options for the feature matrix
+--   and the hspec options. Hspec options can be defined with `--hspec <options>`.
+getOptionsAndHspecArgs :: IO (Options Unwrapped, [String])
+getOptionsAndHspecArgs = do
+  (ourArgs, hspecArgs) <- readArgs
+  options <-
+    Environment.withArgs ourArgs $ unwrapRecord "Feature matrix compatibility tester tool"
+  absoluteOutputPath <- Directory.makeAbsolute (output options)
+  pure
+    ( options {output = absoluteOutputPath},
+      hspecArgs
+    )
+
+-- | Command-line options for optparse-generic.
+data Options w = Options
+  { connectionString ::
+      w
+        ::: String
+        <?> "Postgres connection string"
+          <!> "postgresql://hasura:hasura@127.0.0.1:65002/hasura",
+    output ::
+      w
+        ::: FilePath
+        <?> "Feature matrix output file path"
+          <!> "/tmp/feature_matrix_tool_output.html",
+    overrideOutputFile ::
+      w
+        ::: Bool
+        <?> "Override output file if exists",
+    createDirectory ::
+      w
+        ::: Bool
+        <?> "Create directory if not exists",
+    -- this is just a flag, we take care of splitting the arguments ourselves.
+    noAsk ::
+      w
+        ::: Bool
+        <?> "Do not ask to override output file or create a directory if missing",
+    -- this is just a flag, we take care of splitting the arguments ourselves.
+    hspec ::
+      w
+        ::: Bool
+        <?> "arguments for hspec"
+  }
+  deriving (Generic)
+
+instance ParseRecord (Options Wrapped)
+
+-- | getArgs and split on @--hspec@.
+readArgs :: IO ([String], [String])
+readArgs = splitOnHspec <$> Environment.getArgs
+
+splitOnHspec :: [String] -> ([String], [String])
+splitOnHspec = \case
+  [] -> ([], [])
+  "--hspec" : rest -> (["--hspec"], rest)
+  arg : rest ->
+    case splitOnHspec rest of
+      (leftList, rightList) -> (arg : leftList, rightList)
+
+-- * Runner
+
+-- | Run test suite with the connection string and hspec arguments
+--   return the logs from the suite, to be used for rendering the
+--   feature matrix.
+runSuite :: String -> [String] -> IO BS.ByteString
+runSuite uri hspecArgs = do
+  Environment.withArgs hspecArgs $ do
+    -- write the logs to this queue
+    queue <- newTQueueIO
+    -- setup mode and logging
+    postgresOptions <- Options.parseConnectionString uri `onLeft` fail
+    SpecHook.setupGlobalConfig
+      (TestEnvironment.TestNewPostgresVariant postgresOptions)
+      (FL.LogCallback (atomically . writeTQueue queue) (pure ()))
+    -- run the tests
+    Hspec.hspec Spec.spec
+    -- fetch the logs
+    BS.intercalate "\n" . map FL.fromLogStr <$> atomically (flushTQueue queue)
+
+-- * Utils
+
+-- | Check file and directory configuration.
+checkFileAndDirectory :: Options Unwrapped -> IO ()
+checkFileAndDirectory options = do
+  checkFile options
+  checkDirectory options
+
+-- | Check that file does not exists, ask to override, or terminate.
+checkFile :: Options Unwrapped -> IO ()
+checkFile options = do
+  let filepath = options.output
+  fileExists <- Directory.doesFileExist filepath
+  when (fileExists && not options.overrideOutputFile) do
+    when options.noAsk $ errorWithoutStackTrace $ "Output file '" <> filepath <> "' already exists."
+    putStrLn $ "Output file '" <> filepath <> "' already exists. Override? (y/N)"
+    answer <- getLine
+    if map toLower answer `elem` ["y", "yes"]
+      then putStrLn "The file will be overriden."
+      else errorWithoutStackTrace "Terminating."
+
+-- | Check that directory exists, ask to create, or terminate.
+checkDirectory :: Options Unwrapped -> IO ()
+checkDirectory options = do
+  let directory = FilePath.takeDirectory options.output
+  dirExists <- Directory.doesDirectoryExist directory
+  unless dirExists do
+    if options.createDirectory
+      then Directory.createDirectoryIfMissing True directory
+      else do
+        when options.noAsk $ errorWithoutStackTrace $ "Directory '" <> directory <> "' does not exists."
+        putStrLn $ "Directory '" <> directory <> "' does not exists. Create? (y/N)"
+        answer <- getLine
+        if map toLower answer `elem` ["y", "yes"]
+          then do
+            Directory.createDirectoryIfMissing True directory
+            putStrLn "Directory created."
+          else errorWithoutStackTrace "Terminating."

server/lib/api-tests/app-render-feature-matrix/Main.hs

@@ -0,0 +1,8 @@
+module Main (main) where
+
+import Data.ByteString qualified as ByteString
+import Hasura.FeatureMatrix
+import Prelude
+
+main :: IO ()
+main = ByteString.interact render

server/lib/api-tests/src-feature-matrix/Hasura/FeatureMatrix.hs

@@ -1,7 +1,4 @@
-{-# LANGUAGE LambdaCase #-}
+module Hasura.FeatureMatrix (render, parseLogs, extractFeatures, renderFeatureMatrix) where
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
-
-module Main (main) where
 
 import Control.Applicative
 import Control.Monad.Except
@@ -9,7 +6,7 @@ import Control.Monad.State
 import Data.Aeson
 import Data.Aeson.Types
 import Data.Attoparsec.ByteString as Atto
-import Data.ByteString (ByteString, interact)
+import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
 import Data.Foldable
 import Data.Map.Strict (Map)
@@ -67,17 +64,12 @@ data HspecEventItemDone = HspecEventItemDone
 -}
 
 instance FromJSON HspecEventItemDone where
-  parseJSON =
+  parseJSON = withObject "Hspec Event ItemDone" \o -> do
-    withObject
+    let tags = parseMaybe (\o' -> (,) <$> o' .: "type" <*> o' .: "event_tag") o
-      "Hspec Event ItemDone"
+    unless
-      ( \o -> do
+      (tags == Just ("Hspec Event" :: Text, "ItemDone" :: Text))
-          let tags = parseMaybe (\o -> (,) <$> o .: "type" <*> o .: "event_tag") o
+      (fail "Not a Hspec Event ItemDone")
-          unless
+    HspecEventItemDone <$> o .: "groups" <*> o .: "item" <*> o .: "requirement"
-            (tags == Just ("Hspec Event" :: Text, "ItemDone" :: Text))
-            (fail "Not a Hspec Event ItemDone")
-
-          HspecEventItemDone <$> o .: "groups" <*> o .: "item" <*> o .: "requirement"
-      )
 
 data HspecItem = HspecItem
   { hiResult :: HspecItemResult
@@ -105,9 +97,9 @@ instance FromJSON HspecItemResult where
             _ -> fail $ "Unknown result type: " ++ result
       )
 
-main :: IO ()
+render :: ByteString -> ByteString
-main = interact \stdIn ->
+render input =
-  let parsedLogs = parseLogs stdIn
+  let parsedLogs = parseLogs input
       features = runExcept . flip execStateT mempty . traverse extractFeatures <$> parsedLogs
    in renderFeatureMatrix features
 

server/lib/api-tests/src/SpecHook.hs

@@ -2,22 +2,26 @@ module SpecHook
   ( hook,
     setupTestEnvironment,
     teardownTestEnvironment,
+    setupGlobalConfig,
+    setupLogType,
   )
 where
 
-import Control.Exception.Safe (bracket)
 import Data.Char qualified as Char
+import Data.IORef
 import Data.List qualified as List
 import Data.Monoid (getLast)
 import Data.UUID.V4 (nextRandom)
-import Database.PostgreSQL.Simple.Options (Options (..), parseConnectionString)
+import Database.PostgreSQL.Simple.Options qualified as Options
 import Harness.Constants qualified as Constants
+import Harness.Exceptions (HasCallStack, bracket)
 import Harness.GraphqlEngine (startServerThread)
 import Harness.Logging
 import Harness.Test.BackendType (BackendType (..))
 import Harness.TestEnvironment (TestEnvironment (..), TestingMode (..), stopServer)
 import Hasura.Prelude
-import System.Environment (lookupEnv)
+import System.Environment (getEnvironment, lookupEnv)
+import System.IO.Unsafe (unsafePerformIO)
 import System.Log.FastLogger qualified as FL
 import Test.Hspec (Spec, SpecWith, aroundAllWith, runIO)
 import Test.Hspec.Core.Spec (Item (..), filterForestWithLabels, mapSpecForest, modifyConfig)
@@ -35,27 +39,20 @@ import Test.Hspec.Core.Spec (Item (..), filterForestWithLabels, mapSpecForest, m
 --
 -- * @TestNewPostgresVariant@, which runs the Postgres tests against the
 --   connection URI given in the @POSTGRES_VARIANT_URI@.
-setupTestingMode :: IO TestingMode
+lookupTestingMode :: [(String, String)] -> Either String TestingMode
-setupTestingMode =
+lookupTestingMode env =
-  lookupEnv "POSTGRES_VARIANT_URI" >>= \case
+  case lookup "POSTGRES_VARIANT_URI" env of
     Nothing ->
-      lookupEnv "HASURA_TEST_BACKEND_TYPE" >>= \case
+      case lookup "HASURA_TEST_BACKEND_TYPE" env of
-        Nothing -> pure TestEverything
+        Nothing -> Right TestEverything
         Just backendType ->
-          onNothing (parseBackendType backendType) (error $ "Did not recognise backend type " <> backendType)
+          maybe (Left $ "Did not recognise backend type " <> backendType) Right (parseBackendType backendType)
     Just uri ->
-      case parseConnectionString uri of
+      case Options.parseConnectionString uri of
         Left reason ->
-          error $ "Parsing variant URI failed: " ++ reason
+          Left $ "Parsing variant URI failed: " ++ reason
         Right options ->
-          pure
+          Right $ TestNewPostgresVariant options
-            TestNewPostgresVariant
-              { postgresSourceUser = fromMaybe Constants.postgresUser $ getLast (user options),
-                postgresSourcePassword = fromMaybe Constants.postgresPassword $ getLast (password options),
-                postgresSourceHost = fromMaybe Constants.postgresHost $ getLast (hostaddr options <> host options),
-                postgresSourcePort = maybe Constants.defaultPostgresPort fromIntegral $ getLast (port options),
-                postgresSourceInitialDatabase = fromMaybe Constants.postgresDb $ getLast (dbname options)
-              }
 
 -- | which backend should we run tests for?
 parseBackendType :: String -> Maybe TestingMode
@@ -90,27 +87,34 @@ teardownTestEnvironment TestEnvironment {..} = do
   stopServer server
 
 -- | allow setting log output type
-setupLogType :: IO (FL.LogType' FL.LogStr)
+setupLogType :: IO FL.LogType
-setupLogType =
+setupLogType = do
+  env <- getEnvironment
   let defaultLogType = FL.LogFileNoRotate "tests-hspec.log" 1024
-   in lookupEnv "HASURA_TEST_LOGTYPE" >>= \case
+  pure case lookup "HASURA_TEST_LOGTYPE" env of
-        Nothing -> pure defaultLogType
+    Nothing -> defaultLogType
-        Just str ->
+    Just str ->
-          case Char.toUpper <$> str of
+      case Char.toUpper <$> str of
-            "STDOUT" -> pure (FL.LogStdout 64)
+        "STDOUT" -> FL.LogStdout 64
-            "STDERR" -> pure (FL.LogStderr 64)
+        "STDERR" -> FL.LogStderr 64
-            _ -> pure defaultLogType
+        _ -> defaultLogType
 
-hook :: SpecWith TestEnvironment -> Spec
+hook :: HasCallStack => SpecWith TestEnvironment -> Spec
 hook specs = do
-  logType <- runIO setupLogType
+  (testingMode, logType) <-
+    runIO $
+      readIORef globalConfigRef `onNothingM` do
+        logType <- setupLogType
+        environment <- getEnvironment
+        testingMode <- lookupTestingMode environment `onLeft` error
+        setupGlobalConfig testingMode logType
+        pure (testingMode, logType)
+
   (logger', _cleanup) <- runIO $ FL.newFastLogger logType
   let logger = flLogger logger'
 
   modifyConfig (addLoggingFormatter logger)
 
-  testingMode <- runIO setupTestingMode
-
   let shouldRunTest :: [String] -> Item x -> Bool
       shouldRunTest labels _ = case testingMode of
         TestEverything -> True
@@ -122,3 +126,11 @@ hook specs = do
 
   aroundAllWith (const . bracket (setupTestEnvironment testingMode logger) teardownTestEnvironment) $
     mapSpecForest (filterForestWithLabels shouldRunTest) (contextualizeLogger specs)
+
+{-# NOINLINE globalConfigRef #-}
+globalConfigRef :: IORef (Maybe (TestingMode, FL.LogType))
+globalConfigRef = unsafePerformIO $ newIORef Nothing
+
+setupGlobalConfig :: TestingMode -> FL.LogType -> IO ()
+setupGlobalConfig testingMode logType =
+  writeIORef globalConfigRef $ Just (testingMode, logType)

server/lib/test-harness/src/Harness/Backend/Postgres.hs

@@ -37,13 +37,16 @@ import Control.Monad.Reader
 import Data.Aeson (Value)
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as S8
+import Data.Monoid (Last, getLast)
 import Data.String (fromString)
 import Data.String.Interpolate (i)
 import Data.Text qualified as T
 import Data.Text.Encoding (decodeUtf8)
 import Data.Text.Extended (commaSeparated)
+import Data.Text.Lazy qualified as TL
 import Data.Time (defaultTimeLocale, formatTime)
 import Database.PostgreSQL.Simple qualified as Postgres
+import Database.PostgreSQL.Simple.Options (Options (..))
 import Harness.Constants as Constants
 import Harness.Exceptions
 import Harness.GraphqlEngine qualified as GraphqlEngine
@@ -62,22 +65,33 @@ import Harness.Test.SetupAction (SetupAction (..))
 import Harness.TestEnvironment (TestEnvironment (..), TestingMode (..), testLogMessage)
 import Hasura.Prelude
 import System.Process.Typed
+import Text.Pretty.Simple (pShow)
 
 -- | The default connection information based on the 'TestingMode'. The
 -- interesting thing here is the database: in both modes, we specify an
 -- /initial/ database (returned by this function), which we use only as a way
 -- to create other databases for testing.
-defaultConnectInfo :: TestEnvironment -> Postgres.ConnectInfo
+defaultConnectInfo :: HasCallStack => TestEnvironment -> Postgres.ConnectInfo
 defaultConnectInfo testEnvironment =
   case testingMode testEnvironment of
-    TestNewPostgresVariant {..} ->
+    TestNewPostgresVariant opts@Options {..} ->
-      Postgres.ConnectInfo
+      let getComponent :: forall a. String -> Last a -> a
-        { connectHost = postgresSourceHost,
+          getComponent component =
-          connectPort = postgresSourcePort,
+            fromMaybe
-          connectUser = postgresSourceUser,
+              ( error $
-          connectPassword = postgresSourcePassword,
+                  unlines
-          connectDatabase = postgresSourceInitialDatabase
+                    [ "Postgres URI is missing its " <> component <> " component.",
-        }
+                      "Postgres options: " <> TL.unpack (pShow opts)
+                    ]
+              )
+              . getLast
+       in Postgres.ConnectInfo
+            { connectUser = getComponent "user" user,
+              connectPassword = getComponent "password" password,
+              connectHost = getComponent "host" $ hostaddr <> host,
+              connectPort = fromIntegral . getComponent "port" $ port,
+              connectDatabase = getComponent "dbname" $ dbname
+            }
     _otherTestingMode ->
       Postgres.ConnectInfo
         { connectHost = Constants.postgresHost,

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

@@ -20,6 +20,7 @@ import Control.Concurrent.Async (Async)
 import Control.Concurrent.Async qualified as Async
 import Data.UUID (UUID)
 import Data.Word
+import Database.PostgreSQL.Simple.Options (Options)
 import Harness.Logging.Messages
 import Harness.Test.BackendType
 import Hasura.Prelude
@@ -56,13 +57,7 @@ data TestingMode
   | -- | run "all the other tests"
     TestNoBackends
   | -- | test a Postgres-compatible using a custom connection string
-    TestNewPostgresVariant
+    TestNewPostgresVariant Options
-      { postgresSourceUser :: String,
-        postgresSourcePassword :: String,
-        postgresSourceHost :: String,
-        postgresSourcePort :: Word16,
-        postgresSourceInitialDatabase :: String
-      }
   deriving (Eq, Ord, Show)
 
 -- | Information about a server that we're working with.

server/lib/test-harness/test-harness.cabal

@@ -36,6 +36,7 @@ library
     , parsec
     , pg-client
     , postgresql-simple
+    , postgres-options
     , pretty-simple
     , refined
     , resourcet