graphql-engine/server/src-lib/Hasura/Backends/DataConnector/Adapter/Schema.hs
David Overton a9f77acb32 Remove builtin scalar types from Data Connector backend
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7167
Co-authored-by: Daniel Chambers <1214352+daniel-chambers@users.noreply.github.com>
GitOrigin-RevId: 926e7282b908e3a9669ac39d625aa54971e11c37
2023-01-11 02:37:26 +00:00

347 lines
16 KiB
Haskell

{-# 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.Backends.DataConnector.Adapter.Types.Mutations qualified as DC
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Class
import Hasura.GraphQL.Schema.Backend (BackendSchema (..), BackendTableSelectSchema (..), BackendUpdateOperatorsSchema (..), 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.GraphQL.Schema.Update.Batch qualified as GS.U.B
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 is only used when generating Relay schemas, and Data Connector backends do not yet support Relay
-- If/when we want to support this we would need to add something to Capabilities to tell HGE what (integer-like) scalar
-- type should be used to represent the result of a count aggregate in relay order-by queries.
aggregateOrderByCountType =
error "aggregateOrderByCountType: not implemented for Data Connector backend"
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
instance BackendUpdateOperatorsSchema 'DataConnector where
type UpdateOperators 'DataConnector = DC.UpdateOperator
parseUpdateOperators = parseUpdateOperators'
--------------------------------------------------------------------------------
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 =>
GS.C.Scenario ->
RQL.TableInfo 'DataConnector ->
GQLNameIdentifier ->
GS.C.SchemaT r m [P.FieldParser n (IR.AnnotatedUpdateG 'DataConnector (IR.RemoteRelationshipField IR.UnpreparedValue) (IR.UnpreparedValue 'DataConnector))]
buildTableUpdateMutationFields' scenario tableInfo gqlName = do
API.Capabilities {..} <- DC._scCapabilities . RQL._siConfiguration @('DataConnector) <$> asks getter
case _cMutations >>= API._mcUpdateCapabilities of
Just _updateCapabilities -> do
updateRootFields <- GS.B.buildSingleBatchTableUpdateMutationFields DC.SingleBatch scenario tableInfo gqlName
updateManyRootField <- GS.U.B.updateTableMany DC.MultipleBatches scenario tableInfo gqlName
pure $ updateRootFields ++ (maybeToList updateManyRootField)
Nothing -> pure []
parseUpdateOperators' ::
forall m n r.
MonadBuildSchema 'DataConnector r m n =>
RQL.TableInfo 'DataConnector ->
RQL.UpdPermInfo 'DataConnector ->
GS.C.SchemaT r m (P.InputFieldsParser n (HashMap (RQL.Column 'DataConnector) (DC.UpdateOperator (IR.UnpreparedValue 'DataConnector))))
parseUpdateOperators' tableInfo updatePermissions = do
GS.U.buildUpdateOperators
(DC.UpdateSet <$> GS.U.presetColumns updatePermissions)
[ DC.UpdateSet <$> GS.U.setOp
]
tableInfo
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@(DC.ScalarType name graphQLType) ->
P.memoizeOn 'columnParser' (scalarType, nullability) $
GS.C.peelWithOrigin . fmap (RQL.ColumnValue columnType) . possiblyNullable' scalarType nullability
<$> 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