server: add infrastructure to write runit tests for update parsers

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4533
GitOrigin-RevId: d094149d6cbdeebe152c58032715bad725480d9b

cabal.project

@@ -56,7 +56,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/hasura/graphql-parser-hs.git
-  tag: d835e1cef1291eeff9343b3e6448edacc0fcaa2e
+  tag: 47feca50fbfe6a059d02910c283e7567fbc1d7ef
 
 source-repository-package
   type: git

server/graphql-engine.cabal

@@ -236,6 +236,7 @@ library
                      , template-haskell
                      , text
                      , text-builder >= 0.6
+                     , th-lift
                      , these
                      , time >= 1.9
                      , time-compat
@@ -872,6 +873,7 @@ test-suite graphql-engine-tests
   build-depends:
       aeson
     , async
+    , attoparsec
     , base
     , bytestring
     , case-insensitive
@@ -884,6 +886,7 @@ test-suite graphql-engine-tests
     , free
     , graphql-engine
     , graphql-parser
+    , data-has
     , hedgehog
     , hspec >=2.8.3 && <3
     , hspec-core >=2.8.3 && <3
@@ -973,6 +976,7 @@ test-suite graphql-engine-tests
     Hasura.GraphQL.NamespaceSpec
     Hasura.GraphQL.Parser.DirectivesTest
     Hasura.GraphQL.Parser.TestUtils
+    Hasura.GraphQL.Schema.Build.UpdateSpec
     Hasura.GraphQL.Schema.RemoteTest
     Hasura.IncrementalSpec
     Hasura.StreamingSubscriptionSpec
@@ -995,6 +999,10 @@ test-suite graphql-engine-tests
     Network.HTTP.Client.TransformableSpec
     Test.Aeson.Utils
     Test.Autodocodec.Extended
+    Test.Parser.Field
+    Test.Parser.Monad
+    Test.Parser.Internal
+    Test.Parser.Expectation
     Test.QuickCheck.Extended
 
 test-suite tests-hspec

server/src-lib/Hasura/Backends/Postgres/Instances/Schema.hs

@@ -7,7 +7,7 @@
 --
 -- Defines a 'Hasura.GraphQL.Schema.Backend.BackendSchema' type class instance for Postgres.
 module Hasura.Backends.Postgres.Instances.Schema
-  (
+  ( updateOperators,
   )
 where
 

server/src-lib/Hasura/Backends/Postgres/Types/Update.hs

@@ -19,7 +19,7 @@ data BackendUpdate v = BackendUpdate
   { -- | The update operations to perform on each colum.
     updateOperations :: !(HashMap PGCol (UpdateOpExpression v))
   }
-  deriving (Functor, Foldable, Traversable, Generic, Data)
+  deriving (Functor, Foldable, Traversable, Generic, Data, Show, Eq)
 
 -- | The various @update operators@ supported by PostgreSQL,
 -- i.e. the @_set@, @_inc@ operators that appear in the schema.
@@ -33,4 +33,4 @@ data UpdateOpExpression v
   | UpdateDeleteKey !v
   | UpdateDeleteElem !v
   | UpdateDeleteAtPath ![v]
-  deriving (Functor, Foldable, Traversable, Generic, Data)
+  deriving (Functor, Foldable, Traversable, Generic, Data, Show, Eq)

server/src-lib/Hasura/GraphQL/Parser/Schema.hs

@@ -72,6 +72,7 @@ import Language.GraphQL.Draft.Syntax
     Value (..),
   )
 import Language.GraphQL.Draft.Syntax qualified as G
+import Language.Haskell.TH.Lift qualified as TH
 
 class HasName a where
   getName :: a -> Name
@@ -714,7 +715,7 @@ JSON values, but fortunately, the duplication of logic is minimal. -}
 data InputValue v
   = GraphQLValue (Value v)
   | JSONValue J.Value
-  deriving (Show, Eq, Functor, Generic, Ord)
+  deriving (Show, Eq, Functor, Generic, Ord, TH.Lift)
 
 instance (Hashable v) => Hashable (InputValue v)
 
@@ -727,7 +728,7 @@ data Variable = Variable
     -- non-null default value, this field contains the default value, not 'VNull'.
     vValue :: InputValue Void
   }
-  deriving (Show, Eq, Generic, Ord)
+  deriving (Show, Eq, Generic, Ord, TH.Lift)
 
 instance Hashable Variable
 
@@ -739,7 +740,7 @@ data VariableInfo
     -- default value are indistinguishable from variables with a default value
     -- of null, so we don’t distinguish those cases here.
     VIOptional Name (Value Void)
-  deriving (Show, Eq, Generic, Ord)
+  deriving (Show, Eq, Generic, Ord, TH.Lift)
 
 instance Hashable VariableInfo
 

server/src-lib/Hasura/RQL/IR/Returning.hs

@@ -31,9 +31,25 @@ data MutFldG (b :: BackendType) (r :: Type) v
   = MCount
   | MExp !Text
   | MRet !(AnnFieldsG b r v)
-  deriving (Functor, Foldable, Traversable)
+  deriving stock (Functor, Foldable, Traversable)
 
-deriving instance (Show r, Backend b, Show (BooleanOperators b a), Show (FunctionArgumentExp b a), Show a) => Show (MutFldG b r a)
+deriving stock instance
+  ( Show r,
+    Backend b,
+    Show (BooleanOperators b a),
+    Show (FunctionArgumentExp b a),
+    Show a
+  ) =>
+  Show (MutFldG b r a)
+
+deriving stock instance
+  ( Backend b,
+    Eq (BooleanOperators b a),
+    Eq (FunctionArgumentExp b a),
+    Eq r,
+    Eq a
+  ) =>
+  Eq (MutFldG b r a)
 
 type MutFld b = MutFldG b Void (SQLExpression b)
 
@@ -44,7 +60,24 @@ data MutationOutputG (b :: BackendType) (r :: Type) v
   | MOutSinglerowObject !(AnnFieldsG b r v)
   deriving (Functor, Foldable, Traversable)
 
-deriving instance (Show (MutFldsG b r a), Show r, Backend b, Show (BooleanOperators b a), Show (FunctionArgumentExp b a), Show a) => Show (MutationOutputG b r a)
+deriving stock instance
+  ( Backend b,
+    Show (BooleanOperators b a),
+    Show (MutFldsG b r a),
+    Show (FunctionArgumentExp b a),
+    Show r,
+    Show a
+  ) =>
+  Show (MutationOutputG b r a)
+
+deriving stock instance
+  ( Backend b,
+    Eq (BooleanOperators b a),
+    Eq (FunctionArgumentExp b a),
+    Eq r,
+    Eq a
+  ) =>
+  Eq (MutationOutputG b r a)
 
 type MutationOutput b = MutationOutputG b Void (SQLExpression b)
 

server/src-lib/Hasura/RQL/IR/Root.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Hasura.RQL.IR.Root
   ( SourceConfigWith (..),
     RootField (..),

server/src-lib/Hasura/RQL/IR/Select.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -1012,6 +1013,15 @@ data
     _rssJoinMapping :: (HM.HashMap FieldName (ScalarType tgt, Column tgt))
   }
 
+deriving stock instance
+  ( Backend tgt,
+    Eq (BooleanOperators tgt (vf tgt)),
+    Eq (FunctionArgumentExp tgt (vf tgt)),
+    Eq (vf tgt),
+    Eq r
+  ) =>
+  Eq (RemoteSourceSelect r vf tgt)
+
 -- Permissions
 
 data TablePermG (b :: BackendType) v = TablePerm

server/src-lib/Hasura/RQL/IR/Update.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Hasura.RQL.IR.Update
   ( AnnotatedUpdate,
@@ -30,10 +31,32 @@ data AnnotatedUpdateG (b :: BackendType) (r :: Type) v = AnnotatedUpdateG
     -- we don't prepare the arguments for returning
     -- however the session variable can still be
     -- converted as desired
+
+    -- | Selection set
     _auOutput :: !(MutationOutputG b r v),
     _auAllCols :: ![ColumnInfo b]
   }
-  deriving (Functor, Foldable, Traversable)
+  deriving stock (Functor, Foldable, Traversable)
+
+deriving stock instance
+  ( Backend b,
+    Eq (BooleanOperators b v),
+    Eq (BackendUpdate b v),
+    Eq (FunctionArgumentExp b v),
+    Eq r,
+    Eq v
+  ) =>
+  Eq (AnnotatedUpdateG b r v)
+
+deriving stock instance
+  ( Backend b,
+    Show (BooleanOperators b v),
+    Show (BackendUpdate b v),
+    Show (FunctionArgumentExp b v),
+    Show r,
+    Show v
+  ) =>
+  Show (AnnotatedUpdateG b r v)
 
 type AnnotatedUpdate b = AnnotatedUpdateG b Void (SQLExpression b)
 

server/src-test/Hasura/GraphQL/Schema/Build/UpdateSpec.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+-- | This module is a stub/example for how to write tests for the update field
+-- parsers.
+--
+-- Please see Test.Parser.Expectation for how to build these tests.
+module Hasura.GraphQL.Schema.Build.UpdateSpec (spec) where
+
+import Hasura.Backends.Postgres.SQL.Types (PGScalarType (..))
+import Hasura.Backends.Postgres.SQL.Value (PGScalarValue (..))
+import Hasura.Backends.Postgres.Types.Update (UpdateOpExpression (..))
+import Hasura.GraphQL.Parser.Column (UnpreparedValue (..))
+import Hasura.Prelude
+import Hasura.RQL.IR.BoolExp (OpExpG (..))
+import Hasura.RQL.IR.Returning (MutFldG (..), MutationOutputG (..))
+import Hasura.RQL.Types.Column (ColumnType (..), ColumnValue (..))
+import Hasura.RQL.Types.Instances ()
+import Hasura.SQL.Backend (BackendType (Postgres), PostgresKind (Vanilla))
+import Language.GraphQL.Draft.Syntax qualified as Syntax
+import Test.Hspec
+import Test.Parser.Expectation
+import Test.Parser.Field qualified as GQL
+
+type PG = 'Postgres 'Vanilla
+
+-- | These tests are samples and happy path testers.
+--
+-- Given a table with one or two columns, perform a simple update. There are no
+-- permission restrictions. It's also only using text fields and 'UpdateSet'.
+spec :: Spec
+spec = describe "Simple update" do
+  it "single column" do
+    runUpdateFieldTest
+      UpdateTestSetup
+        { utsTable = "artist",
+          utsColumns = [nameColumn],
+          utsExpect =
+            UpdateExpectationBuilder
+              { utbOutput = MOutMultirowFields [("affected_rows", MCount)],
+                utbWhere = [(nameColumn, [AEQ True oldValue])],
+                utbUpdate = [(nameColumn, UpdateSet newValue)]
+              },
+          utsField =
+            [GQL.field|
+update_artist(
+  where: { name: { _eq: "old name"}},
+  _set: { name: "new name" }
+) {
+  affected_rows
+}
+|]
+        }
+
+  it "two columns" do
+    runUpdateFieldTest
+      UpdateTestSetup
+        { utsTable = "artist",
+          utsColumns = [nameColumn, descColumn],
+          utsExpect =
+            UpdateExpectationBuilder
+              { utbOutput = MOutMultirowFields [("affected_rows", MCount)],
+                utbWhere = [(nameColumn, [AEQ True oldValue])],
+                utbUpdate =
+                  [ (nameColumn, UpdateSet newValue),
+                    (descColumn, UpdateSet otherValue)
+                  ]
+              },
+          utsField =
+            [GQL.field|
+update_artist(
+  where: { name: { _eq: "old name"}},
+  _set: { name: "new name", description: "other" }
+) {
+  affected_rows
+}
+|]
+        }
+
+nameColumn :: ColumnInfoBuilder
+nameColumn =
+  ColumnInfoBuilder
+    { cibName = "name",
+      cibType = ColumnScalar PGText,
+      cibNullable = False
+    }
+
+oldValue :: UnpreparedValue PG
+oldValue =
+  UVParameter Nothing $
+    ColumnValue
+      { cvType = ColumnScalar PGText,
+        cvValue = PGValText "old name"
+      }
+
+newValue :: UnpreparedValue PG
+newValue =
+  UVParameter Nothing $
+    ColumnValue
+      { cvType = ColumnScalar PGText,
+        cvValue = PGValText "new name"
+      }
+
+descColumn :: ColumnInfoBuilder
+descColumn =
+  ColumnInfoBuilder
+    { cibName = "description",
+      cibType = ColumnScalar PGText,
+      cibNullable = False
+    }
+
+otherValue :: UnpreparedValue PG
+otherValue =
+  UVParameter Nothing $
+    ColumnValue
+      { cvType = ColumnScalar PGText,
+        cvValue = PGValText "other"
+      }

server/src-test/Main.hs

@@ -36,6 +36,7 @@ import Hasura.Backends.Postgres.Execute.Types
 import Hasura.EventingSpec qualified as EventingSpec
 import Hasura.GraphQL.NamespaceSpec qualified as NamespaceSpec
 import Hasura.GraphQL.Parser.DirectivesTest qualified as GraphQLDirectivesSpec
+import Hasura.GraphQL.Schema.Build.UpdateSpec qualified as UpdateSpec
 import Hasura.GraphQL.Schema.RemoteTest qualified as GraphRemoteSchemaSpec
 import Hasura.IncrementalSpec qualified as IncrementalSpec
 import Hasura.Logging
@@ -120,6 +121,7 @@ unitSpecs = do
   describe "Hasura.GraphQL.Namespace" NamespaceSpec.spec
   describe "Hasura.GraphQL.Parser.Directives" GraphQLDirectivesSpec.spec
   describe "Hasura.GraphQL.Schema.Remote" GraphRemoteSchemaSpec.spec
+  describe "Hasura.GraphQL.Schema.Build.UpdateSpec" UpdateSpec.spec
   describe "Hasura.Incremental" IncrementalSpec.spec
   describe "Hasura.RQL.IR.SelectSpec" SelectSpec.spec
   describe "Hasura.RQL.MetadataSpec" MetadataSpec.spec

server/src-test/Test/Parser/Expectation.hs

@@ -0,0 +1,167 @@
+-- | Build expectations for GraphQL field parsers. For now it focuses on updates
+-- only.
+--
+-- See 'runUpdateFieldTest'.
+module Test.Parser.Expectation
+  ( UpdateTestSetup (..),
+    UpdateExpectationBuilder (..),
+    runUpdateFieldTest,
+    module I,
+  )
+where
+
+import Data.Bifunctor (bimap)
+import Data.HashMap.Strict qualified as HM
+import Hasura.Backends.Postgres.SQL.Types (QualifiedTable)
+import Hasura.Backends.Postgres.Types.Update (BackendUpdate (..), UpdateOpExpression (..))
+import Hasura.GraphQL.Parser.Column (UnpreparedValue)
+import Hasura.GraphQL.Parser.Internal.Parser (FieldParser (..))
+import Hasura.GraphQL.Parser.Schema (Variable)
+import Hasura.Prelude
+import Hasura.RQL.IR.BoolExp (AnnBoolExpFld (..), GBoolExp (..), OpExpG (..))
+import Hasura.RQL.IR.Returning (MutationOutputG (..))
+import Hasura.RQL.IR.Root (RemoteRelationshipField)
+import Hasura.RQL.IR.Update (AnnotatedUpdateG (..))
+import Hasura.RQL.Types.Column (ColumnInfo (..))
+import Hasura.RQL.Types.Instances ()
+import Hasura.SQL.Backend (BackendType (Postgres), PostgresKind (Vanilla))
+import Language.GraphQL.Draft.Syntax qualified as Syntax
+import Test.Hspec
+import Test.Parser.Internal
+import Test.Parser.Internal as I (ColumnInfoBuilder (..))
+import Test.Parser.Monad
+
+type PG = 'Postgres 'Vanilla
+
+type BoolExp = GBoolExp PG (AnnBoolExpFld PG (UnpreparedValue PG))
+
+type Output = MutationOutputG PG (RemoteRelationshipFieldWrapper UnpreparedValue) (UnpreparedValue PG)
+
+type Field = Syntax.Field Syntax.NoFragments Variable
+
+type Where = (ColumnInfoBuilder, [OpExpG PG (UnpreparedValue PG)])
+
+type Update = (ColumnInfoBuilder, UpdateOpExpression (UnpreparedValue PG))
+
+-- | Holds all the information required to setup and run a field parser update
+-- test.
+data UpdateTestSetup = UpdateTestSetup
+  { -- | name of the table
+    utsTable :: Text,
+    -- | table columns
+    utsColumns :: [ColumnInfoBuilder],
+    -- | expectation
+    utsExpect :: UpdateExpectationBuilder,
+    -- | GrqphQL field, see Test.Parser.Parser
+    utsField :: Field
+  }
+
+-- | Build the expected output columns, where and update clauses.
+data UpdateExpectationBuilder = UpdateExpectationBuilder
+  { -- | build the expected selection set/output, e.g.
+    --
+    -- > MOutMultirowFields [("affected_rows", MCount)]
+    utbOutput :: Output,
+    -- | expected where condition(s), e.g. given a @nameColumn ::
+    -- ColumnInfoBuilder@ and @oldValue :: UnpreparedValue PG@:
+    --
+    -- > [(nameColumn, [AEQ true oldvalue])]
+    utbWhere :: [Where],
+    -- | expected update clause(s), e.g. given a @nameColumn ::
+    -- ColumnInfoBuilder@ and @newValue :: UnpreparedValue PG@:
+    --
+    -- > [(namecolumn, UpdateSet newValue)]
+    utbUpdate :: [Update]
+  }
+
+-- | Run a test given the schema and field.
+runUpdateFieldTest :: UpdateTestSetup -> Expectation
+runUpdateFieldTest UpdateTestSetup {..} =
+  case mkParser table utsColumns of
+    SchemaTestT [] -> expectationFailure "expected at least one parser"
+    SchemaTestT (FieldParser {fParser} : _xs) ->
+      case fParser utsField of
+        ParserTestT (Right annUpdate) -> do
+          coerce annUpdate `shouldBe` expected
+        ParserTestT (Left err) -> err
+  where
+    UpdateExpectationBuilder {..} = utsExpect
+
+    table :: QualifiedTable
+    table = mkTable utsTable
+
+    expected :: AnnotatedUpdateG PG (RemoteRelationshipFieldWrapper UnpreparedValue) (UnpreparedValue PG)
+    expected =
+      mkAnnotatedUpdate
+        AnnotatedUpdateBuilder
+          { aubTable = table,
+            aubOutput = utbOutput,
+            aubColumns = mkColumnInfo <$> utsColumns,
+            aubWhere = first mkColumnInfo <$> utbWhere,
+            aubUpdate = first mkColumnInfo <$> utbUpdate
+          }
+
+-- | Internal use only. The intended use is through 'runUpdateFieldTest'.
+--
+-- Build an 'AnnotatedUpdateG', to be used with 'mkAnnotatedUpdate'.
+data AnnotatedUpdateBuilder = AnnotatedUpdateBuilder
+  { -- | the main table for the update
+    aubTable :: QualifiedTable,
+    -- | the 'Output' clause, e.g., selection set, affected_rows, etc.
+    aubOutput :: Output,
+    -- | the table columns (all of them)
+    aubColumns :: [ColumnInfo PG],
+    -- | the where clause(s)
+    aubWhere :: [(ColumnInfo PG, [OpExpG PG (UnpreparedValue PG)])],
+    -- | the update statement(s)
+    aubUpdate :: [(ColumnInfo PG, UpdateOpExpression (UnpreparedValue PG))]
+  }
+
+-- | 'RemoteRelationshipField' cannot have Eq/Show instances, so we're wrapping
+-- it.
+newtype RemoteRelationshipFieldWrapper vf = RemoteRelationshipFieldWrapper (RemoteRelationshipField vf)
+
+instance Show (RemoteRelationshipFieldWrapper vf) where
+  show =
+    error "Test.Parser.Expectation: no Show implementation for RemoteRelationshipFieldWrapper"
+
+instance Eq (RemoteRelationshipFieldWrapper vf) where
+  (==) =
+    error "Test.Parser.Expectation: no Eq implementation for RemoteRelationshipFieldWrapper"
+
+-- | Internal use, see 'runUpdateFieldTest'.
+mkAnnotatedUpdate ::
+  AnnotatedUpdateBuilder ->
+  AnnotatedUpdateG PG (RemoteRelationshipFieldWrapper UnpreparedValue) (UnpreparedValue PG)
+mkAnnotatedUpdate AnnotatedUpdateBuilder {..} = AnnotatedUpdateG {..}
+  where
+    _auTable :: QualifiedTable
+    _auTable = aubTable
+
+    _auWhere :: (BoolExp, BoolExp)
+    _auWhere =
+      ( column [],
+        BoolAnd $ fmap (\(c, ops) -> BoolFld $ AVColumn c ops) aubWhere
+      )
+
+    _auCheck :: BoolExp
+    _auCheck = BoolAnd []
+
+    _auBackend :: BackendUpdate (UnpreparedValue PG)
+    _auBackend =
+      BackendUpdate
+        { updateOperations =
+            HM.fromList $ fmap (bimap ciColumn id) aubUpdate
+        }
+
+    _auOutput :: Output
+    _auOutput = aubOutput
+
+    _auAllCols :: [ColumnInfo PG]
+    _auAllCols = aubColumns
+
+    column :: [OpExpG PG (UnpreparedValue PG)] -> BoolExp
+    column stuff =
+      BoolAnd
+        . fmap (\c -> BoolFld . AVColumn c $ stuff)
+        $ aubColumns

server/src-test/Test/Parser/Field.hs

@@ -0,0 +1,47 @@
+-- | QuasiQuoter for parsing GraphQL fields in tests. See 'field' for details.
+module Test.Parser.Field (field) where
+
+import Data.Attoparsec.Text qualified as Parser
+import Data.Text qualified as T
+import Hasura.GraphQL.Parser.Schema (Variable)
+import Hasura.Prelude
+import Language.GraphQL.Draft.Parser qualified as GraphQL
+import Language.GraphQL.Draft.Syntax qualified as GraphQL
+import Language.Haskell.TH.Lib (ExpQ)
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax qualified as TH
+import Unsafe.Coerce (unsafeCoerce)
+
+-- | Warning: we are currently using unsafe coercions to convert the field. This
+-- seems to work for now, but beware.
+--
+-- Example usage:
+-- > [GQL.field|
+-- >    update_artist(
+-- >      where: { name: { _eq: "old name"}},
+-- >      _set: { name: "new name" }
+-- >    ) {
+-- >    affected_rows
+-- >    }
+-- > |],
+field :: QuasiQuoter
+field =
+  QuasiQuoter
+    { quoteExp = evalFieldGQL,
+      quotePat = \_ -> fail "invalid",
+      quoteType = \_ -> fail "invalid",
+      quoteDec = \_ -> fail "invalid"
+    }
+
+evalFieldGQL :: String -> ExpQ
+evalFieldGQL = either fail TH.lift . go
+  where
+    -- Note: @skipSpace@ is used here to allow trailing whitespace in the QQ.
+    go :: String -> Either String (GraphQL.Field GraphQL.NoFragments Variable)
+    go =
+      fmap fixField
+        . Parser.parseOnly (Parser.skipSpace *> GraphQL.field @GraphQL.Name)
+        . T.pack
+
+fixField :: GraphQL.Field GraphQL.FragmentSpread GraphQL.Name -> GraphQL.Field GraphQL.NoFragments Variable
+fixField = unsafeCoerce

server/src-test/Test/Parser/Internal.hs

@@ -0,0 +1,206 @@
+-- | Internal helper module. Some things re-exported by
+-- 'Test.Parser.Expectation'.
+module Test.Parser.Internal
+  ( mkTable,
+    ColumnInfoBuilder (..),
+    mkColumnInfo,
+    mkParser,
+  )
+where
+
+import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
+import Data.Text.Casing qualified as C
+import Hasura.Backends.Postgres.Instances.Schema (updateOperators)
+import Hasura.Backends.Postgres.SQL.Types (QualifiedObject (..), QualifiedTable, TableName (..), unsafePGCol)
+import Hasura.Backends.Postgres.Types.Update (BackendUpdate (..))
+import Hasura.GraphQL.Parser.Column (UnpreparedValue (..))
+import Hasura.GraphQL.Parser.Internal.Input (InputFieldsParser)
+import Hasura.GraphQL.Parser.Internal.Parser (FieldParser (..))
+import Hasura.GraphQL.Schema.Build qualified as Build
+import Hasura.Prelude
+import Hasura.RQL.IR.BoolExp (AnnBoolExpFld (..), GBoolExp (..), PartialSQLExp (..))
+import Hasura.RQL.IR.Root (RemoteRelationshipField)
+import Hasura.RQL.IR.Update (AnnotatedUpdateG (..))
+import Hasura.RQL.Types.Column (ColumnInfo (..), ColumnMutability (..), ColumnType (..))
+import Hasura.RQL.Types.Common (Comment (..), FieldName (..), SourceName, SystemDefined (..))
+import Hasura.RQL.Types.Instances ()
+import Hasura.RQL.Types.Table (CustomRootField (..), FieldInfo (..), RolePermInfo (..), SelPermInfo (..), TableConfig (..), TableCoreInfoG (..), TableCustomRootFields (..), TableInfo (..), UpdPermInfo (..))
+import Hasura.SQL.Backend (BackendType (Postgres), PostgresKind (Vanilla))
+import Language.GraphQL.Draft.Syntax (unsafeMkName)
+import Test.Parser.Monad
+
+type PG = 'Postgres 'Vanilla
+
+type Parser = FieldParser ParserTestT (AnnotatedUpdateG PG (RemoteRelationshipField UnpreparedValue) (UnpreparedValue PG))
+
+-- | Create a table by its name, using the public schema.
+mkTable :: Text -> QualifiedTable
+mkTable name =
+  QualifiedObject
+    { qSchema = "public",
+      qName = TableName name
+    }
+
+-- | Build a column, see 'mkColumnInfo'.
+data ColumnInfoBuilder = ColumnInfoBuilder
+  { -- | name of the column
+    cibName :: Text,
+    -- | Column type, e.g.
+    --
+    -- > ColumnScalar PGText
+    cibType :: ColumnType PG,
+    -- | whether the column is nullable or not
+    cibNullable :: Bool
+  }
+
+-- | Create a column using the provided 'ColumnInfoBuilder' and defaults.
+--
+-- Note that all permissions are enabled by default.
+mkColumnInfo :: ColumnInfoBuilder -> ColumnInfo PG
+mkColumnInfo ColumnInfoBuilder {..} =
+  ColumnInfo
+    { ciColumn = unsafePGCol cibName,
+      ciName = unsafeMkName cibName,
+      ciPosition = 0,
+      ciType = cibType,
+      ciIsNullable = cibNullable,
+      ciDescription = Nothing,
+      ciMutability = columnMutability
+    }
+  where
+    columnMutability :: ColumnMutability
+    columnMutability =
+      ColumnMutability
+        { _cmIsInsertable = True,
+          _cmIsUpdatable = True
+        }
+
+-- | Create a parser for the provided table and columns.
+--
+-- No special permissions, required headers, filters, etc., are set.
+--
+-- This will not work for inserts and deletes (see @rolePermInfo@ below).
+mkParser :: QualifiedTable -> [ColumnInfoBuilder] -> SchemaTestT [Parser]
+mkParser table cib =
+  Build.buildTableUpdateMutationFields
+    backendUpdateParser
+    sourceName
+    table
+    tableInfo
+    name
+  where
+    backendUpdateParser ::
+      TableInfo PG ->
+      SchemaTestT (InputFieldsParser ParserTestT (BackendUpdate (UnpreparedValue PG)))
+    backendUpdateParser ti =
+      fmap BackendUpdate <$> updateOperators ti updPermInfo
+
+    updPermInfo :: UpdPermInfo PG
+    updPermInfo =
+      UpdPermInfo
+        { upiCols = HS.fromList . fmap (unsafePGCol . cibName) $ cib,
+          upiTable = table,
+          upiFilter = upiFilter,
+          upiCheck = Nothing,
+          upiSet = mempty,
+          upiRequiredHeaders = mempty
+        }
+
+    columnInfos :: [ColumnInfo PG]
+    columnInfos = mkColumnInfo <$> cib
+
+    upiFilter :: GBoolExp PG (AnnBoolExpFld PG (PartialSQLExp PG))
+    upiFilter = BoolAnd $ fmap (\ci -> BoolFld $ AVColumn ci []) columnInfos
+
+    ------------------------------------------
+    sourceName :: SourceName
+    sourceName = undefined
+
+    ------------------------------------------
+    tableInfo :: TableInfo PG
+    tableInfo =
+      TableInfo
+        { _tiCoreInfo = tableCoreInfo,
+          _tiRolePermInfoMap = mempty,
+          _tiEventTriggerInfoMap = mempty,
+          _tiAdminRolePermInfo = rolePermInfo
+        }
+
+    tableCoreInfo :: TableCoreInfoG PG (FieldInfo PG) (ColumnInfo PG)
+    tableCoreInfo =
+      TableCoreInfo
+        { _tciName = table,
+          _tciDescription = Nothing,
+          _tciSystemDefined = SystemDefined False,
+          _tciFieldInfoMap = fieldInfoMap,
+          _tciPrimaryKey = Nothing,
+          _tciUniqueConstraints = mempty,
+          _tciForeignKeys = mempty,
+          _tciViewInfo = Nothing,
+          _tciEnumValues = Nothing,
+          _tciCustomConfig = tableConfig,
+          _tciExtraTableMetadata = ()
+        }
+
+    rolePermInfo :: RolePermInfo PG
+    rolePermInfo =
+      RolePermInfo
+        { _permIns = Nothing,
+          _permSel = Just selPermInfo,
+          _permUpd = Just updPermInfo,
+          _permDel = Nothing
+        }
+
+    fieldInfoMap :: HM.HashMap FieldName (FieldInfo PG)
+    fieldInfoMap =
+      HM.fromList
+        . fmap toHashPair
+        $ cib
+
+    tableConfig :: TableConfig PG
+    tableConfig =
+      TableConfig
+        { _tcCustomRootFields = tableCustomRootFields,
+          _tcColumnConfig = mempty,
+          _tcCustomName = Nothing,
+          _tcComment = Automatic
+        }
+
+    selPermInfo :: SelPermInfo PG
+    selPermInfo =
+      SelPermInfo
+        { spiCols = HM.fromList . fmap ((,Nothing) . unsafePGCol . cibName) $ cib,
+          spiScalarComputedFields = mempty,
+          spiFilter = upiFilter,
+          spiLimit = Nothing,
+          spiAllowAgg = True,
+          spiRequiredHeaders = mempty
+        }
+
+    tableCustomRootFields :: TableCustomRootFields
+    tableCustomRootFields =
+      TableCustomRootFields
+        { _tcrfSelect = customRootField,
+          _tcrfSelectByPk = customRootField,
+          _tcrfSelectAggregate = customRootField,
+          _tcrfInsert = customRootField,
+          _tcrfInsertOne = customRootField,
+          _tcrfUpdate = customRootField,
+          _tcrfUpdateByPk = customRootField,
+          _tcrfDelete = customRootField,
+          _tcrfDeleteByPk = customRootField
+        }
+
+    customRootField :: CustomRootField
+    customRootField =
+      CustomRootField
+        { _crfName = Nothing,
+          _crfComment = Automatic
+        }
+    ------------------------------------------
+    name :: C.GQLNameIdentifier
+    name = C.fromName $ unsafeMkName "test"
+
+toHashPair :: ColumnInfoBuilder -> (FieldName, FieldInfo PG)
+toHashPair cib = (coerce $ cibName cib, FIColumn $ mkColumnInfo cib)

server/src-test/Test/Parser/Monad.hs

@@ -0,0 +1,161 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+-- | This module defines the monads required to run parser tests.
+--
+-- Warning: a lot of the implementations are currently 'undefined'. As we write
+-- more advanced tests, they might require implementations.
+module Test.Parser.Monad
+  ( ParserTestT (..),
+    SchemaEnvironment,
+    SchemaTestT (..),
+  )
+where
+
+import Data.Aeson.Internal (JSONPath)
+import Data.Has (Has (..))
+import Data.Text qualified as T
+import Hasura.Base.Error (Code, QErr)
+import Hasura.GraphQL.Execute.Types (GraphQLQueryType (..))
+import Hasura.GraphQL.Parser.Class (MonadParse (..), MonadSchema (..))
+import Hasura.GraphQL.Parser.Schema (MkTypename (..))
+import Hasura.GraphQL.Schema.Common (QueryContext (..))
+import Hasura.Prelude
+import Hasura.RQL.Types.Common (StringifyNumbers (LeaveNumbersAlone))
+import Hasura.RQL.Types.Function (FunctionPermissionsCtx (..))
+import Hasura.RQL.Types.RemoteSchema (RemoteSchemaPermsCtx (..))
+import Hasura.RQL.Types.SchemaCache (RemoteSchemaMap)
+import Hasura.RQL.Types.Source (SourceCache)
+import Hasura.RQL.Types.SourceCustomization (CustomizeRemoteFieldName, MkRootFieldName, NamingCase (..))
+import Hasura.Session (RoleName, adminRoleName)
+import Language.Haskell.TH.Syntax qualified as TH
+import Test.Hspec
+
+notImplemented :: String -> a
+notImplemented location =
+  error $ "Not implemented: Test.Parser.Monad." <> location
+
+-- | Monad builder environment.
+--
+-- Parser functions generally have a return type of @m (Parser n)@. The @m@
+-- parameter is mocked through 'SchemaTestT', which requires a bunch of 'Has'
+-- instances, as well as a 'ReaderT' instance for environment
+-- settings/configurations. This type repesents these settings.
+--
+-- SchemaEnvironment: currently void. This is subject to change if we require
+-- more complex setup.
+data SchemaEnvironment
+
+instance Has NamingCase SchemaEnvironment where
+  getter :: SchemaEnvironment -> NamingCase
+  getter = const HasuraCase
+
+  modifier :: (NamingCase -> NamingCase) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has NamingCase SchemaEnvironment>"
+
+instance Has SourceCache SchemaEnvironment where
+  getter :: SchemaEnvironment -> SourceCache
+  getter = notImplemented "getter<Has SourceCache SchemaEnvironment>"
+
+  modifier :: (SourceCache -> SourceCache) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has SourceCache SchemaEnvironment>"
+
+instance Has RemoteSchemaMap SchemaEnvironment where
+  getter :: SchemaEnvironment -> RemoteSchemaMap
+  getter = notImplemented "getter<Has RemoteSchemaMap SchemaEnvironment>"
+
+  modifier :: (RemoteSchemaMap -> RemoteSchemaMap) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has RemoteSchemaMap SchemaEnvironment>"
+
+instance Has RoleName SchemaEnvironment where
+  getter :: SchemaEnvironment -> RoleName
+  getter = const adminRoleName
+
+  modifier :: (RoleName -> RoleName) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has RoleName SchemaEnvironment>"
+
+queryContext :: QueryContext
+queryContext =
+  QueryContext
+    { qcStringifyNum = LeaveNumbersAlone,
+      qcDangerousBooleanCollapse = False,
+      qcQueryType = QueryHasura,
+      qcFunctionPermsContext = FunctionPermissionsInferred,
+      qcRemoteSchemaPermsCtx = RemoteSchemaPermsDisabled,
+      qcOptimizePermissionFilters = False
+    }
+
+instance Has QueryContext SchemaEnvironment where
+  getter :: SchemaEnvironment -> QueryContext
+  getter = const queryContext
+
+  modifier :: (QueryContext -> QueryContext) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has QueryContext SchemaEnvironment>"
+
+instance Has MkTypename SchemaEnvironment where
+  getter :: SchemaEnvironment -> MkTypename
+  getter = const (MkTypename id)
+
+  modifier :: (MkTypename -> MkTypename) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has MkTypeName SchemaEnvironment>"
+
+instance Has MkRootFieldName SchemaEnvironment where
+  getter :: SchemaEnvironment -> MkRootFieldName
+  getter = const mempty
+
+  modifier :: (MkRootFieldName -> MkRootFieldName) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has MkRootFieldName SchemaEnvironment>"
+
+instance Has CustomizeRemoteFieldName SchemaEnvironment where
+  getter :: SchemaEnvironment -> CustomizeRemoteFieldName
+  getter = notImplemented "getter<Has CustomizeRemoteFieldName SchemaEnvironment>"
+
+  modifier :: (CustomizeRemoteFieldName -> CustomizeRemoteFieldName) -> SchemaEnvironment -> SchemaEnvironment
+  modifier = notImplemented "modifier<Has CustomizeRemoteFieldName SchemaEnvironment>"
+
+-------------------------------------------------------------------------------
+
+-- | SchemaTestT
+newtype SchemaTestT a = SchemaTestT a
+  deriving stock (Functor)
+  deriving (Applicative, Monad) via Identity
+
+instance MonadError QErr SchemaTestT where
+  throwError :: forall a. QErr -> SchemaTestT a
+  throwError = notImplemented "throwError<MonadError QErr SchemaTestT>"
+
+  catchError :: forall a. SchemaTestT a -> (QErr -> SchemaTestT a) -> SchemaTestT a
+  catchError = notImplemented "catchError<MonadError QErr SchemaTestT>"
+
+-- | Note this is not used because all the actual getters/setters for
+-- SchemaEnvironment are @const X@, so these bottoms never actually get
+-- evaluated.
+instance MonadReader SchemaEnvironment SchemaTestT where
+  ask :: SchemaTestT SchemaEnvironment
+  ask = notImplemented "ask<MonadReader SchemaEnvironment SchemaTestT>"
+
+  local :: (SchemaEnvironment -> SchemaEnvironment) -> SchemaTestT a -> SchemaTestT a
+  local = notImplemented "local<MonadReader SchemaEnvironment SchemaTestT>"
+
+-------------------------------------------------------------------------------
+
+-- | ParserTestT
+--
+-- Encodes an assertion error (as `Left`) or a value as `Right`.
+newtype ParserTestT a = ParserTestT (Either (IO ()) a)
+  deriving stock (Functor)
+  deriving (Applicative, Monad) via (Either (IO ()))
+
+instance MonadSchema ParserTestT SchemaTestT where
+  memoizeOn :: TH.Name -> a -> SchemaTestT (p ParserTestT b) -> SchemaTestT (p ParserTestT b)
+  memoizeOn _ _ = id
+
+instance MonadParse ParserTestT where
+  withPath :: (JSONPath -> JSONPath) -> ParserTestT a -> ParserTestT a
+  withPath = const id
+
+  parseErrorWith :: Code -> Text -> ParserTestT a
+  parseErrorWith code text =
+    ParserTestT
+      . Left
+      . expectationFailure
+      $ show code <> ": " <> T.unpack text