graphql-engine/server/src-lib/Hasura/Backends/DataConnector/Adapter/Schema.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Hasura.Backends.DataConnector.Adapter.Schema () where

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

import Control.Lens ((^.))
import Data.Aeson qualified as J
import Data.Has
import Data.HashMap.Strict qualified as Map
import Data.List.NonEmpty qualified as NE
import Data.Scientific (fromFloatDigits)
import Data.Text.Casing (GQLNameIdentifier, fromCustomName)
import Data.Text.Extended ((<<>))
import Hasura.Backends.DataConnector.API qualified as API
import Hasura.Backends.DataConnector.Adapter.Backend (CustomBooleanOperator (..), columnTypeToScalarType)
import Hasura.Backends.DataConnector.Adapter.Types qualified as DC
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Class
import Hasura.GraphQL.Schema.Backend (BackendSchema (..), BackendTableSelectSchema (..), ComparisonExp, MonadBuildSchema)
import Hasura.GraphQL.Schema.BoolExp qualified as GS.BE
import Hasura.GraphQL.Schema.Build qualified as GS.B
import Hasura.GraphQL.Schema.Common qualified as GS.C
import Hasura.GraphQL.Schema.NamingCase
import Hasura.GraphQL.Schema.Options qualified as Options
import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.GraphQL.Schema.Select qualified as GS.S
import Hasura.GraphQL.Schema.Update qualified as GS.U
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.IR.BoolExp qualified as IR
import Hasura.RQL.IR.Delete qualified as IR
import Hasura.RQL.IR.Insert qualified as IR
import Hasura.RQL.IR.Root qualified as IR
import Hasura.RQL.IR.Select qualified as IR
import Hasura.RQL.IR.Update qualified as IR
import Hasura.RQL.IR.Value qualified as IR
import Hasura.RQL.Types.Backend qualified as RQL
import Hasura.RQL.Types.Column qualified as RQL
import Hasura.RQL.Types.Source qualified as RQL
import Hasura.RQL.Types.SourceCustomization qualified as RQL
import Hasura.RQL.Types.Table qualified as RQL
import Hasura.SQL.Backend (BackendType (..))
import Language.GraphQL.Draft.Syntax qualified as GQL

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

instance BackendSchema 'DataConnector where
  -- top level parsers
  buildTableQueryAndSubscriptionFields = GS.B.buildTableQueryAndSubscriptionFields

  buildTableRelayQueryFields = experimentalBuildTableRelayQueryFields

  buildFunctionQueryFields _ _ _ _ = pure []
  buildFunctionRelayQueryFields _ _ _ _ _ = pure []
  buildFunctionMutationFields _ _ _ _ = pure []
  buildTableInsertMutationFields = buildTableInsertMutationFields'
  buildTableUpdateMutationFields = buildTableUpdateMutationFields'
  buildTableDeleteMutationFields = buildTableDeleteMutationFields'
  buildTableStreamingSubscriptionFields _ _ _ _ = pure []

  -- backend extensions
  relayExtension = Nothing
  nodesAggExtension = Just ()
  streamSubscriptionExtension = Nothing

  -- individual components
  columnParser = columnParser'
  enumParser = enumParser'
  possiblyNullable = possiblyNullable'
  scalarSelectionArgumentsParser _ = pure Nothing
  orderByOperators = orderByOperators'
  comparisonExps = comparisonExps'

  countTypeInput = countTypeInput'
  aggregateOrderByCountType = DC.NumberTy
  computedField =
    error "computedField: not implemented for the Data Connector backend."

instance BackendTableSelectSchema 'DataConnector where
  tableArguments = tableArgs'
  selectTable = GS.S.defaultSelectTable
  selectTableAggregate = GS.S.defaultSelectTableAggregate
  tableSelectionSet = GS.S.defaultTableSelectionSet

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

buildTableInsertMutationFields' ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.MkRootFieldName ->
  GS.C.Scenario ->
  RQL.TableName 'DataConnector ->
  RQL.TableInfo 'DataConnector ->
  GQLNameIdentifier ->
  GS.C.SchemaT r m [P.FieldParser n (IR.AnnotatedInsert 'DataConnector (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue 'DataConnector))]
buildTableInsertMutationFields' mkRootFieldName scenario tableName tableInfo gqlName = do
  API.Capabilities {..} <- DC._scCapabilities . RQL._siConfiguration @('DataConnector) <$> asks getter
  case _cMutations >>= API._mcInsertCapabilities of
    Just _insertCapabilities -> GS.B.buildTableInsertMutationFields mkBackendInsertParser mkRootFieldName scenario tableName tableInfo gqlName
    Nothing -> pure []

mkBackendInsertParser ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.TableInfo 'DataConnector ->
  GS.C.SchemaT r m (P.InputFieldsParser n (DC.BackendInsert (IR.UnpreparedValue 'DataConnector)))
mkBackendInsertParser _tableInfo =
  pure $ pure DC.BackendInsert

buildTableUpdateMutationFields' ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.MkRootFieldName ->
  GS.C.Scenario ->
  RQL.TableName 'DataConnector ->
  RQL.TableInfo 'DataConnector ->
  GQLNameIdentifier ->
  GS.C.SchemaT r m [P.FieldParser n (IR.AnnotatedUpdateG 'DataConnector (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue 'DataConnector))]
buildTableUpdateMutationFields' mkRootFieldName scenario tableName tableInfo gqlName = do
  API.Capabilities {..} <- DC._scCapabilities . RQL._siConfiguration @('DataConnector) <$> asks getter
  fieldParsers <- runMaybeT $ do
    _updateCapabilities <- hoistMaybe $ _cMutations >>= API._mcUpdateCapabilities
    roleName <- GS.C.retrieve GS.C.scRole
    updatePerms <- hoistMaybe $ RQL._permUpd $ RQL.getRolePermInfo roleName tableInfo
    let mkBackendUpdate backendUpdateTableInfo =
          (fmap . fmap) DC.BackendUpdate $
            GS.U.buildUpdateOperators
              (DC.UpdateSet <$> GS.U.presetColumns updatePerms)
              [ DC.UpdateSet <$> GS.U.setOp
              ]
              backendUpdateTableInfo
    lift $
      GS.B.buildTableUpdateMutationFields
        mkBackendUpdate
        mkRootFieldName
        scenario
        tableName
        tableInfo
        gqlName
  pure $ fromMaybe [] fieldParsers

buildTableDeleteMutationFields' ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.MkRootFieldName ->
  GS.C.Scenario ->
  RQL.TableName 'DataConnector ->
  RQL.TableInfo 'DataConnector ->
  GQLNameIdentifier ->
  GS.C.SchemaT r m [P.FieldParser n (IR.AnnDelG 'DataConnector (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue 'DataConnector))]
buildTableDeleteMutationFields' mkRootFieldName scenario tableName tableInfo gqlName = do
  API.Capabilities {..} <- DC._scCapabilities . RQL._siConfiguration @('DataConnector) <$> asks getter
  case _cMutations >>= API._mcDeleteCapabilities of
    Just _deleteCapabilities -> GS.B.buildTableDeleteMutationFields mkRootFieldName scenario tableName tableInfo gqlName
    Nothing -> pure []

experimentalBuildTableRelayQueryFields ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.MkRootFieldName ->
  RQL.TableName 'DataConnector ->
  RQL.TableInfo 'DataConnector ->
  GQLNameIdentifier ->
  NESeq (RQL.ColumnInfo 'DataConnector) ->
  GS.C.SchemaT r m [P.FieldParser n a]
experimentalBuildTableRelayQueryFields _mkRootFieldName _tableName _tableInfo _gqlName _pkeyColumns =
  pure []

columnParser' ::
  MonadBuildSchema 'DataConnector r m n =>
  RQL.ColumnType 'DataConnector ->
  GQL.Nullability ->
  GS.C.SchemaT r m (P.Parser 'P.Both n (IR.ValueWithOrigin (RQL.ColumnValue 'DataConnector)))
columnParser' columnType nullability = case columnType of
  RQL.ColumnScalar scalarType ->
    P.memoizeOn 'columnParser' (scalarType, nullability) $
      GS.C.peelWithOrigin . fmap (RQL.ColumnValue columnType) . possiblyNullable' scalarType nullability
        <$> case scalarType of
          DC.StringTy -> pure $ J.String <$> P.string
          DC.NumberTy -> pure $ J.Number <$> P.scientific
          DC.BoolTy -> pure $ J.Bool <$> P.boolean
          DC.CustomTy name graphQLType -> do
            gqlName <-
              GQL.mkName name
                `onNothing` throw400 ValidationFailed ("The column type name " <> name <<> " is not a valid GraphQL name")
            pure $ case graphQLType of
              Nothing -> P.jsonScalar gqlName (Just "A custom scalar type")
              Just DC.GraphQLInt -> (J.Number . fromIntegral) <$> P.namedInt gqlName
              Just DC.GraphQLFloat -> (J.Number . fromFloatDigits) <$> P.namedFloat gqlName
              Just DC.GraphQLString -> J.String <$> P.namedString gqlName
              Just DC.GraphQLBoolean -> J.Bool <$> P.namedBoolean gqlName
              Just DC.GraphQLID -> J.String <$> P.namedIdentifier gqlName
  RQL.ColumnEnumReference (RQL.EnumReference tableName enumValues customTableName) ->
    case nonEmpty (Map.toList enumValues) of
      Just enumValuesList ->
        GS.C.peelWithOrigin . fmap (RQL.ColumnValue columnType)
          <$> enumParser' tableName enumValuesList customTableName nullability
      Nothing -> throw400 ValidationFailed "empty enum values"

enumParser' ::
  MonadError QErr m =>
  RQL.TableName 'DataConnector ->
  NonEmpty (RQL.EnumValue, RQL.EnumValueInfo) ->
  Maybe GQL.Name ->
  GQL.Nullability ->
  GS.C.SchemaT r m (P.Parser 'P.Both n (RQL.ScalarValue 'DataConnector))
enumParser' _tableName _enumValues _customTableName _nullability =
  throw400 NotSupported "This column type is unsupported by the Data Connector backend"

possiblyNullable' ::
  MonadParse m =>
  RQL.ScalarType 'DataConnector ->
  GQL.Nullability ->
  P.Parser 'P.Both m J.Value ->
  P.Parser 'P.Both m J.Value
possiblyNullable' _scalarType (GQL.Nullability isNullable)
  | isNullable = fmap (fromMaybe J.Null) . P.nullable
  | otherwise = id

orderByOperators' :: RQL.SourceInfo 'DataConnector -> NamingCase -> (GQL.Name, NonEmpty (P.Definition P.EnumValueInfo, (RQL.BasicOrderType 'DataConnector, RQL.NullsOrderType 'DataConnector)))
orderByOperators' RQL.SourceInfo {_siConfiguration} _tCase =
  let dcName = DC._scDataConnectorName _siConfiguration
      orderBy = GQL.addSuffixes (DC.unDataConnectorName dcName) [$$(GQL.litSuffix "_order_by")]
   in (orderBy,) $
        -- NOTE: NamingCase is not being used here as we don't support naming conventions for this DB
        NE.fromList
          [ ( define $$(GQL.litName "asc") "in ascending order",
              (DC.Ascending, ())
            ),
            ( define $$(GQL.litName "desc") "in descending order",
              (DC.Descending, ())
            )
          ]
  where
    define name desc = P.Definition name (Just desc) Nothing [] P.EnumValueInfo

comparisonExps' ::
  forall m n r.
  MonadBuildSchema 'DataConnector r m n =>
  RQL.ColumnType 'DataConnector ->
  GS.C.SchemaT r m (P.Parser 'P.Input n [ComparisonExp 'DataConnector])
comparisonExps' columnType = do
  collapseIfNull <- GS.C.retrieve Options.soDangerousBooleanCollapse
  sourceInfo :: RQL.SourceInfo 'DataConnector <- asks getter
  let dataConnectorName = sourceInfo ^. RQL.siConfiguration . DC.scDataConnectorName
      tCase = RQL._rscNamingConvention $ RQL._siCustomization sourceInfo
  P.memoizeOn 'comparisonExps' (dataConnectorName, columnType) do
    typedParser <- columnParser' columnType (GQL.Nullability False)
    let name = GQL.addSuffixes (P.getName typedParser) [$$(GQL.litSuffix "_"), GQL.convertNameToSuffix (DC.unDataConnectorName dataConnectorName), $$(GQL.litSuffix "_comparison_exp")]
        desc =
          GQL.Description $
            "Boolean expression to compare columns of type "
              <> P.getName typedParser
                <<> ". All fields are combined with logical 'AND'."
        columnListParser = fmap IR.openValueOrigin <$> P.list typedParser
    customOperators <- (fmap . fmap . fmap) IR.ABackendSpecific <$> mkCustomOperators sourceInfo tCase collapseIfNull (P.getName typedParser)
    pure $
      P.object name (Just desc) $
        fmap catMaybes $
          sequenceA $
            concat
              [ GS.BE.equalityOperators
                  tCase
                  collapseIfNull
                  (IR.mkParameter <$> typedParser)
                  (mkListLiteral <$> columnListParser),
                GS.BE.comparisonOperators
                  tCase
                  collapseIfNull
                  (IR.mkParameter <$> typedParser),
                customOperators
              ]
  where
    mkListLiteral :: [RQL.ColumnValue 'DataConnector] -> IR.UnpreparedValue 'DataConnector
    mkListLiteral columnValues =
      IR.UVLiteral $ DC.ArrayLiteral (columnTypeToScalarType columnType) (RQL.cvValue <$> columnValues)

    mkCustomOperators ::
      RQL.SourceInfo 'DataConnector ->
      NamingCase ->
      Options.DangerouslyCollapseBooleans ->
      GQL.Name ->
      GS.C.SchemaT r m [P.InputFieldsParser n (Maybe (CustomBooleanOperator (IR.UnpreparedValue 'DataConnector)))]
    mkCustomOperators sourceInfo tCase collapseIfNull typeName = do
      let capabilities = sourceInfo ^. RQL.siConfiguration . DC.scCapabilities
      case Map.lookup (DC.fromGQLType typeName) (API.unScalarTypesCapabilities $ API._cScalarTypes capabilities) of
        Nothing -> pure []
        Just API.ScalarTypeCapabilities {..} -> do
          traverse (mkCustomOperator tCase collapseIfNull) $ Map.toList $ fmap (DC.mkScalarType capabilities) $ API.unComparisonOperators $ _stcComparisonOperators

    mkCustomOperator ::
      NamingCase ->
      Options.DangerouslyCollapseBooleans ->
      (GQL.Name, DC.ScalarType) ->
      GS.C.SchemaT r m (P.InputFieldsParser n (Maybe (CustomBooleanOperator (IR.UnpreparedValue 'DataConnector))))
    mkCustomOperator tCase collapseIfNull (operatorName, argType) = do
      argParser <- mkArgParser argType
      pure $
        GS.BE.mkBoolOperator tCase collapseIfNull (fromCustomName operatorName) Nothing $
          CustomBooleanOperator (GQL.unName operatorName) . Just . Right <$> argParser

    mkArgParser :: DC.ScalarType -> GS.C.SchemaT r m (P.Parser 'P.Both n (IR.UnpreparedValue 'DataConnector))
    mkArgParser argType =
      fmap IR.mkParameter
        <$> columnParser'
          (RQL.ColumnScalar argType)
          (GQL.Nullability True)

tableArgs' ::
  forall r m n.
  MonadBuildSchema 'DataConnector r m n =>
  RQL.TableInfo 'DataConnector ->
  GS.C.SchemaT r m (P.InputFieldsParser n (IR.SelectArgsG 'DataConnector (IR.UnpreparedValue 'DataConnector)))
tableArgs' tableInfo = do
  whereParser <- GS.S.tableWhereArg tableInfo
  orderByParser <- GS.S.tableOrderByArg tableInfo
  let mkSelectArgs whereArg orderByArg limitArg offsetArg =
        IR.SelectArgs
          { _saWhere = whereArg,
            _saOrderBy = orderByArg,
            _saLimit = limitArg,
            _saOffset = offsetArg,
            _saDistinct = Nothing
          }
  pure $
    mkSelectArgs
      <$> whereParser
      <*> orderByParser
      <*> GS.S.tableLimitArg
      <*> GS.S.tableOffsetArg

countTypeInput' ::
  MonadParse n =>
  Maybe (P.Parser 'P.Both n DC.ColumnName) ->
  P.InputFieldsParser n (IR.CountDistinct -> DC.CountAggregate)
countTypeInput' = \case
  Just columnEnum -> mkCountAggregate <$> P.fieldOptional Name._column Nothing columnEnum
  Nothing -> pure $ mkCountAggregate Nothing
  where
    mkCountAggregate :: Maybe DC.ColumnName -> IR.CountDistinct -> DC.CountAggregate
    mkCountAggregate Nothing _ = DC.StarCount
    mkCountAggregate (Just column) IR.SelectCountDistinct = DC.ColumnDistinctCount column
    mkCountAggregate (Just column) IR.SelectCountNonDistinct = DC.ColumnCount column