mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-22 15:01:39 +03:00
d5cb312f8b
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4426 GitOrigin-RevId: 69beda27ccf4cb47dab80d59ec383704be805bf6
1149 lines
45 KiB
Haskell
1149 lines
45 KiB
Haskell
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
-- | This module defines translation functions for queries which select data.
|
|
-- Principally this includes translating the @query@ root field, but parts are
|
|
-- also reused for serving the responses for mutations.
|
|
module Hasura.Backends.MSSQL.FromIr.Query
|
|
( fromQueryRootField,
|
|
fromSelect,
|
|
fromSourceRelationship,
|
|
)
|
|
where
|
|
|
|
import Control.Applicative (getConst)
|
|
import Control.Monad.Validate
|
|
import Data.Aeson.Extended qualified as J
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.List.NonEmpty qualified as NE
|
|
import Data.Map.Strict (Map)
|
|
import Data.Map.Strict qualified as M
|
|
import Data.Proxy
|
|
import Data.Text.NonEmpty (mkNonEmptyTextUnsafe)
|
|
import Database.ODBC.SQLServer qualified as ODBC
|
|
import Hasura.Backends.MSSQL.FromIr
|
|
( Error (..),
|
|
FromIr,
|
|
NameTemplate (..),
|
|
generateAlias,
|
|
)
|
|
import Hasura.Backends.MSSQL.Instances.Types ()
|
|
import Hasura.Backends.MSSQL.Types.Internal as TSQL
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.IR qualified as IR
|
|
import Hasura.RQL.Types.Column qualified as IR
|
|
import Hasura.RQL.Types.Common qualified as IR
|
|
import Hasura.RQL.Types.Relationships.Local qualified as IR
|
|
import Hasura.SQL.Backend
|
|
|
|
-- | This is the top-level entry point for translation of Query root fields.
|
|
fromQueryRootField :: IR.QueryDB 'MSSQL Void Expression -> FromIr Select
|
|
fromQueryRootField =
|
|
\case
|
|
(IR.QDBSingleRow s) -> fromSelect IR.JASSingleObject s
|
|
(IR.QDBMultipleRows s) -> fromSelect IR.JASMultipleRows s
|
|
(IR.QDBAggregation s) -> fromSelectAggregate Nothing s
|
|
|
|
fromSelect ::
|
|
IR.JsonAggSelect ->
|
|
IR.AnnSelectG 'MSSQL (IR.AnnFieldG 'MSSQL Void) Expression ->
|
|
FromIr TSQL.Select
|
|
fromSelect jsonAggSelect annSimpleSel =
|
|
case jsonAggSelect of
|
|
IR.JASMultipleRows ->
|
|
guardSelectYieldingNull emptyArrayExpression <$> fromSelectRows annSimpleSel
|
|
IR.JASSingleObject ->
|
|
fmap (guardSelectYieldingNull nullExpression) $
|
|
fromSelectRows annSimpleSel <&> \sel ->
|
|
sel
|
|
{ selectFor =
|
|
JsonFor
|
|
ForJson {jsonCardinality = JsonSingleton, jsonRoot = NoRoot},
|
|
selectTop = Top 1
|
|
}
|
|
where
|
|
guardSelectYieldingNull :: TSQL.Expression -> TSQL.Select -> TSQL.Select
|
|
guardSelectYieldingNull fallbackExpression select =
|
|
let isNullApplication = FunExpISNULL (SelectExpression select) fallbackExpression
|
|
in emptySelect
|
|
{ selectProjections =
|
|
[ ExpressionProjection $
|
|
Aliased
|
|
{ aliasedThing = FunctionApplicationExpression isNullApplication,
|
|
aliasedAlias = "root"
|
|
}
|
|
]
|
|
}
|
|
|
|
-- | Used in 'Hasura.Backends.MSSQL.Plan.planSourceRelationship', which is in
|
|
-- turn used by to implement `mkDBRemoteRelationship' for 'BackendExecute'.
|
|
-- For more information, see the module/documentation of 'Hasura.GraphQL.Execute.RemoteJoin.Source'.
|
|
fromSourceRelationship ::
|
|
-- | List of json objects, each of which becomes a row of the table
|
|
NE.NonEmpty J.Object ->
|
|
-- | The above objects have this schema
|
|
HM.HashMap IR.FieldName (ColumnName, ScalarType) ->
|
|
IR.FieldName ->
|
|
(IR.FieldName, IR.SourceRelationshipSelection 'MSSQL Void (Const Expression)) ->
|
|
FromIr TSQL.Select
|
|
fromSourceRelationship lhs lhsSchema argumentId relationshipField = do
|
|
(argumentIdQualified, fieldSource) <-
|
|
flip runReaderT (fromAlias selectFrom) $ do
|
|
argumentIdQualified <- fromColumn (coerceToColumn argumentId)
|
|
relationshipSource <-
|
|
fromRemoteRelationFieldsG
|
|
mempty
|
|
(fst <$> joinColumns)
|
|
relationshipField
|
|
pure (ColumnExpression argumentIdQualified, relationshipSource)
|
|
let selectProjections = [projectArgumentId argumentIdQualified, fieldSourceProjections fieldSource]
|
|
pure
|
|
Select
|
|
{ selectWith = Nothing,
|
|
selectOrderBy = Nothing,
|
|
selectTop = NoTop,
|
|
selectProjections,
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = mapMaybe fieldSourceJoin $ pure fieldSource,
|
|
selectWhere = mempty,
|
|
selectFor =
|
|
JsonFor ForJson {jsonCardinality = JsonArray, jsonRoot = NoRoot},
|
|
selectOffset = Nothing
|
|
}
|
|
where
|
|
projectArgumentId column =
|
|
ExpressionProjection $
|
|
Aliased
|
|
{ aliasedThing = column,
|
|
aliasedAlias = IR.getFieldNameTxt argumentId
|
|
}
|
|
selectFrom =
|
|
FromOpenJson
|
|
Aliased
|
|
{ aliasedThing =
|
|
OpenJson
|
|
{ openJsonExpression =
|
|
ValueExpression (ODBC.TextValue $ lbsToTxt $ J.encode lhs),
|
|
openJsonWith =
|
|
Just $
|
|
toJsonFieldSpec argumentId IntegerType
|
|
NE.:| map (uncurry toJsonFieldSpec . second snd) (HM.toList lhsSchema)
|
|
},
|
|
aliasedAlias = "lhs"
|
|
}
|
|
|
|
joinColumns = mapKeys coerceToColumn lhsSchema
|
|
|
|
coerceToColumn = ColumnName . IR.getFieldNameTxt
|
|
|
|
toJsonFieldSpec (IR.FieldName lhsFieldName) scalarType =
|
|
ScalarField scalarType DataLengthMax lhsFieldName (Just $ FieldPath RootPath lhsFieldName)
|
|
|
|
-- | Build the 'FieldSource' for the relation field, depending on whether it's
|
|
-- an object, array, or aggregate relationship.
|
|
fromRemoteRelationFieldsG ::
|
|
Map TableName EntityAlias ->
|
|
HM.HashMap ColumnName ColumnName ->
|
|
(IR.FieldName, IR.SourceRelationshipSelection 'MSSQL Void (Const Expression)) ->
|
|
ReaderT EntityAlias FromIr FieldSource
|
|
fromRemoteRelationFieldsG existingJoins joinColumns (IR.FieldName name, field) =
|
|
case field of
|
|
IR.SourceRelationshipObject selectionSet ->
|
|
fmap
|
|
( \aliasedThing ->
|
|
JoinFieldSource JsonSingleton (Aliased {aliasedThing, aliasedAlias = name})
|
|
)
|
|
( fromObjectRelationSelectG
|
|
existingJoins
|
|
( withJoinColumns $
|
|
runIdentity $
|
|
traverse (Identity . getConst) selectionSet
|
|
)
|
|
)
|
|
IR.SourceRelationshipArray selectionSet ->
|
|
fmap
|
|
( \aliasedThing ->
|
|
JoinFieldSource JsonArray (Aliased {aliasedThing, aliasedAlias = name})
|
|
)
|
|
( fromArraySelectG
|
|
( IR.ASSimple $
|
|
withJoinColumns $
|
|
runIdentity $
|
|
traverse (Identity . getConst) selectionSet
|
|
)
|
|
)
|
|
IR.SourceRelationshipArrayAggregate selectionSet ->
|
|
fmap
|
|
( \aliasedThing ->
|
|
JoinFieldSource JsonArray (Aliased {aliasedThing, aliasedAlias = name})
|
|
)
|
|
( fromArraySelectG
|
|
( IR.ASAggregate $
|
|
withJoinColumns $
|
|
runIdentity $
|
|
traverse (Identity . getConst) selectionSet
|
|
)
|
|
)
|
|
where
|
|
withJoinColumns ::
|
|
s -> IR.AnnRelationSelectG 'MSSQL s
|
|
withJoinColumns annotatedRelationship =
|
|
IR.AnnRelationSelectG
|
|
(IR.RelName $ mkNonEmptyTextUnsafe name)
|
|
joinColumns
|
|
annotatedRelationship
|
|
|
|
-- | Top/root-level 'Select'. All descendent/sub-translations are collected to produce a root TSQL.Select.
|
|
fromSelectRows :: IR.AnnSelectG 'MSSQL (IR.AnnFieldG 'MSSQL Void) Expression -> FromIr TSQL.Select
|
|
fromSelectRows annSelectG = do
|
|
selectFrom <-
|
|
case from of
|
|
IR.FromTable qualifiedObject -> fromQualifiedTable qualifiedObject
|
|
IR.FromIdentifier identifier -> pure $ FromIdentifier $ IR.unFIIdentifier identifier
|
|
IR.FromFunction {} -> refute $ pure FunctionNotSupported
|
|
Args
|
|
{ argsOrderBy,
|
|
argsWhere,
|
|
argsJoins,
|
|
argsTop,
|
|
argsDistinct = Proxy,
|
|
argsOffset,
|
|
argsExistingJoins
|
|
} <-
|
|
runReaderT (fromSelectArgsG args) (fromAlias selectFrom)
|
|
fieldSources <-
|
|
runReaderT
|
|
(traverse (fromAnnFieldsG argsExistingJoins stringifyNumbers) fields)
|
|
(fromAlias selectFrom)
|
|
filterExpression <-
|
|
runReaderT (fromGBoolExp permFilter) (fromAlias selectFrom)
|
|
let selectProjections = map fieldSourceProjections fieldSources
|
|
pure $
|
|
emptySelect
|
|
{ selectOrderBy = argsOrderBy,
|
|
selectTop = permissionBasedTop <> argsTop,
|
|
selectProjections,
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = argsJoins <> mapMaybe fieldSourceJoin fieldSources,
|
|
selectWhere = argsWhere <> Where [filterExpression],
|
|
selectFor =
|
|
JsonFor ForJson {jsonCardinality = JsonArray, jsonRoot = NoRoot},
|
|
selectOffset = argsOffset
|
|
}
|
|
where
|
|
IR.AnnSelectG
|
|
{ _asnFields = fields,
|
|
_asnFrom = from,
|
|
_asnPerm = perm,
|
|
_asnArgs = args,
|
|
_asnStrfyNum = stringifyNumbers
|
|
} = annSelectG
|
|
IR.TablePerm {_tpLimit = mPermLimit, _tpFilter = permFilter} = perm
|
|
permissionBasedTop =
|
|
maybe NoTop Top mPermLimit
|
|
|
|
mkNodesSelect :: Args -> Where -> Expression -> Top -> From -> [(Int, (IR.FieldName, [FieldSource]))] -> [(Int, Projection)]
|
|
mkNodesSelect Args {..} foreignKeyConditions filterExpression permissionBasedTop selectFrom nodes =
|
|
[ ( index,
|
|
ExpressionProjection $
|
|
Aliased
|
|
{ aliasedThing =
|
|
SelectExpression $
|
|
emptySelect
|
|
{ selectProjections = map fieldSourceProjections fieldSources,
|
|
selectTop = permissionBasedTop <> argsTop,
|
|
selectFrom = pure selectFrom,
|
|
selectJoins = argsJoins <> mapMaybe fieldSourceJoin fieldSources,
|
|
selectWhere = argsWhere <> Where [filterExpression] <> foreignKeyConditions,
|
|
selectFor =
|
|
JsonFor ForJson {jsonCardinality = JsonArray, jsonRoot = NoRoot},
|
|
selectOrderBy = argsOrderBy,
|
|
selectOffset = argsOffset
|
|
},
|
|
aliasedAlias = IR.getFieldNameTxt fieldName
|
|
}
|
|
)
|
|
| (index, (fieldName, fieldSources)) <- nodes
|
|
]
|
|
|
|
--
|
|
-- The idea here is that LIMIT/OFFSET and aggregates don't mix
|
|
-- well. Therefore we have a nested query:
|
|
--
|
|
-- select sum(*), .. FROM (select * from x offset o limit l) p
|
|
--
|
|
-- That's why @projections@ appears on the outer, and is a
|
|
-- @StarProjection@ for the inner. But the joins, conditions, top,
|
|
-- offset are on the inner.
|
|
--
|
|
mkAggregateSelect :: Args -> Where -> Expression -> From -> [(Int, (IR.FieldName, [Projection]))] -> [(Int, Projection)]
|
|
mkAggregateSelect Args {..} foreignKeyConditions filterExpression selectFrom aggregates =
|
|
[ ( index,
|
|
ExpressionProjection $
|
|
Aliased
|
|
{ aliasedThing =
|
|
safeJsonQueryExpression JsonSingleton $
|
|
SelectExpression $
|
|
emptySelect
|
|
{ selectProjections = projections,
|
|
selectTop = NoTop,
|
|
selectFrom =
|
|
pure $
|
|
FromSelect
|
|
Aliased
|
|
{ aliasedAlias = aggSubselectName,
|
|
aliasedThing =
|
|
emptySelect
|
|
{ selectProjections = pure StarProjection,
|
|
selectTop = argsTop,
|
|
selectFrom = pure selectFrom,
|
|
selectJoins = argsJoins,
|
|
selectWhere = argsWhere <> Where [filterExpression] <> foreignKeyConditions,
|
|
selectFor = NoFor,
|
|
selectOrderBy = mempty,
|
|
selectOffset = argsOffset
|
|
}
|
|
},
|
|
selectJoins = mempty,
|
|
selectWhere = mempty,
|
|
selectFor =
|
|
JsonFor
|
|
ForJson
|
|
{ jsonCardinality = JsonSingleton,
|
|
jsonRoot = NoRoot
|
|
},
|
|
selectOrderBy = mempty,
|
|
selectOffset = Nothing
|
|
},
|
|
aliasedAlias = IR.getFieldNameTxt fieldName
|
|
}
|
|
)
|
|
| (index, (fieldName, projections)) <- aggregates
|
|
]
|
|
|
|
fromSelectAggregate ::
|
|
Maybe (EntityAlias, HashMap ColumnName ColumnName) ->
|
|
IR.AnnSelectG 'MSSQL (IR.TableAggregateFieldG 'MSSQL Void) Expression ->
|
|
FromIr TSQL.Select
|
|
fromSelectAggregate
|
|
mparentRelationship
|
|
IR.AnnSelectG
|
|
{ _asnFields = (zip [0 ..] -> fields),
|
|
_asnFrom = from,
|
|
_asnPerm = IR.TablePerm {_tpLimit = (maybe NoTop Top -> permissionBasedTop), _tpFilter = permFilter},
|
|
_asnArgs = args,
|
|
_asnStrfyNum = stringifyNumbers
|
|
} =
|
|
do
|
|
selectFrom <- case from of
|
|
IR.FromTable qualifiedObject -> fromQualifiedTable qualifiedObject
|
|
IR.FromIdentifier identifier -> pure $ FromIdentifier $ IR.unFIIdentifier identifier
|
|
IR.FromFunction {} -> refute $ pure FunctionNotSupported
|
|
-- Below: When we're actually a RHS of a query (of CROSS APPLY),
|
|
-- then we'll have a LHS table that we're joining on. So we get the
|
|
-- conditions expressions from the field mappings. The LHS table is
|
|
-- the entityAlias, and the RHS table is selectFrom.
|
|
mforeignKeyConditions <- fmap (Where . fromMaybe []) $
|
|
for mparentRelationship $
|
|
\(entityAlias, mapping) ->
|
|
runReaderT (fromMapping selectFrom mapping) entityAlias
|
|
filterExpression <- runReaderT (fromGBoolExp permFilter) (fromAlias selectFrom)
|
|
args'@Args {argsExistingJoins} <-
|
|
runReaderT (fromSelectArgsG args) (fromAlias selectFrom)
|
|
-- Although aggregates, exps and nodes could be handled in one list,
|
|
-- we need to separately treat the subselect expressions
|
|
expss :: [(Int, Projection)] <- flip runReaderT (fromAlias selectFrom) $ sequence $ mapMaybe fromTableExpFieldG fields
|
|
nodes :: [(Int, (IR.FieldName, [FieldSource]))] <-
|
|
flip runReaderT (fromAlias selectFrom) $ sequence $ mapMaybe (fromTableNodesFieldG argsExistingJoins stringifyNumbers) fields
|
|
let aggregates :: [(Int, (IR.FieldName, [Projection]))] = mapMaybe fromTableAggFieldG fields
|
|
pure
|
|
emptySelect
|
|
{ selectProjections =
|
|
map snd $
|
|
sortBy (comparing fst) $
|
|
expss
|
|
<> mkNodesSelect args' mforeignKeyConditions filterExpression permissionBasedTop selectFrom nodes
|
|
<> mkAggregateSelect args' mforeignKeyConditions filterExpression selectFrom aggregates,
|
|
selectTop = NoTop,
|
|
selectFrom =
|
|
pure $
|
|
FromOpenJson $
|
|
Aliased
|
|
{ aliasedThing =
|
|
OpenJson
|
|
{ openJsonExpression = ValueExpression $ ODBC.TextValue "[0]",
|
|
openJsonWith = Nothing
|
|
},
|
|
aliasedAlias = existsFieldName
|
|
},
|
|
selectJoins = mempty, -- JOINs and WHEREs are only relevant in subselects
|
|
selectWhere = mempty,
|
|
selectFor = JsonFor ForJson {jsonCardinality = JsonSingleton, jsonRoot = NoRoot},
|
|
selectOrderBy = Nothing,
|
|
selectOffset = Nothing
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- GraphQL Args
|
|
|
|
data Args = Args
|
|
{ argsWhere :: Where,
|
|
argsOrderBy :: Maybe (NonEmpty OrderBy),
|
|
argsJoins :: [Join],
|
|
argsTop :: Top,
|
|
argsOffset :: Maybe Expression,
|
|
argsDistinct :: Proxy (Maybe (NonEmpty FieldName)),
|
|
argsExistingJoins :: Map TableName EntityAlias
|
|
}
|
|
deriving (Show)
|
|
|
|
fromSelectArgsG :: IR.SelectArgsG 'MSSQL Expression -> ReaderT EntityAlias FromIr Args
|
|
fromSelectArgsG selectArgsG = do
|
|
let argsOffset = ValueExpression . ODBC.IntValue . fromIntegral <$> moffset
|
|
argsWhere <-
|
|
maybe (pure mempty) (fmap (Where . pure) . fromGBoolExp) mannBoolExp
|
|
argsTop <-
|
|
maybe (pure mempty) (pure . Top) mlimit
|
|
-- Not supported presently, per Vamshi:
|
|
--
|
|
-- > It is hardly used and we don't have to go to great lengths to support it.
|
|
--
|
|
-- But placeholdering the code so that when it's ready to be used,
|
|
-- you can just drop the Proxy wrapper.
|
|
let argsDistinct = Proxy
|
|
(argsOrderBy, joins) <-
|
|
runWriterT (traverse fromAnnotatedOrderByItemG (maybe [] toList orders))
|
|
-- Any object-relation joins that we generated, we record their
|
|
-- generated names into a mapping.
|
|
let argsExistingJoins =
|
|
M.fromList (mapMaybe unfurledObjectTableAlias (toList joins))
|
|
pure
|
|
Args
|
|
{ argsJoins = toList (fmap unfurledJoin joins),
|
|
argsOrderBy = nonEmpty argsOrderBy,
|
|
..
|
|
}
|
|
where
|
|
IR.SelectArgs
|
|
{ _saWhere = mannBoolExp,
|
|
_saLimit = mlimit,
|
|
_saOffset = moffset,
|
|
_saOrderBy = orders
|
|
} = selectArgsG
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Conversion functions
|
|
fromQualifiedTable :: TableName -> FromIr From
|
|
fromQualifiedTable schemadTableName@(TableName {tableName}) = do
|
|
alias <- generateAlias (TableTemplate tableName)
|
|
pure
|
|
( FromQualifiedTable
|
|
( Aliased
|
|
{ aliasedThing = schemadTableName,
|
|
aliasedAlias = alias
|
|
}
|
|
)
|
|
)
|
|
|
|
-- | Translate an 'AnnBoolExpFld' within an 'EntityAlias' context referring to the table the `AnnBoolExpFld` field belongs to.
|
|
--
|
|
-- This is mutually recursive with 'fromGBoolExp', mirroring the mutually recursive structure between 'AnnBoolExpFld' and 'AnnBoolExp b a' (alias of 'GBoolExp b (AnnBoolExpFld b a)').
|
|
fromAnnBoolExpFld ::
|
|
IR.AnnBoolExpFld 'MSSQL Expression ->
|
|
ReaderT EntityAlias FromIr Expression
|
|
fromAnnBoolExpFld =
|
|
\case
|
|
IR.AVColumn columnInfo opExpGs -> do
|
|
expression <- fromColumnInfoForBoolExp columnInfo
|
|
expressions <- traverse (lift . fromOpExpG expression) opExpGs
|
|
pure (AndExpression expressions)
|
|
IR.AVRelationship IR.RelInfo {riMapping = mapping, riRTable = table} annBoolExp -> do
|
|
selectFrom <- lift (fromQualifiedTable table)
|
|
foreignKeyConditions <- fromMapping selectFrom mapping
|
|
whereExpression <-
|
|
local (const (fromAlias selectFrom)) (fromGBoolExp annBoolExp)
|
|
pure
|
|
( ExistsExpression
|
|
emptySelect
|
|
{ selectOrderBy = Nothing,
|
|
selectProjections =
|
|
[ ExpressionProjection
|
|
( Aliased
|
|
{ aliasedThing = trueExpression,
|
|
aliasedAlias = existsFieldName
|
|
}
|
|
)
|
|
],
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = mempty,
|
|
selectWhere = Where (foreignKeyConditions <> [whereExpression]),
|
|
selectTop = NoTop,
|
|
selectFor = NoFor,
|
|
selectOffset = Nothing
|
|
}
|
|
)
|
|
|
|
-- | For boolean operators, various comparison operators used need
|
|
-- special handling to ensure that SQL Server won't outright reject
|
|
-- the comparison. See also 'shouldCastToVarcharMax'.
|
|
fromColumnInfoForBoolExp :: IR.ColumnInfo 'MSSQL -> ReaderT EntityAlias FromIr Expression
|
|
fromColumnInfoForBoolExp IR.ColumnInfo {ciColumn = column, ciType} = do
|
|
fieldName <- columnNameToFieldName column <$> ask
|
|
if shouldCastToVarcharMax ciType -- See function commentary.
|
|
then pure (CastExpression (ColumnExpression fieldName) WvarcharType DataLengthMax)
|
|
else pure (ColumnExpression fieldName)
|
|
|
|
-- | There's a problem of comparing text fields with =, <, etc. that
|
|
-- SQL Server completely refuses to do so. So one way to workaround
|
|
-- this restriction is to automatically cast such text fields to
|
|
-- varchar(max).
|
|
shouldCastToVarcharMax :: IR.ColumnType 'MSSQL -> Bool
|
|
shouldCastToVarcharMax typ =
|
|
typ == IR.ColumnScalar TextType || typ == IR.ColumnScalar WtextType
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Sources of projected fields
|
|
--
|
|
-- Because in the IR, a field projected can be a foreign object, we
|
|
-- have to both generate a projection AND on the side generate a join.
|
|
--
|
|
-- So a @FieldSource@ couples the idea of the projected thing and the
|
|
-- source of it (via 'Aliased').
|
|
|
|
data FieldSource
|
|
= ExpressionFieldSource (Aliased Expression)
|
|
| JoinFieldSource JsonCardinality (Aliased Join)
|
|
deriving (Eq, Show)
|
|
|
|
-- | Get FieldSource from a TAFExp type table aggregate field
|
|
fromTableExpFieldG :: -- TODO: Convert function to be similar to Nodes function
|
|
(Int, (IR.FieldName, IR.TableAggregateFieldG 'MSSQL Void Expression)) ->
|
|
Maybe (ReaderT EntityAlias FromIr (Int, Projection))
|
|
fromTableExpFieldG = \case
|
|
(index, (IR.FieldName name, IR.TAFExp text)) ->
|
|
Just $
|
|
pure $
|
|
( index,
|
|
fieldSourceProjections $
|
|
ExpressionFieldSource
|
|
Aliased
|
|
{ aliasedThing = TSQL.ValueExpression (ODBC.TextValue text),
|
|
aliasedAlias = name
|
|
}
|
|
)
|
|
_ -> Nothing
|
|
|
|
fromTableAggFieldG ::
|
|
(Int, (IR.FieldName, IR.TableAggregateFieldG 'MSSQL Void Expression)) ->
|
|
Maybe (Int, (IR.FieldName, [Projection]))
|
|
fromTableAggFieldG = \case
|
|
(index, (fieldName, IR.TAFAgg (aggregateFields :: [(IR.FieldName, IR.AggregateField 'MSSQL)]))) ->
|
|
Just $
|
|
let aggregates =
|
|
aggregateFields <&> \(fieldName', aggregateField) ->
|
|
fromAggregateField (IR.getFieldNameTxt fieldName') aggregateField
|
|
in (index, (fieldName, aggregates))
|
|
_ -> Nothing
|
|
|
|
fromTableNodesFieldG ::
|
|
Map TableName EntityAlias ->
|
|
IR.StringifyNumbers ->
|
|
(Int, (IR.FieldName, IR.TableAggregateFieldG 'MSSQL Void Expression)) ->
|
|
Maybe (ReaderT EntityAlias FromIr (Int, (IR.FieldName, [FieldSource])))
|
|
fromTableNodesFieldG argsExistingJoins stringifyNumbers = \case
|
|
(index, (fieldName, IR.TAFNodes () (annFieldsG :: [(IR.FieldName, IR.AnnFieldG 'MSSQL Void Expression)]))) -> Just do
|
|
fieldSources' <- fromAnnFieldsG argsExistingJoins stringifyNumbers `traverse` annFieldsG
|
|
pure (index, (fieldName, fieldSources'))
|
|
_ -> Nothing
|
|
|
|
fromAggregateField :: Text -> IR.AggregateField 'MSSQL -> Projection
|
|
fromAggregateField alias aggregateField =
|
|
case aggregateField of
|
|
IR.AFExp text -> AggregateProjection $ Aliased (TextAggregate text) alias
|
|
IR.AFCount countType -> AggregateProjection . flip Aliased alias . CountAggregate $ case countType of
|
|
StarCountable -> StarCountable
|
|
NonNullFieldCountable name -> NonNullFieldCountable $ columnFieldAggEntity name
|
|
DistinctCountable name -> DistinctCountable $ columnFieldAggEntity name
|
|
IR.AFOp IR.AggregateOp {_aoOp = op, _aoFields = fields} ->
|
|
let projections :: [Projection] =
|
|
fields <&> \(fieldName, columnField) ->
|
|
case columnField of
|
|
IR.CFCol column _columnType ->
|
|
let fname = columnFieldAggEntity column
|
|
in AggregateProjection $ Aliased (OpAggregate op [ColumnExpression fname]) (IR.getFieldNameTxt fieldName)
|
|
IR.CFExp text ->
|
|
ExpressionProjection $ Aliased (ValueExpression (ODBC.TextValue text)) (IR.getFieldNameTxt fieldName)
|
|
in ExpressionProjection $
|
|
flip Aliased alias $
|
|
safeJsonQueryExpression JsonSingleton $
|
|
SelectExpression $
|
|
emptySelect
|
|
{ selectProjections = projections,
|
|
selectFor = JsonFor $ ForJson JsonSingleton NoRoot
|
|
}
|
|
where
|
|
columnFieldAggEntity col = columnNameToFieldName col $ EntityAlias aggSubselectName
|
|
|
|
-- | The main sources of fields, either constants, fields or via joins.
|
|
fromAnnFieldsG ::
|
|
Map TableName EntityAlias ->
|
|
IR.StringifyNumbers ->
|
|
(IR.FieldName, IR.AnnFieldG 'MSSQL Void Expression) ->
|
|
ReaderT EntityAlias FromIr FieldSource
|
|
fromAnnFieldsG existingJoins stringifyNumbers (IR.FieldName name, field) =
|
|
case field of
|
|
IR.AFColumn annColumnField -> do
|
|
expression <- fromAnnColumnField stringifyNumbers annColumnField
|
|
pure
|
|
( ExpressionFieldSource
|
|
Aliased {aliasedThing = expression, aliasedAlias = name}
|
|
)
|
|
IR.AFExpression text ->
|
|
pure
|
|
( ExpressionFieldSource
|
|
Aliased
|
|
{ aliasedThing = TSQL.ValueExpression (ODBC.TextValue text),
|
|
aliasedAlias = name
|
|
}
|
|
)
|
|
IR.AFObjectRelation objectRelationSelectG ->
|
|
fmap
|
|
( \aliasedThing ->
|
|
JoinFieldSource JsonSingleton (Aliased {aliasedThing, aliasedAlias = name})
|
|
)
|
|
(fromObjectRelationSelectG existingJoins objectRelationSelectG)
|
|
IR.AFArrayRelation arraySelectG ->
|
|
fmap
|
|
( \aliasedThing ->
|
|
JoinFieldSource JsonArray (Aliased {aliasedThing, aliasedAlias = name})
|
|
)
|
|
(fromArraySelectG arraySelectG)
|
|
|
|
-- | Here is where we project a field as a column expression. If
|
|
-- number stringification is on, then we wrap it in a
|
|
-- 'ToStringExpression' so that it's casted when being projected.
|
|
fromAnnColumnField ::
|
|
IR.StringifyNumbers ->
|
|
IR.AnnColumnField 'MSSQL Expression ->
|
|
ReaderT EntityAlias FromIr Expression
|
|
fromAnnColumnField _stringifyNumbers annColumnField = do
|
|
fieldName <- fromColumn column
|
|
-- TODO: Handle stringifying large numbers
|
|
{-(IR.isScalarColumnWhere isBigNum typ && stringifyNumbers == IR.StringifyNumbers)-}
|
|
|
|
-- for geometry and geography values, the automatic json encoding on sql
|
|
-- server would fail. So we need to convert it to a format the json encoding
|
|
-- handles. Ideally we want this representation to be GeoJSON but sql server
|
|
-- doesn't have any functions to convert to GeoJSON format. So we return it in
|
|
-- WKT format
|
|
if typ == (IR.ColumnScalar GeometryType) || typ == (IR.ColumnScalar GeographyType)
|
|
then pure $ MethodApplicationExpression (ColumnExpression fieldName) MethExpSTAsText
|
|
else case caseBoolExpMaybe of
|
|
Nothing -> pure (ColumnExpression fieldName)
|
|
Just ex -> do
|
|
ex' <- fromGBoolExp (coerce ex)
|
|
let nullValue = ValueExpression ODBC.NullValue
|
|
pure (ConditionalExpression ex' (ColumnExpression fieldName) nullValue)
|
|
where
|
|
IR.AnnColumnField
|
|
{ _acfColumn = column,
|
|
_acfType = typ,
|
|
_acfAsText = _asText :: Bool,
|
|
_acfArguments = _ :: Maybe Void,
|
|
_acfCaseBoolExpression = caseBoolExpMaybe
|
|
} = annColumnField
|
|
|
|
-- | This is where a field name "foo" is resolved to a fully qualified
|
|
-- field name [table].[foo]. The table name comes from EntityAlias in
|
|
-- the ReaderT.
|
|
fromColumn :: ColumnName -> ReaderT EntityAlias FromIr FieldName
|
|
fromColumn column = columnNameToFieldName column <$> ask
|
|
|
|
-- entityAlias <- ask
|
|
-- pure (columnNameToFieldName column entityAlias -- FieldName {fieldName = columnName column, fieldNameEntity = entityAliasText}
|
|
-- )
|
|
|
|
fieldSourceProjections :: FieldSource -> Projection
|
|
fieldSourceProjections =
|
|
\case
|
|
ExpressionFieldSource aliasedExpression ->
|
|
ExpressionProjection aliasedExpression
|
|
JoinFieldSource cardinality aliasedJoin ->
|
|
ExpressionProjection
|
|
( aliasedJoin
|
|
{ aliasedThing =
|
|
-- Basically a cast, to ensure that SQL Server won't
|
|
-- double-encode the JSON but will "pass it through"
|
|
-- untouched.
|
|
safeJsonQueryExpression
|
|
cardinality
|
|
( ColumnExpression
|
|
( joinAliasToField
|
|
(joinJoinAlias (aliasedThing aliasedJoin))
|
|
)
|
|
)
|
|
}
|
|
)
|
|
|
|
joinAliasToField :: JoinAlias -> FieldName
|
|
joinAliasToField JoinAlias {..} =
|
|
FieldName
|
|
{ fieldNameEntity = joinAliasEntity,
|
|
fieldName = fromMaybe (error "TODO: Eliminate this case. joinAliasToField") joinAliasField
|
|
}
|
|
|
|
fieldSourceJoin :: FieldSource -> Maybe Join
|
|
fieldSourceJoin =
|
|
\case
|
|
JoinFieldSource _ aliasedJoin -> pure (aliasedThing aliasedJoin)
|
|
ExpressionFieldSource {} -> Nothing
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Joins
|
|
|
|
fromObjectRelationSelectG ::
|
|
Map TableName EntityAlias ->
|
|
IR.ObjectRelationSelectG 'MSSQL Void Expression ->
|
|
ReaderT EntityAlias FromIr Join
|
|
fromObjectRelationSelectG existingJoins annRelationSelectG = do
|
|
eitherAliasOrFrom <- lift (lookupTableFrom existingJoins tableFrom)
|
|
let entityAlias :: EntityAlias = either id fromAlias eitherAliasOrFrom
|
|
fieldSources <-
|
|
local
|
|
(const entityAlias)
|
|
(traverse (fromAnnFieldsG mempty IR.LeaveNumbersAlone) fields)
|
|
let selectProjections = map fieldSourceProjections fieldSources
|
|
joinJoinAlias <-
|
|
do
|
|
fieldName <- lift (fromRelName _aarRelationshipName)
|
|
alias <- lift (generateAlias (ObjectRelationTemplate fieldName))
|
|
pure
|
|
JoinAlias
|
|
{ joinAliasEntity = alias,
|
|
joinAliasField = pure jsonFieldName
|
|
}
|
|
let selectFor =
|
|
JsonFor ForJson {jsonCardinality = JsonSingleton, jsonRoot = NoRoot}
|
|
filterExpression <- local (const entityAlias) (fromGBoolExp tableFilter)
|
|
case eitherAliasOrFrom of
|
|
Right selectFrom -> do
|
|
foreignKeyConditions <- fromMapping selectFrom mapping
|
|
pure
|
|
Join
|
|
{ joinJoinAlias,
|
|
joinSource =
|
|
JoinSelect
|
|
emptySelect
|
|
{ selectOrderBy = Nothing,
|
|
selectTop = NoTop,
|
|
selectProjections,
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = mapMaybe fieldSourceJoin fieldSources,
|
|
selectWhere =
|
|
Where (foreignKeyConditions <> [filterExpression]),
|
|
selectFor,
|
|
selectOffset = Nothing
|
|
}
|
|
}
|
|
Left _entityAlias ->
|
|
pure
|
|
Join
|
|
{ joinJoinAlias,
|
|
joinSource =
|
|
JoinReselect
|
|
Reselect
|
|
{ reselectProjections = selectProjections,
|
|
reselectFor = selectFor,
|
|
reselectWhere = Where [filterExpression]
|
|
}
|
|
}
|
|
where
|
|
IR.AnnObjectSelectG
|
|
{ _aosFields = fields :: IR.AnnFieldsG 'MSSQL Void Expression,
|
|
_aosTableFrom = tableFrom :: TableName,
|
|
_aosTableFilter = tableFilter :: IR.AnnBoolExp 'MSSQL Expression
|
|
} = annObjectSelectG
|
|
IR.AnnRelationSelectG
|
|
{ _aarRelationshipName,
|
|
_aarColumnMapping = mapping :: HashMap ColumnName ColumnName,
|
|
_aarAnnSelect = annObjectSelectG :: IR.AnnObjectSelectG 'MSSQL Void Expression
|
|
} = annRelationSelectG
|
|
|
|
lookupTableFrom ::
|
|
Map TableName EntityAlias ->
|
|
TableName ->
|
|
FromIr (Either EntityAlias From)
|
|
lookupTableFrom existingJoins tableFrom = do
|
|
case M.lookup tableFrom existingJoins of
|
|
Just entityAlias -> pure (Left entityAlias)
|
|
Nothing -> fmap Right (fromQualifiedTable tableFrom)
|
|
|
|
fromArraySelectG :: IR.ArraySelectG 'MSSQL Void Expression -> ReaderT EntityAlias FromIr Join
|
|
fromArraySelectG =
|
|
\case
|
|
IR.ASSimple arrayRelationSelectG ->
|
|
fromArrayRelationSelectG arrayRelationSelectG
|
|
IR.ASAggregate arrayAggregateSelectG ->
|
|
fromArrayAggregateSelectG arrayAggregateSelectG
|
|
|
|
fromArrayAggregateSelectG ::
|
|
IR.AnnRelationSelectG 'MSSQL (IR.AnnAggregateSelectG 'MSSQL Void Expression) ->
|
|
ReaderT EntityAlias FromIr Join
|
|
fromArrayAggregateSelectG annRelationSelectG = do
|
|
fieldName <- lift (fromRelName _aarRelationshipName)
|
|
joinSelect <- do
|
|
lhsEntityAlias <- ask
|
|
-- With this, the foreign key relations are injected automatically
|
|
-- at the right place by fromSelectAggregate.
|
|
lift (fromSelectAggregate (pure (lhsEntityAlias, mapping)) annSelectG)
|
|
alias <- lift (generateAlias (ArrayAggregateTemplate fieldName))
|
|
pure
|
|
Join
|
|
{ joinJoinAlias =
|
|
JoinAlias
|
|
{ joinAliasEntity = alias,
|
|
joinAliasField = pure jsonFieldName
|
|
},
|
|
joinSource = JoinSelect joinSelect
|
|
}
|
|
where
|
|
IR.AnnRelationSelectG
|
|
{ _aarRelationshipName,
|
|
_aarColumnMapping = mapping :: HashMap ColumnName ColumnName,
|
|
_aarAnnSelect = annSelectG
|
|
} = annRelationSelectG
|
|
|
|
fromArrayRelationSelectG :: IR.ArrayRelationSelectG 'MSSQL Void Expression -> ReaderT EntityAlias FromIr Join
|
|
fromArrayRelationSelectG annRelationSelectG = do
|
|
fieldName <- lift (fromRelName _aarRelationshipName)
|
|
sel <- lift (fromSelectRows annSelectG)
|
|
joinSelect <-
|
|
do
|
|
foreignKeyConditions <- selectFromMapping sel mapping
|
|
pure
|
|
sel {selectWhere = Where foreignKeyConditions <> selectWhere sel}
|
|
alias <- lift (generateAlias (ArrayRelationTemplate fieldName))
|
|
pure
|
|
Join
|
|
{ joinJoinAlias =
|
|
JoinAlias
|
|
{ joinAliasEntity = alias,
|
|
joinAliasField = pure jsonFieldName
|
|
},
|
|
joinSource = JoinSelect joinSelect
|
|
}
|
|
where
|
|
IR.AnnRelationSelectG
|
|
{ _aarRelationshipName,
|
|
_aarColumnMapping = mapping :: HashMap ColumnName ColumnName,
|
|
_aarAnnSelect = annSelectG
|
|
} = annRelationSelectG
|
|
|
|
fromRelName :: IR.RelName -> FromIr Text
|
|
fromRelName relName =
|
|
pure (IR.relNameToTxt relName)
|
|
|
|
-- | The context given by the reader is of the previous/parent
|
|
-- "remote" table. The WHERE that we're generating goes in the child,
|
|
-- "local" query. The @From@ passed in as argument is the local table.
|
|
--
|
|
-- We should hope to see e.g. "post.category = category.id" for a
|
|
-- local table of post and a remote table of category.
|
|
--
|
|
-- The left/right columns in @HashMap ColumnName ColumnName@ corresponds
|
|
-- to the left/right of @select ... join ...@. Therefore left=remote,
|
|
-- right=local in this context.
|
|
fromMapping ::
|
|
From ->
|
|
HashMap ColumnName ColumnName ->
|
|
ReaderT EntityAlias FromIr [Expression]
|
|
fromMapping localFrom =
|
|
traverse
|
|
( \(remoteColumn, localColumn) -> do
|
|
localFieldName <- local (const (fromAlias localFrom)) (fromColumn localColumn)
|
|
remoteFieldName <- fromColumn remoteColumn
|
|
pure
|
|
( OpExpression
|
|
TSQL.EQ'
|
|
(ColumnExpression localFieldName)
|
|
(ColumnExpression remoteFieldName)
|
|
)
|
|
)
|
|
. HM.toList
|
|
|
|
selectFromMapping ::
|
|
Select ->
|
|
HashMap ColumnName ColumnName ->
|
|
ReaderT EntityAlias FromIr [Expression]
|
|
selectFromMapping Select {selectFrom = Nothing} = const (pure [])
|
|
selectFromMapping Select {selectFrom = Just from} = fromMapping from
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Basic SQL expression types
|
|
|
|
fromOpExpG :: Expression -> IR.OpExpG 'MSSQL Expression -> FromIr Expression
|
|
fromOpExpG expression op =
|
|
case op of
|
|
IR.ANISNULL -> pure $ TSQL.IsNullExpression expression
|
|
IR.ANISNOTNULL -> pure $ TSQL.IsNotNullExpression expression
|
|
IR.AEQ False val -> pure $ nullableBoolEquality expression val
|
|
IR.AEQ True val -> pure $ OpExpression TSQL.EQ' expression val
|
|
IR.ANE False val -> pure $ nullableBoolInequality expression val
|
|
IR.ANE True val -> pure $ OpExpression TSQL.NEQ' expression val
|
|
IR.AGT val -> pure $ OpExpression TSQL.GT expression val
|
|
IR.ALT val -> pure $ OpExpression TSQL.LT expression val
|
|
IR.AGTE val -> pure $ OpExpression TSQL.GTE expression val
|
|
IR.ALTE val -> pure $ OpExpression TSQL.LTE expression val
|
|
IR.AIN val -> pure $ OpExpression TSQL.IN expression val
|
|
IR.ANIN val -> pure $ OpExpression TSQL.NIN expression val
|
|
IR.ALIKE val -> pure $ OpExpression TSQL.LIKE expression val
|
|
IR.ANLIKE val -> pure $ OpExpression TSQL.NLIKE expression val
|
|
IR.ABackendSpecific o -> case o of
|
|
ASTContains val -> pure $ TSQL.STOpExpression TSQL.STContains expression val
|
|
ASTCrosses val -> pure $ TSQL.STOpExpression TSQL.STCrosses expression val
|
|
ASTEquals val -> pure $ TSQL.STOpExpression TSQL.STEquals expression val
|
|
ASTIntersects val -> pure $ TSQL.STOpExpression TSQL.STIntersects expression val
|
|
ASTOverlaps val -> pure $ TSQL.STOpExpression TSQL.STOverlaps expression val
|
|
ASTTouches val -> pure $ TSQL.STOpExpression TSQL.STTouches expression val
|
|
ASTWithin val -> pure $ TSQL.STOpExpression TSQL.STWithin expression val
|
|
-- As of March 2021, only geometry/geography casts are supported
|
|
IR.ACast _casts -> refute (pure (UnsupportedOpExpG op)) -- mkCastsExp casts
|
|
|
|
-- We do not yet support column names in permissions
|
|
IR.CEQ _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SEQ lhs $ mkQCol rhsCol
|
|
IR.CNE _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SNE lhs $ mkQCol rhsCol
|
|
IR.CGT _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SGT lhs $ mkQCol rhsCol
|
|
IR.CLT _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SLT lhs $ mkQCol rhsCol
|
|
IR.CGTE _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SGTE lhs $ mkQCol rhsCol
|
|
IR.CLTE _rhsCol -> refute (pure (UnsupportedOpExpG op)) -- S.BECompare S.SLTE lhs $ mkQCol rhsCol
|
|
|
|
nullableBoolEquality :: Expression -> Expression -> Expression
|
|
nullableBoolEquality x y =
|
|
OrExpression
|
|
[ OpExpression TSQL.EQ' x y,
|
|
AndExpression [IsNullExpression x, IsNullExpression y]
|
|
]
|
|
|
|
nullableBoolInequality :: Expression -> Expression -> Expression
|
|
nullableBoolInequality x y =
|
|
OrExpression
|
|
[ OpExpression TSQL.NEQ' x y,
|
|
AndExpression [IsNotNullExpression x, IsNullExpression y]
|
|
]
|
|
|
|
-- | Translate a 'GBoolExp' of a 'AnnBoolExpFld', within an 'EntityAlias' context.
|
|
--
|
|
-- It is mutually recursive with 'fromAnnBoolExpFld' and 'fromGExists'.
|
|
fromGBoolExp ::
|
|
IR.GBoolExp 'MSSQL (IR.AnnBoolExpFld 'MSSQL Expression) ->
|
|
ReaderT EntityAlias FromIr Expression
|
|
fromGBoolExp =
|
|
\case
|
|
IR.BoolAnd expressions ->
|
|
fmap AndExpression (traverse fromGBoolExp expressions)
|
|
IR.BoolOr expressions ->
|
|
fmap OrExpression (traverse fromGBoolExp expressions)
|
|
IR.BoolNot expression ->
|
|
fmap NotExpression (fromGBoolExp expression)
|
|
IR.BoolExists gExists ->
|
|
fromGExists gExists
|
|
IR.BoolFld expression ->
|
|
fromAnnBoolExpFld expression
|
|
where
|
|
fromGExists :: IR.GExists 'MSSQL (IR.AnnBoolExpFld 'MSSQL Expression) -> ReaderT EntityAlias FromIr Expression
|
|
fromGExists IR.GExists {_geTable, _geWhere} = do
|
|
selectFrom <- lift (fromQualifiedTable _geTable)
|
|
whereExpression <-
|
|
local (const (fromAlias selectFrom)) (fromGBoolExp _geWhere)
|
|
pure $
|
|
ExistsExpression $
|
|
emptySelect
|
|
{ selectOrderBy = Nothing,
|
|
selectProjections =
|
|
[ ExpressionProjection
|
|
( Aliased
|
|
{ aliasedThing = trueExpression,
|
|
aliasedAlias = existsFieldName
|
|
}
|
|
)
|
|
],
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = mempty,
|
|
selectWhere = Where [whereExpression],
|
|
selectTop = NoTop,
|
|
selectFor = NoFor,
|
|
selectOffset = Nothing
|
|
}
|
|
|
|
trueExpression :: Expression
|
|
trueExpression = ValueExpression (ODBC.BoolValue True)
|
|
|
|
-- | A version of @JSON_QUERY(..)@ that returns a proper json literal, rather
|
|
-- than SQL null, which does not compose properly with @FOR JSON@ clauses.
|
|
safeJsonQueryExpression :: JsonCardinality -> Expression -> Expression
|
|
safeJsonQueryExpression expectedType jsonQuery =
|
|
FunctionApplicationExpression (FunExpISNULL (JsonQueryExpression jsonQuery) jsonTypeExpression)
|
|
where
|
|
jsonTypeExpression = case expectedType of
|
|
JsonSingleton -> nullExpression
|
|
JsonArray -> emptyArrayExpression
|
|
|
|
nullExpression :: Expression
|
|
nullExpression = ValueExpression $ ODBC.TextValue "null"
|
|
|
|
emptyArrayExpression :: Expression
|
|
emptyArrayExpression = ValueExpression $ ODBC.TextValue "[]"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Constants
|
|
|
|
jsonFieldName :: Text
|
|
jsonFieldName = "json"
|
|
|
|
aggSubselectName :: Text
|
|
aggSubselectName = "agg_sub"
|
|
|
|
existsFieldName :: Text
|
|
existsFieldName = "exists_placeholder"
|
|
|
|
data UnfurledJoin = UnfurledJoin
|
|
{ unfurledJoin :: Join,
|
|
-- | Recorded if we joined onto an object relation.
|
|
unfurledObjectTableAlias :: Maybe (TableName, EntityAlias)
|
|
}
|
|
deriving (Show)
|
|
|
|
fromAnnotatedOrderByItemG ::
|
|
IR.AnnotatedOrderByItemG 'MSSQL Expression ->
|
|
WriterT (Seq UnfurledJoin) (ReaderT EntityAlias FromIr) OrderBy
|
|
fromAnnotatedOrderByItemG IR.OrderByItemG {obiType, obiColumn = obiColumn, obiNulls} = do
|
|
(orderByFieldName, orderByType) <- unfurlAnnotatedOrderByElement obiColumn
|
|
let orderByNullsOrder = fromMaybe NullsAnyOrder obiNulls
|
|
orderByOrder = fromMaybe AscOrder obiType
|
|
pure OrderBy {..}
|
|
|
|
-- | Unfurl the nested set of object relations (tell'd in the writer)
|
|
-- that are terminated by field name (IR.AOCColumn and
|
|
-- IR.AOCArrayAggregation).
|
|
unfurlAnnotatedOrderByElement ::
|
|
IR.AnnotatedOrderByElement 'MSSQL Expression ->
|
|
WriterT (Seq UnfurledJoin) (ReaderT EntityAlias FromIr) (FieldName, Maybe TSQL.ScalarType)
|
|
unfurlAnnotatedOrderByElement =
|
|
\case
|
|
IR.AOCColumn columnInfo -> do
|
|
fieldName <- lift (fromColumnInfo columnInfo)
|
|
pure
|
|
( fieldName,
|
|
case IR.ciType columnInfo of
|
|
IR.ColumnScalar t -> Just t
|
|
-- Above: It is of interest to us whether the type is
|
|
-- text/ntext/image. See ToQuery for more explanation.
|
|
_ -> Nothing
|
|
)
|
|
IR.AOCObjectRelation IR.RelInfo {riMapping = mapping, riRTable = table} annBoolExp annOrderByElementG -> do
|
|
selectFrom <- lift (lift (fromQualifiedTable table))
|
|
joinAliasEntity <-
|
|
lift (lift (generateAlias (ForOrderAlias (tableNameText table))))
|
|
foreignKeyConditions <- lift (fromMapping selectFrom mapping)
|
|
-- TODO: Because these object relations are re-used by regular
|
|
-- object mapping queries, this WHERE may be unnecessarily
|
|
-- restrictive. But I actually don't know from where such an
|
|
-- expression arises in the source GraphQL syntax.
|
|
--
|
|
-- Worst case scenario, we could put the WHERE in the key of the
|
|
-- Map in 'argsExistingJoins'. That would guarantee only equal
|
|
-- selects are re-used.
|
|
whereExpression <-
|
|
lift (local (const (fromAlias selectFrom)) (fromGBoolExp annBoolExp))
|
|
tell
|
|
( pure
|
|
UnfurledJoin
|
|
{ unfurledJoin =
|
|
Join
|
|
{ joinSource =
|
|
JoinSelect
|
|
emptySelect
|
|
{ selectTop = NoTop,
|
|
selectProjections = [StarProjection],
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = [],
|
|
selectWhere =
|
|
Where (foreignKeyConditions <> [whereExpression]),
|
|
selectFor = NoFor,
|
|
selectOrderBy = Nothing,
|
|
selectOffset = Nothing
|
|
},
|
|
joinJoinAlias =
|
|
JoinAlias {joinAliasEntity, joinAliasField = Nothing}
|
|
},
|
|
unfurledObjectTableAlias = Just (table, EntityAlias joinAliasEntity)
|
|
}
|
|
)
|
|
local
|
|
(const (EntityAlias joinAliasEntity))
|
|
(unfurlAnnotatedOrderByElement annOrderByElementG)
|
|
IR.AOCArrayAggregation IR.RelInfo {riMapping = mapping, riRTable = tableName} annBoolExp annAggregateOrderBy -> do
|
|
selectFrom <- lift (lift (fromQualifiedTable tableName))
|
|
let alias = aggFieldName
|
|
joinAliasEntity <-
|
|
lift (lift (generateAlias (ForOrderAlias (tableNameText tableName))))
|
|
foreignKeyConditions <- lift (fromMapping selectFrom mapping)
|
|
whereExpression <-
|
|
lift (local (const (fromAlias selectFrom)) (fromGBoolExp annBoolExp))
|
|
aggregate <-
|
|
lift
|
|
( local
|
|
(const (fromAlias selectFrom))
|
|
( case annAggregateOrderBy of
|
|
IR.AAOCount -> pure (CountAggregate StarCountable)
|
|
IR.AAOOp text columnInfo -> do
|
|
fieldName <- fromColumnInfo columnInfo
|
|
pure (OpAggregate text (pure (ColumnExpression fieldName)))
|
|
)
|
|
)
|
|
tell
|
|
( pure
|
|
( UnfurledJoin
|
|
{ unfurledJoin =
|
|
Join
|
|
{ joinSource =
|
|
JoinSelect
|
|
emptySelect
|
|
{ selectTop = NoTop,
|
|
selectProjections =
|
|
[ AggregateProjection
|
|
Aliased
|
|
{ aliasedThing = aggregate,
|
|
aliasedAlias = alias
|
|
}
|
|
],
|
|
selectFrom = Just selectFrom,
|
|
selectJoins = [],
|
|
selectWhere =
|
|
Where
|
|
(foreignKeyConditions <> [whereExpression]),
|
|
selectFor = NoFor,
|
|
selectOrderBy = Nothing,
|
|
selectOffset = Nothing
|
|
},
|
|
joinJoinAlias =
|
|
JoinAlias {joinAliasEntity, joinAliasField = Nothing}
|
|
},
|
|
unfurledObjectTableAlias = Nothing
|
|
}
|
|
)
|
|
)
|
|
pure
|
|
( FieldName {fieldNameEntity = joinAliasEntity, fieldName = alias},
|
|
Nothing
|
|
)
|
|
|
|
tableNameText :: TableName -> Text
|
|
tableNameText (TableName {tableName}) = tableName
|
|
|
|
fromColumnInfo :: IR.ColumnInfo 'MSSQL -> ReaderT EntityAlias FromIr FieldName
|
|
fromColumnInfo IR.ColumnInfo {ciColumn = column} =
|
|
columnNameToFieldName column <$> ask
|
|
|
|
aggFieldName :: Text
|
|
aggFieldName = "agg"
|