graphql-engine/server/src-test/Hasura/RQL/MetadataSpec.hs

module Hasura.RQL.MetadataSpec
  ( spec,

    -- ** Test Helpers
    trippingJSON,
    trippingJSONValue,
    trippingJSONEncoding,
  )
where

-------------------------------------------------------------------------------

import Control.Lens ((%~), (.~), (^?!))
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Lens (key, _Object)
import Data.HashMap.Strict qualified as HM
import Data.Text qualified as T
import Data.Yaml.TH (yamlQQ)
import GHC.Stack (HasCallStack)
import Hasura.Prelude hiding ((%~))
import Hasura.RQL.DDL.RemoteRelationship
  ( CreateFromSourceRelationship,
  )
import Hasura.RQL.Types.Metadata (Metadata)
import Hasura.SQL.Backend (BackendType (BigQuery, MSSQL, Postgres), PostgresKind (Vanilla))
import Hasura.Server.API.Metadata (RQLMetadataV1)
import Hasura.Server.API.Query qualified as V1 (RQLQuery)
import Hedgehog (MonadTest, evalEither, tripping)
import Test.Hspec (Spec, describe, expectationFailure, it)
import Test.Hspec.Hedgehog (hedgehog)

-------------------------------------------------------------------------------

spec :: Spec
spec = describe "Remote Relationship Metadata" do
  spec_roundtrip
  spec_Metadata_examples
  spec_RQLQuery_examples
  spec_RQLMetadataV1_examples

-------------------------------------------------------------------------------

spec_roundtrip :: Spec
spec_roundtrip = describe "JSON Roundtrip" do
  describe "Metadata" do
    it "example remote relationship fragment" $
      hedgehog do
        metadata :: Metadata <-
          evalAesonResult $
            Aeson.fromJSON remote_relationship_metadata_fragment
        trippingJSONValue metadata

  describe "CreateFromSourceRelationship" do
    it "'pg_create_remote_relationship' query" $
      hedgehog $ do
        let argument = mk_pg_remote_relationship_argument "create" ^?! key "args"
        cfsr :: (CreateFromSourceRelationship ('Postgres 'Vanilla)) <-
          evalAesonResult $ Aeson.fromJSON argument
        trippingJSON cfsr

    it "'pg_create_remote_relationship' query with the 'old' schema" $
      hedgehog $ do
        let argument = mk_pg_remote_relationship_old_argument "create" ^?! key "args"
        cfsr :: (CreateFromSourceRelationship ('Postgres 'Vanilla)) <-
          evalAesonResult $ Aeson.fromJSON argument
        trippingJSON cfsr

    it "'mssql_create_remote_relationship' query" $
      hedgehog $ do
        let argument = mk_mssql_remote_relationship_argument "create" ^?! key "args"
        cfsr :: (CreateFromSourceRelationship 'MSSQL) <-
          evalAesonResult $ Aeson.fromJSON argument
        trippingJSON cfsr

    it "'bigquery_create_remote_relationship' query" $
      hedgehog $ do
        let argument = mk_bigquery_remote_relationship_argument "create" ^?! key "args"
        cfsr :: (CreateFromSourceRelationship 'BigQuery) <-
          evalAesonResult $ Aeson.fromJSON argument
        trippingJSON cfsr

-------------------------------------------------------------------------------

spec_Metadata_examples :: Spec
spec_Metadata_examples = describe "Metadata" $ do
  it "parses an example remote relationship metadata fragment" do
    case Aeson.fromJSON @Metadata remote_relationship_metadata_fragment of
      Aeson.Success _ -> pure ()
      Aeson.Error err -> expectationFailure err

-------------------------------------------------------------------------------

spec_RQLQuery_examples :: Spec
spec_RQLQuery_examples = describe "V1 RQLQuery" do
  it "parses a 'create_remote_relationship' query with the 'old' schema" do
    case Aeson.fromJSON @V1.RQLQuery create_remote_relationship_argument of
      Aeson.Success _ -> pure ()
      Aeson.Error err -> expectationFailure err

-------------------------------------------------------------------------------

spec_RQLMetadataV1_examples :: Spec
spec_RQLMetadataV1_examples = describe "RQLMetadataV1" do
  describe "Success" do
    for_ ["create", "update", "delete"] \action ->
      it ("parses a 'pg_" <> T.unpack action <> "_remote_relationship query") do
        case Aeson.fromJSON @RQLMetadataV1 (mk_pg_remote_relationship_argument action) of
          Aeson.Success _ -> pure ()
          Aeson.Error err -> expectationFailure err

    for_ ["create", "update", "delete"] \action ->
      it ("parses a 'pg_" <> T.unpack action <> "_remote_relationship query using the 'old' schema") do
        case Aeson.fromJSON @RQLMetadataV1 (mk_pg_remote_relationship_old_argument action) of
          Aeson.Success _ -> pure ()
          Aeson.Error err -> expectationFailure err

    for_ ["create", "update", "delete"] \action ->
      it ("parses a 'citus_" <> T.unpack action <> "_remote_relationship query") do
        case Aeson.fromJSON @RQLMetadataV1 (mk_citus_remote_relationship_argument action) of
          Aeson.Success _ -> pure ()
          Aeson.Error err -> expectationFailure err

    for_ ["create", "update", "delete"] \action ->
      it ("parses a 'bigquery_" <> T.unpack action <> "_remote_relationship query") do
        case Aeson.fromJSON @RQLMetadataV1 (mk_bigquery_remote_relationship_argument action) of
          Aeson.Success _ -> pure ()
          Aeson.Error err -> expectationFailure err

  describe "Failure" do
    for_ ["create", "update", "delete"] \action ->
      it ("fails to parse an 'mssql_" <> T.unpack action <> "_remote_relationship query") do
        case Aeson.fromJSON @RQLMetadataV1 (mk_mssql_remote_relationship_argument action) of
          Aeson.Error _ -> pure ()
          Aeson.Success _ ->
            let errMsg = "expected 'mssql_" <> T.unpack action <> "' query to fail to parse"
             in expectationFailure errMsg

-------------------------------------------------------------------------------
-- Example YAML fragments for the metadata and query tests above.

remote_relationship_metadata_fragment :: Aeson.Value
remote_relationship_metadata_fragment =
  [yamlQQ|
version: 3
sources:
- name: something
  kind: postgres
  configuration:
    connection_info:
      database_url: something
  tables:
  - table: test
    remote_relationships:
    - name: remote
      definition:
        hasura_fields: [id]
        remote_field:
          some_fiend_name:
            arguments:
              id: $id
        remote_schema: some_remote_schema_name
    |]

create_remote_relationship_argument :: Aeson.Value
create_remote_relationship_argument =
  [yamlQQ|
type: create_remote_relationship
args:
  name: message
  table: profiles
  hasura_fields:
    - id
    - name
  remote_schema: my-remote-schema
  remote_field:
    message:
      arguments:
        id: "$id"
|]

-- | Backend-agnostic @v1/metadata@ argument fragment which omits the @type@
-- field.
--
-- This should be used to construct backend-specific fragments by adding the
-- correct type and/or modifying any of the fields specified here as needed.
--
-- See 'mk_backend_remote_relationship_argument for example usage.
backend_create_remote_relationship_fragment :: Aeson.Value
backend_create_remote_relationship_fragment =
  [yamlQQ|
args:
  name: message
  table: profiles
  definition:
    to_remote_schema:
      lhs_fields:
        - id
        - name
      remote_schema: my-remote-schema
      remote_field:
        message:
          arguments:
            id: "$id"
  |]

-- | Constructor for @v1/metadata@ @<backend>_(create|update|delete)_remote_relationship@
-- arguments using the new, unified schema.
--
-- See 'mk_pg_backend_remote_relationship_argument for example usage.
mk_backend_remote_relationship_argument :: Text -> Text -> Aeson.Value
mk_backend_remote_relationship_argument backend action =
  backend_create_remote_relationship_fragment
    & _Object
      %~ HM.insert
        ("type" :: Text)
        (Aeson.String $ backend <> "_" <> action <> "_remote_relationship")

-- | Constructor for @v1/metadata@ @mssql_(create|update|delete)_remote_relationship@
-- arguments using the new, unified schema.
mk_mssql_remote_relationship_argument :: Text -> Aeson.Value
mk_mssql_remote_relationship_argument action =
  mk_backend_remote_relationship_argument "mssql" action

-- | Constructor for @v1/metadata@ @citus_(create|update|delete)_remote_relationship@
-- arguments using the new, unified schema.
mk_citus_remote_relationship_argument :: Text -> Aeson.Value
mk_citus_remote_relationship_argument action =
  mk_backend_remote_relationship_argument "citus" action

-- | Constructor for @v1/metadata@ @pg_(create|update|delete)_remote_relationship@
-- arguments using the new, unified schema.
mk_pg_remote_relationship_argument :: Text -> Aeson.Value
mk_pg_remote_relationship_argument action =
  mk_backend_remote_relationship_argument "pg" action

-- | Constructor for @v1/metadata@ @bigquery_(create|update|delete)_remote_relationship@
-- arguments using the new, unified schema.
--
-- NOTE: The 'BigQuery' backend expects its @table@ argument to be of type
-- 'Aeson.Object' (all of the other backends support 'Aeson.String').
mk_bigquery_remote_relationship_argument :: Text -> Aeson.Value
mk_bigquery_remote_relationship_argument action =
  mk_backend_remote_relationship_argument "bigquery" action
    & key "args" . key "table"
      .~ ( Aeson.Object $
             HM.fromList
               [ ("name" :: Text, "profiles"),
                 ("dataset" :: Text, "test")
               ]
         )

-- | Constructor for @v1/metadata@ @pg_(create|update|delete)_remote_relationship@
-- arguments using the old, non-unified schema.
mk_pg_remote_relationship_old_argument :: Text -> Aeson.Value
mk_pg_remote_relationship_old_argument action =
  fragment
    & _Object
      %~ HM.insert
        ("type" :: Text)
        (Aeson.String $ "pg_" <> action <> "_remote_relationship")
  where
    fragment =
      [yamlQQ|
args:
  name: message
  table: profiles
  hasura_fields:
    - id
    - name
  remote_schema: my-remote-schema
  remote_field:
    message:
      arguments:
        id: "$id"
|]

-------------------------------------------------------------------------------
-- Utility functions.
--
-- NOTE(jkachmar): These are probably generally useful, and should be moved out
-- to some sort of test prelude.

-- | Fails the test if the 'Aeson.Result' is 'Aeson.Error', otherwise returns
-- the value in 'Aeson.Success'.
evalAesonResult ::
  forall m a.
  (MonadTest m, HasCallStack) =>
  Aeson.Result a ->
  m a
evalAesonResult x = evalEither $ case x of
  Aeson.Success val -> Right val
  Aeson.Error err -> Left err

-- | Test that the 'Aeson.toJSON' / 'Aeson.fromJSON' and 'Aeson.encode' /
-- 'Aeson.decode' functions are compatible with one another (respectively).
--
-- This is principally useful for validating manually implemented 'toEncoding'
-- methods (typically used to improve serialization performance).
trippingJSON ::
  forall a m.
  (FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
  a ->
  m ()
trippingJSON x = do
  trippingJSONValue x
  trippingJSONEncoding x

-- | Test that 'Aeson.toJSON' / 'Aeson.fromJSON' functions are compatible for a
-- given value.
--
-- This verifies that the 'parseJSON' and 'toJSON' instances agree with one
-- another.
trippingJSONValue ::
  forall a m.
  (FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
  a ->
  m ()
trippingJSONValue x = tripping x Aeson.toJSON Aeson.fromJSON

-- | Test that 'Aeson.encode' / 'Aeson.decode' functions are compatible for a
-- given value.
--
-- This verifies that the 'parseJSON' and 'toEncoding' instances agree with one
-- another.
trippingJSONEncoding ::
  forall a m.
  (FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
  a ->
  m ()
trippingJSONEncoding x = tripping x Aeson.encode Aeson.eitherDecode'