mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 21:12:09 +03:00
bdacf1bd23
I spent half the day reducing a weird compile failure here https://github.com/hasura/graphql-engine-mono/pull/1593/files#r713102990 to this https://gitlab.haskell.org/ghc/ghc/-/issues/17768#note_378004. Seems ApplicativeDo makes a mess of non-applicative monadic do in some cases. Given our rather localized use of ApplicativeDo, seemed a good idea to remove it from the list of default extensions. It appears that ApplicativeDo also buries some unused return value warnings, so this PR also silences those. We should check that none of those warnings were warranted though. https://github.com/hasura/graphql-engine-mono/pull/2413 GitOrigin-RevId: 1874c1a82230431849265755b1407beebc947041
424 lines
16 KiB
Haskell
424 lines
16 KiB
Haskell
{-# LANGUAGE ApplicativeDo #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Hasura.Backends.MSSQL.Instances.Schema () where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.List.NonEmpty as NE
|
|
import qualified Database.ODBC.SQLServer as ODBC
|
|
import qualified Language.GraphQL.Draft.Syntax as G
|
|
|
|
import Data.Has
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Text.Extended
|
|
|
|
import qualified Hasura.Backends.MSSQL.Types as MSSQL
|
|
import qualified Hasura.GraphQL.Parser as P
|
|
import qualified Hasura.GraphQL.Schema.Build as GSB
|
|
import qualified Hasura.RQL.IR.Select as IR
|
|
import qualified Hasura.RQL.IR.Update as IR
|
|
|
|
import Hasura.Base.Error
|
|
import Hasura.GraphQL.Parser hiding (EnumValueInfo, field)
|
|
import Hasura.GraphQL.Parser.Internal.Parser hiding (field)
|
|
import Hasura.GraphQL.Schema.Backend
|
|
import Hasura.GraphQL.Schema.BoolExp
|
|
import Hasura.GraphQL.Schema.Common
|
|
import Hasura.GraphQL.Schema.Select
|
|
import Hasura.RQL.IR
|
|
import Hasura.RQL.Types
|
|
|
|
|
|
----------------------------------------------------------------
|
|
-- BackendSchema instance
|
|
|
|
instance BackendSchema 'MSSQL where
|
|
-- top level parsers
|
|
buildTableQueryFields = GSB.buildTableQueryFields
|
|
buildTableRelayQueryFields = msBuildTableRelayQueryFields
|
|
buildTableInsertMutationFields = GSB.buildTableInsertMutationFields
|
|
buildTableUpdateMutationFields = msBuildTableUpdateMutationFields
|
|
buildTableDeleteMutationFields = msBuildTableDeleteMutationFields
|
|
buildFunctionQueryFields = msBuildFunctionQueryFields
|
|
buildFunctionRelayQueryFields = msBuildFunctionRelayQueryFields
|
|
buildFunctionMutationFields = msBuildFunctionMutationFields
|
|
|
|
-- backend extensions
|
|
relayExtension = Nothing
|
|
nodesAggExtension = Just ()
|
|
nestedInsertsExtension = Nothing
|
|
|
|
-- table arguments
|
|
tableArguments = msTableArgs
|
|
|
|
-- individual components
|
|
columnParser = msColumnParser
|
|
jsonPathArg = msJsonPathArg
|
|
orderByOperators = msOrderByOperators
|
|
comparisonExps = msComparisonExps
|
|
updateOperators = msUpdateOperators
|
|
mkCountType = msMkCountType
|
|
aggregateOrderByCountType = MSSQL.IntegerType
|
|
computedField = msComputedField
|
|
node = msNode
|
|
|
|
-- SQL literals
|
|
columnDefaultValue = msColumnDefaultValue
|
|
|
|
|
|
----------------------------------------------------------------
|
|
-- Top level parsers
|
|
|
|
msBuildTableRelayQueryFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> TableInfo 'MSSQL
|
|
-> G.Name
|
|
-> NESeq (ColumnInfo 'MSSQL)
|
|
-> SelPermInfo 'MSSQL
|
|
-> m [FieldParser n (QueryRootField UnpreparedValue)]
|
|
msBuildTableRelayQueryFields _sourceName _sourceInfo _tableName _tableInfo _gqlName _pkeyColumns _selPerms =
|
|
pure []
|
|
|
|
msBuildTableUpdateMutationFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> TableInfo 'MSSQL
|
|
-> G.Name
|
|
-> UpdPermInfo 'MSSQL
|
|
-> Maybe (SelPermInfo 'MSSQL)
|
|
-> m [FieldParser n (MutationRootField UnpreparedValue)]
|
|
msBuildTableUpdateMutationFields _sourceName _sourceInfo _tableName _tableInfo _gqlName _updPerns _selPerms =
|
|
pure []
|
|
|
|
msBuildTableDeleteMutationFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> TableInfo 'MSSQL
|
|
-> G.Name
|
|
-> DelPermInfo 'MSSQL
|
|
-> Maybe (SelPermInfo 'MSSQL)
|
|
-> m [FieldParser n (MutationRootField UnpreparedValue)]
|
|
msBuildTableDeleteMutationFields _sourceName _sourceInfo _tableName _tableInfo _gqlName _delPerns _selPerms =
|
|
pure []
|
|
|
|
msBuildFunctionQueryFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> FunctionName 'MSSQL
|
|
-> FunctionInfo 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> SelPermInfo 'MSSQL
|
|
-> m [FieldParser n (QueryRootField UnpreparedValue)]
|
|
msBuildFunctionQueryFields _ _ _ _ _ _ =
|
|
pure []
|
|
|
|
msBuildFunctionRelayQueryFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> FunctionName 'MSSQL
|
|
-> FunctionInfo 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> NESeq (ColumnInfo 'MSSQL)
|
|
-> SelPermInfo 'MSSQL
|
|
-> m [FieldParser n (QueryRootField UnpreparedValue)]
|
|
msBuildFunctionRelayQueryFields _sourceName _sourceInfo _functionName _functionInfo _tableName _pkeyColumns _selPerms =
|
|
pure []
|
|
|
|
msBuildFunctionMutationFields
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> SourceConfig 'MSSQL
|
|
-> FunctionName 'MSSQL
|
|
-> FunctionInfo 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> SelPermInfo 'MSSQL
|
|
-> m [FieldParser n (MutationRootField UnpreparedValue)]
|
|
msBuildFunctionMutationFields _ _ _ _ _ _ =
|
|
pure []
|
|
|
|
|
|
----------------------------------------------------------------
|
|
-- Table arguments
|
|
|
|
msTableArgs
|
|
:: forall r m n
|
|
. MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> TableInfo 'MSSQL
|
|
-> SelPermInfo 'MSSQL
|
|
-> m (InputFieldsParser n (IR.SelectArgsG 'MSSQL (UnpreparedValue 'MSSQL)))
|
|
msTableArgs sourceName tableInfo selectPermissions = do
|
|
whereParser <- tableWhereArg sourceName tableInfo selectPermissions
|
|
orderByParser <- tableOrderByArg sourceName tableInfo selectPermissions
|
|
pure do
|
|
whereArg <- whereParser
|
|
orderByArg <- orderByParser
|
|
limitArg <- tableLimitArg
|
|
offsetArg <- tableOffsetArg
|
|
pure $ IR.SelectArgs
|
|
{ IR._saWhere = whereArg
|
|
, IR._saOrderBy = orderByArg
|
|
, IR._saLimit = limitArg
|
|
, IR._saOffset = offsetArg
|
|
-- not supported on MSSQL for now
|
|
, IR._saDistinct = Nothing
|
|
}
|
|
|
|
|
|
----------------------------------------------------------------
|
|
-- Individual components
|
|
|
|
msColumnParser
|
|
:: (MonadSchema n m, MonadError QErr m)
|
|
=> ColumnType 'MSSQL
|
|
-> G.Nullability
|
|
-> m (Parser 'Both n (ValueWithOrigin (ColumnValue 'MSSQL)))
|
|
msColumnParser columnType (G.Nullability isNullable) =
|
|
peelWithOrigin . fmap (ColumnValue columnType) <$> case columnType of
|
|
-- TODO: the mapping here is not consistent with mkMSSQLScalarTypeName. For
|
|
-- example, exposing all the float types as a GraphQL Float type is
|
|
-- incorrect, similarly exposing all the integer types as a GraphQL Int
|
|
ColumnScalar scalarType -> possiblyNullable scalarType <$> case scalarType of
|
|
-- bytestring
|
|
MSSQL.CharType -> pure $ ODBC.ByteStringValue . encodeUtf8 <$> P.string
|
|
MSSQL.VarcharType -> pure $ ODBC.ByteStringValue . encodeUtf8 <$> P.string
|
|
|
|
-- text
|
|
MSSQL.WcharType -> pure $ ODBC.TextValue <$> P.string
|
|
MSSQL.WvarcharType -> pure $ ODBC.TextValue <$> P.string
|
|
MSSQL.WtextType -> pure $ ODBC.TextValue <$> P.string
|
|
MSSQL.TextType -> pure $ ODBC.TextValue <$> P.string
|
|
|
|
-- integer
|
|
MSSQL.IntegerType -> pure $ ODBC.IntValue . fromIntegral <$> P.int
|
|
MSSQL.SmallintType -> pure $ ODBC.IntValue . fromIntegral <$> P.int
|
|
MSSQL.BigintType -> pure $ ODBC.IntValue . fromIntegral <$> P.int
|
|
MSSQL.TinyintType -> pure $ ODBC.IntValue . fromIntegral <$> P.int
|
|
|
|
-- float
|
|
MSSQL.NumericType -> pure $ ODBC.DoubleValue <$> P.float
|
|
MSSQL.DecimalType -> pure $ ODBC.DoubleValue <$> P.float
|
|
MSSQL.FloatType -> pure $ ODBC.DoubleValue <$> P.float
|
|
MSSQL.RealType -> pure $ ODBC.DoubleValue <$> P.float
|
|
|
|
-- boolean
|
|
MSSQL.BitType -> pure $ ODBC.BoolValue <$> P.boolean
|
|
_ -> do
|
|
name <- MSSQL.mkMSSQLScalarTypeName scalarType
|
|
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
|
pure $ Parser
|
|
{ pType = schemaType
|
|
, pParser =
|
|
valueToJSON (P.toGraphQLType schemaType) >=>
|
|
either (parseErrorWith ParseFailed . qeError) pure . (MSSQL.parseScalarValue scalarType)
|
|
}
|
|
ColumnEnumReference (EnumReference tableName enumValues) ->
|
|
case nonEmpty (Map.toList enumValues) of
|
|
Just enumValuesList -> do
|
|
tableGQLName <- tableGraphQLName @'MSSQL tableName `onLeft` throwError
|
|
let enumName = tableGQLName <> $$(G.litName "_enum")
|
|
pure $ possiblyNullable MSSQL.VarcharType $ P.enum enumName Nothing (mkEnumValue <$> enumValuesList)
|
|
Nothing -> throw400 ValidationFailed "empty enum values"
|
|
where
|
|
possiblyNullable _scalarType
|
|
| isNullable = fmap (fromMaybe ODBC.NullValue) . P.nullable
|
|
| otherwise = id
|
|
mkEnumValue :: (EnumValue, EnumValueInfo) -> (P.Definition P.EnumValueInfo, ScalarValue 'MSSQL)
|
|
mkEnumValue (EnumValue value, EnumValueInfo description) =
|
|
( P.mkDefinition value (G.Description <$> description) P.EnumValueInfo
|
|
, ODBC.TextValue $ G.unName value
|
|
)
|
|
|
|
msJsonPathArg
|
|
:: MonadParse n
|
|
=> ColumnType 'MSSQL
|
|
-> InputFieldsParser n (Maybe (IR.ColumnOp 'MSSQL))
|
|
msJsonPathArg _columnType = pure Nothing
|
|
|
|
msOrderByOperators
|
|
:: NonEmpty
|
|
( Definition P.EnumValueInfo
|
|
, (BasicOrderType 'MSSQL, NullsOrderType 'MSSQL)
|
|
)
|
|
msOrderByOperators = NE.fromList
|
|
[ ( define $$(G.litName "asc") "in ascending order, nulls first"
|
|
, (MSSQL.AscOrder, MSSQL.NullsFirst)
|
|
)
|
|
, ( define $$(G.litName "asc_nulls_first") "in ascending order, nulls first"
|
|
, (MSSQL.AscOrder, MSSQL.NullsFirst)
|
|
)
|
|
, ( define $$(G.litName "asc_nulls_last") "in ascending order, nulls last"
|
|
, (MSSQL.AscOrder, MSSQL.NullsLast)
|
|
)
|
|
, ( define $$(G.litName "desc") "in descending order, nulls last"
|
|
, (MSSQL.DescOrder, MSSQL.NullsLast)
|
|
)
|
|
, ( define $$(G.litName "desc_nulls_first") "in descending order, nulls first"
|
|
, (MSSQL.DescOrder, MSSQL.NullsFirst)
|
|
)
|
|
, ( define $$(G.litName "desc_nulls_last") "in descending order, nulls last"
|
|
, (MSSQL.DescOrder, MSSQL.NullsLast)
|
|
)
|
|
]
|
|
where
|
|
define name desc = P.mkDefinition name (Just desc) P.EnumValueInfo
|
|
|
|
msComparisonExps
|
|
:: forall m n r
|
|
. ( BackendSchema 'MSSQL
|
|
, MonadSchema n m
|
|
, MonadError QErr m
|
|
, MonadReader r m
|
|
, Has QueryContext r
|
|
)
|
|
=> ColumnType 'MSSQL
|
|
-> m (Parser 'Input n [ComparisonExp 'MSSQL])
|
|
msComparisonExps = P.memoize 'comparisonExps \columnType -> do
|
|
-- see Note [Columns in comparison expression are never nullable]
|
|
collapseIfNull <- asks $ qcDangerousBooleanCollapse . getter
|
|
|
|
-- parsers used for individual values
|
|
typedParser <- columnParser columnType (G.Nullability False)
|
|
nullableTextParser <- columnParser (ColumnScalar @'MSSQL MSSQL.VarcharType) (G.Nullability True)
|
|
textParser <- columnParser (ColumnScalar @'MSSQL MSSQL.VarcharType) (G.Nullability False)
|
|
let
|
|
columnListParser = fmap openValueOrigin <$> P.list typedParser
|
|
textListParser = fmap openValueOrigin <$> P.list textParser
|
|
|
|
-- field info
|
|
let
|
|
name = P.getName typedParser <> $$(G.litName "_MSSQL_comparison_exp")
|
|
desc = G.Description $ "Boolean expression to compare columns of type "
|
|
<> P.getName typedParser
|
|
<<> ". All fields are combined with logical 'AND'."
|
|
|
|
pure $ P.object name (Just desc) $ fmap catMaybes $ sequenceA $ concat
|
|
[
|
|
-- Common ops for all types
|
|
equalityOperators
|
|
collapseIfNull
|
|
(mkParameter <$> typedParser)
|
|
(mkListLiteral <$> columnListParser)
|
|
, comparisonOperators
|
|
collapseIfNull
|
|
(mkParameter <$> typedParser)
|
|
|
|
-- Ops for String like types
|
|
, guard (isScalarColumnWhere (`elem` MSSQL.stringTypes) columnType) *>
|
|
[ P.fieldOptional $$(G.litName "_like")
|
|
(Just "does the column match the given pattern")
|
|
(ALIKE . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_nlike")
|
|
(Just "does the column NOT match the given pattern")
|
|
(ANLIKE . mkParameter <$> typedParser)
|
|
]
|
|
|
|
-- Ops for Geometry/Geography types
|
|
, guard (isScalarColumnWhere (`elem` MSSQL.geoTypes) columnType) *>
|
|
[ P.fieldOptional $$(G.litName "_st_contains")
|
|
(Just "does the column contain the given value")
|
|
(ABackendSpecific . MSSQL.ASTContains . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_st_equals")
|
|
(Just "is the column equal to given value (directionality is ignored)")
|
|
(ABackendSpecific . MSSQL.ASTEquals . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_st_intersects")
|
|
(Just "does the column spatially intersect the given value")
|
|
(ABackendSpecific . MSSQL.ASTIntersects . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_st_overlaps")
|
|
(Just "does the column 'spatially overlap' (intersect but not completely contain) the given value")
|
|
(ABackendSpecific . MSSQL.ASTOverlaps . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_st_within")
|
|
(Just "is the column contained in the given value")
|
|
(ABackendSpecific . MSSQL.ASTWithin . mkParameter <$> typedParser)
|
|
]
|
|
|
|
-- Ops for Geometry types
|
|
, guard (isScalarColumnWhere (MSSQL.GeometryType ==) columnType) *>
|
|
[ P.fieldOptional $$(G.litName "_st_crosses")
|
|
(Just "does the column cross the given geometry value")
|
|
(ABackendSpecific . MSSQL.ASTCrosses . mkParameter <$> typedParser)
|
|
, P.fieldOptional $$(G.litName "_st_touches")
|
|
(Just "does the column have at least one point in common with the given geometry value")
|
|
(ABackendSpecific . MSSQL.ASTTouches . mkParameter <$> typedParser)
|
|
]
|
|
]
|
|
where
|
|
mkListLiteral :: [ColumnValue 'MSSQL] -> UnpreparedValue 'MSSQL
|
|
mkListLiteral =
|
|
P.UVLiteral . MSSQL.ListExpression . fmap (MSSQL.ValueExpression . cvValue)
|
|
|
|
msMkCountType
|
|
:: Maybe Bool
|
|
-- ^ distinct values
|
|
-> Maybe [Column 'MSSQL]
|
|
-> CountType 'MSSQL
|
|
msMkCountType _ Nothing = MSSQL.StarCountable
|
|
msMkCountType (Just True) (Just cols) =
|
|
maybe MSSQL.StarCountable MSSQL.DistinctCountable $ nonEmpty cols
|
|
msMkCountType _ (Just cols) =
|
|
maybe MSSQL.StarCountable MSSQL.NonNullFieldCountable $ nonEmpty cols
|
|
|
|
-- | Various update operators
|
|
msUpdateOperators
|
|
:: Applicative m
|
|
=> TableInfo 'MSSQL -- ^ table info
|
|
-> UpdPermInfo 'MSSQL -- ^ update permissions of the table
|
|
-> m (Maybe (InputFieldsParser n [(Column 'MSSQL, IR.UpdOpExpG (UnpreparedValue 'MSSQL))]))
|
|
msUpdateOperators _tableInfo _updatePermissions = pure Nothing
|
|
|
|
-- | Computed field parser.
|
|
-- Currently unsupported: returns Nothing for now.
|
|
msComputedField
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> SourceName
|
|
-> ComputedFieldInfo 'MSSQL
|
|
-> TableName 'MSSQL
|
|
-> SelPermInfo 'MSSQL
|
|
-> m (Maybe (FieldParser n (AnnotatedField 'MSSQL)))
|
|
msComputedField _sourceName _fieldInfo _table _selectPemissions = pure Nothing
|
|
|
|
-- | Remote join field parser.
|
|
-- Currently unsupported: returns Nothing for now.
|
|
msRemoteRelationshipField
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> RemoteFieldInfo 'MSSQL
|
|
-> m (Maybe [FieldParser n (AnnotatedField 'MSSQL)])
|
|
msRemoteRelationshipField _remoteFieldInfo = pure Nothing
|
|
|
|
-- | The 'node' root field of a Relay request. Relay is currently unsupported on MSSQL,
|
|
-- meaning this parser will never be called: any attempt to create this parser should
|
|
-- therefore fail.
|
|
msNode
|
|
:: MonadBuildSchema 'MSSQL r m n
|
|
=> m ( Parser 'Output n
|
|
( HashMap
|
|
( TableName 'MSSQL)
|
|
( SourceName, SourceConfig 'MSSQL
|
|
, SelPermInfo 'MSSQL
|
|
, PrimaryKeyColumns 'MSSQL
|
|
, AnnotatedFields 'MSSQL
|
|
)
|
|
)
|
|
)
|
|
msNode = throw500 "MSSQL does not support relay; `node` should never be exposed in the schema."
|
|
|
|
|
|
----------------------------------------------------------------
|
|
-- SQL literals
|
|
|
|
-- FIXME: this is nonsensical for MSSQL, we'll need to adjust the corresponding mutation
|
|
-- and its representation.
|
|
msColumnDefaultValue :: Column 'MSSQL -> SQLExpression 'MSSQL
|
|
msColumnDefaultValue = const $ MSSQL.ValueExpression ODBC.NullValue
|