mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-23 23:43:44 +03:00
e8d2d4f364
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9014 GitOrigin-RevId: 64f51811770d88ad6d5b298fc4c71170ffd7182c
905 lines
30 KiB
Haskell
905 lines
30 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
-- | MSSQL ToQuery
|
|
--
|
|
-- Convert the simple T-SQL AST to an SQL query, ready to be passed to the odbc
|
|
-- package's query/exec functions.
|
|
--
|
|
-- We define a custom prettyprinter with the type 'Printer'.
|
|
--
|
|
-- If you'd like to trace and see what a 'Printer' looks like as SQL, you can use something like:
|
|
-- > ltraceM "sql" (ODBC.renderQuery (toQueryPretty myPrinter))
|
|
module Hasura.Backends.MSSQL.ToQuery
|
|
( fromSelect,
|
|
fromReselect,
|
|
toQueryFlat,
|
|
toQueryPretty,
|
|
fromInsert,
|
|
fromMerge,
|
|
fromTempTableDDL,
|
|
fromSetIdentityInsert,
|
|
fromDelete,
|
|
fromUpdate,
|
|
fromSelectIntoTempTable,
|
|
fromInsertValuesIntoTempTable,
|
|
dropTempTableQuery,
|
|
fromRawUnescapedText,
|
|
fromTableName,
|
|
(<+>),
|
|
Printer (..),
|
|
)
|
|
where
|
|
|
|
import Data.Aeson (ToJSON (..))
|
|
import Data.HashMap.Strict qualified as HashMap
|
|
import Data.List (intersperse)
|
|
import Data.String
|
|
import Data.Text qualified as T
|
|
import Data.Text.Extended qualified as T
|
|
import Data.Text.Lazy qualified as L
|
|
import Data.Text.Lazy.Builder qualified as L
|
|
import Database.ODBC.SQLServer
|
|
import Hasura.Backends.MSSQL.Types
|
|
import Hasura.NativeQuery.Metadata (InterpolatedItem (..), InterpolatedQuery (..))
|
|
import Hasura.Prelude hiding (GT, LT)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- * Types
|
|
|
|
data Printer
|
|
= SeqPrinter [Printer]
|
|
| SepByPrinter Printer [Printer]
|
|
| NewlinePrinter
|
|
| QueryPrinter Query
|
|
| IndentPrinter Int Printer
|
|
deriving (Show, Eq)
|
|
|
|
instance IsString Printer where
|
|
fromString = QueryPrinter . fromString
|
|
|
|
(<+>) :: Printer -> Printer -> Printer
|
|
(<+>) x y = SeqPrinter [x, y]
|
|
|
|
(<+>?) :: Printer -> Maybe Printer -> Printer
|
|
(<+>?) x Nothing = x
|
|
(<+>?) x (Just y) = SeqPrinter [x, y]
|
|
|
|
(?<+>) :: Maybe Printer -> Printer -> Printer
|
|
(?<+>) Nothing x = x
|
|
(?<+>) (Just x) y = SeqPrinter [x, y]
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- * Instances
|
|
|
|
-- This is a debug instance, only here because it avoids a circular
|
|
-- dependency between this module and Types/Instances.
|
|
instance ToJSON Expression where
|
|
toJSON = toJSON . T.toTxt . toQueryFlat . fromExpression
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- * Printer generators
|
|
|
|
fromExpression :: Expression -> Printer
|
|
fromExpression =
|
|
\case
|
|
CastExpression e t dataLength ->
|
|
"CAST("
|
|
<+> fromExpression e
|
|
<+> " AS "
|
|
<+> fromString (T.unpack $ scalarTypeDBName dataLength t)
|
|
<+> ")"
|
|
JsonQueryExpression e -> "JSON_QUERY(" <+> fromExpression e <+> ")"
|
|
JsonValueExpression e path ->
|
|
"JSON_VALUE(" <+> fromExpression e <+> fromPath path <+> ")"
|
|
ValueExpression value -> QueryPrinter $ toSql value
|
|
AndExpression xs ->
|
|
case xs of
|
|
[] -> truePrinter
|
|
_ ->
|
|
SepByPrinter
|
|
(NewlinePrinter <+> "AND ")
|
|
(fmap (\x -> "(" <+> fromExpression x <+> ")") (toList xs))
|
|
OrExpression xs ->
|
|
case xs of
|
|
[] -> falsePrinter
|
|
_ ->
|
|
SepByPrinter
|
|
(NewlinePrinter <+> "OR ")
|
|
(fmap (\x -> "(" <+> fromExpression x <+> ")") (toList xs))
|
|
NotExpression expression -> "NOT " <+> fromExpression expression
|
|
ExistsExpression sel -> "EXISTS (" <+> fromSelect sel <+> ")"
|
|
IsNullExpression expression ->
|
|
"(" <+> fromExpression expression <+> ") IS NULL"
|
|
IsNotNullExpression expression ->
|
|
"(" <+> fromExpression expression <+> ") IS NOT NULL"
|
|
ColumnExpression fieldName -> fromFieldName fieldName
|
|
ToStringExpression e -> "CONCAT(" <+> fromExpression e <+> ", '')"
|
|
SelectExpression s -> "(" <+> IndentPrinter 1 (fromSelect s) <+> ")"
|
|
OpExpression op x y ->
|
|
"("
|
|
<+> fromExpression x
|
|
<+> ") "
|
|
<+> fromOp op
|
|
<+> " ("
|
|
<+> fromExpression y
|
|
<+> ")"
|
|
MethodApplicationExpression ex methodAppExp -> fromMethodApplicationExpression ex methodAppExp
|
|
FunctionApplicationExpression funAppExp -> fromFunctionApplicationExpression funAppExp
|
|
ListExpression xs -> SepByPrinter ", " $ fromExpression <$> xs
|
|
STOpExpression op e str ->
|
|
"("
|
|
<+> fromExpression e
|
|
<+> ")."
|
|
<+> fromString (show op)
|
|
<+> "("
|
|
<+> fromExpression str
|
|
<+> ") = 1"
|
|
ConditionalExpression condition trueExpression falseExpression ->
|
|
"(CASE WHEN("
|
|
<+> fromExpression condition
|
|
<+> ") THEN "
|
|
<+> fromExpression trueExpression
|
|
<+> " ELSE "
|
|
<+> fromExpression falseExpression
|
|
<+> " END)"
|
|
DefaultExpression -> "DEFAULT"
|
|
|
|
fromMethodApplicationExpression :: Expression -> MethodApplicationExpression -> Printer
|
|
fromMethodApplicationExpression ex methodAppExp =
|
|
case methodAppExp of
|
|
MethExpSTAsText -> fromApp "STAsText" []
|
|
where
|
|
fromApp :: Text -> [Expression] -> Printer
|
|
fromApp method args =
|
|
fromExpression ex
|
|
<+> "."
|
|
<+> fromString (T.unpack method)
|
|
<+> "("
|
|
<+> SeqPrinter (map fromExpression args)
|
|
<+> ")"
|
|
|
|
fromFunctionApplicationExpression :: FunctionApplicationExpression -> Printer
|
|
fromFunctionApplicationExpression funAppExp = case funAppExp of
|
|
(FunExpISNULL x y) -> fromApp "ISNULL" [x, y]
|
|
where
|
|
fromApp :: Text -> [Expression] -> Printer
|
|
fromApp function args =
|
|
fromString (T.unpack function)
|
|
<+> "("
|
|
<+> SepByPrinter ", " (map fromExpression args)
|
|
<+> ")"
|
|
|
|
fromOp :: Op -> Printer
|
|
fromOp =
|
|
\case
|
|
LT -> "<"
|
|
GT -> ">"
|
|
GTE -> ">="
|
|
LTE -> "<="
|
|
IN -> "IN"
|
|
NIN -> "NOT IN"
|
|
LIKE -> "LIKE"
|
|
NLIKE -> "NOT LIKE"
|
|
EQ' -> "="
|
|
NEQ' -> "!="
|
|
|
|
fromPath :: JsonPath -> Printer
|
|
fromPath path =
|
|
", " <+> string path
|
|
where
|
|
string =
|
|
fromExpression
|
|
. ValueExpression
|
|
. TextValue
|
|
. L.toStrict
|
|
. L.toLazyText
|
|
. go
|
|
go =
|
|
\case
|
|
RootPath -> "$"
|
|
IndexPath r i -> go r <> "[" <> L.fromString (show i) <> "]"
|
|
FieldPath r f -> go r <> ".\"" <> L.fromText f <> "\""
|
|
|
|
fromFieldName :: FieldName -> Printer
|
|
fromFieldName (FieldName {..}) =
|
|
fromNameText fieldNameEntity <+> "." <+> fromNameText fieldName
|
|
|
|
fromInserted :: Inserted -> Printer
|
|
fromInserted Inserted = "INSERTED"
|
|
|
|
fromDeleted :: Deleted -> Printer
|
|
fromDeleted Deleted = "DELETED"
|
|
|
|
fromOutputColumn :: Printer -> OutputColumn -> Printer
|
|
fromOutputColumn prefix (OutputColumn columnName) =
|
|
prefix <+> "." <+> fromNameText (columnNameText columnName)
|
|
|
|
fromOutput :: (t -> Printer) -> Output t -> Printer
|
|
fromOutput typePrinter (Output ty outputColumns) =
|
|
"OUTPUT " <+> SepByPrinter ", " (map (fromOutputColumn (typePrinter ty)) outputColumns)
|
|
|
|
fromInsertOutput :: InsertOutput -> Printer
|
|
fromInsertOutput = fromOutput fromInserted
|
|
|
|
fromDeleteOutput :: DeleteOutput -> Printer
|
|
fromDeleteOutput = fromOutput fromDeleted
|
|
|
|
fromUpdateOutput :: UpdateOutput -> Printer
|
|
fromUpdateOutput = fromOutput fromInserted
|
|
|
|
fromValues :: Values -> Printer
|
|
fromValues (Values values) =
|
|
"( " <+> SepByPrinter ", " (map fromExpression values) <+> " )"
|
|
|
|
fromValuesList :: [Values] -> Printer
|
|
fromValuesList valuesList =
|
|
"VALUES " <+> SepByPrinter ", " (map fromValues valuesList)
|
|
|
|
fromInsert :: Insert -> Printer
|
|
fromInsert Insert {..} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
$ ["INSERT INTO " <+> fromTableName insertTable]
|
|
<> [ "(" <+> SepByPrinter ", " (map (fromNameText . columnNameText) insertColumns) <+> ")"
|
|
| not (null insertColumns)
|
|
]
|
|
<> [ fromInsertOutput insertOutput,
|
|
"INTO " <+> fromTempTable insertTempTable,
|
|
if null insertColumns
|
|
then "VALUES " <+> SepByPrinter ", " (map (const "(DEFAULT)") insertValues)
|
|
else fromValuesList insertValues
|
|
]
|
|
|
|
fromSetValue :: SetValue -> Printer
|
|
fromSetValue = \case
|
|
SetON -> "ON"
|
|
SetOFF -> "OFF"
|
|
|
|
fromSetIdentityInsert :: SetIdentityInsert -> Printer
|
|
fromSetIdentityInsert SetIdentityInsert {..} =
|
|
SepByPrinter
|
|
" "
|
|
[ "SET IDENTITY_INSERT",
|
|
tableName,
|
|
fromSetValue setValue
|
|
]
|
|
where
|
|
tableName =
|
|
case setTable of
|
|
RegularTableName name -> fromTableName name
|
|
TemporaryTableName name -> fromTempTableName name
|
|
|
|
-- | Generate a statement to insert values into temporary table.
|
|
fromInsertValuesIntoTempTable :: InsertValuesIntoTempTable -> Printer
|
|
fromInsertValuesIntoTempTable InsertValuesIntoTempTable {..} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "INSERT INTO " <+> fromTempTableName ivittTempTableName,
|
|
"(" <+> SepByPrinter ", " (map (fromNameText . columnNameText) ivittColumns) <+> ")",
|
|
fromValuesList ivittValues
|
|
]
|
|
|
|
-- | Alias for the source table in a MERGE statement. Used when pretty printing MERGE statments.
|
|
mergeSourceAlias :: Text
|
|
mergeSourceAlias = "source"
|
|
|
|
-- | Alias for the target table in a MERGE statement. Used when pretty printing MERGE statments.
|
|
mergeTargetAlias :: Text
|
|
mergeTargetAlias = "target"
|
|
|
|
-- | USING section of a MERGE statement. Used in 'fromMerge'.
|
|
fromMergeUsing :: MergeUsing -> Printer
|
|
fromMergeUsing MergeUsing {..} =
|
|
"USING (" <+> fromSelect selectSubQuery <+> ") AS " <+> fromNameText mergeSourceAlias
|
|
where
|
|
selectSubQuery :: Select
|
|
selectSubQuery =
|
|
let alias = "merge_temptable"
|
|
columnNameToProjection ColumnName {columnNameText} =
|
|
-- merge_temptable.column_name AS column_name
|
|
FieldNameProjection $
|
|
Aliased
|
|
{ aliasedThing = FieldName columnNameText alias,
|
|
aliasedAlias = columnNameText
|
|
}
|
|
in emptySelect
|
|
{ selectProjections = map columnNameToProjection mergeUsingColumns,
|
|
selectFrom = Just (FromTempTable $ Aliased mergeUsingTempTable alias) -- FROM temp_table AS merge_temptable
|
|
}
|
|
|
|
-- | ON section of a MERGE statement. Used in 'fromMerge'.
|
|
fromMergeOn :: MergeOn -> Printer
|
|
fromMergeOn MergeOn {..} =
|
|
"ON (" <+> onExpression <+> ")"
|
|
where
|
|
onExpression
|
|
| null mergeOnColumns =
|
|
falsePrinter
|
|
| otherwise =
|
|
(fromExpression . AndExpression) (map matchColumn mergeOnColumns)
|
|
|
|
matchColumn :: ColumnName -> Expression
|
|
matchColumn ColumnName {..} =
|
|
let sourceColumn = ColumnExpression $ FieldName columnNameText mergeSourceAlias
|
|
targetColumn = ColumnExpression $ FieldName columnNameText mergeTargetAlias
|
|
in OpExpression EQ' sourceColumn targetColumn
|
|
|
|
-- | WHEN MATCHED section of a MERGE statement. Used in 'fromMerge'.
|
|
fromMergeWhenMatched :: MergeWhenMatched -> Printer
|
|
fromMergeWhenMatched (MergeWhenMatched updateColumns updateCondition updatePreset) =
|
|
if null updates
|
|
then ""
|
|
else
|
|
"WHEN MATCHED AND "
|
|
<+> fromExpression updateCondition
|
|
<+> " THEN UPDATE "
|
|
<+> fromUpdateSet updates
|
|
where
|
|
updates = updateSet <> HashMap.map UpdateSet updatePreset
|
|
|
|
updateSet :: UpdateSet
|
|
updateSet =
|
|
HashMap.fromList $
|
|
map
|
|
( \cn@ColumnName {..} ->
|
|
( cn,
|
|
UpdateSet $ ColumnExpression $ FieldName columnNameText mergeSourceAlias
|
|
)
|
|
)
|
|
updateColumns
|
|
|
|
-- | WHEN NOT MATCHED section of a MERGE statement. Used in 'fromMerge'.
|
|
fromMergeWhenNotMatched :: MergeWhenNotMatched -> Printer
|
|
fromMergeWhenNotMatched (MergeWhenNotMatched insertColumns) =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "WHEN NOT MATCHED THEN INSERT (" <+> SepByPrinter ", " (map fromColumnName insertColumns) <+> ")",
|
|
fromValuesList [Values columnsFromSource]
|
|
]
|
|
where
|
|
columnsFromSource =
|
|
insertColumns <&> \ColumnName {..} -> ColumnExpression $ FieldName columnNameText mergeSourceAlias
|
|
|
|
-- | Generate a MERGE SQL statement
|
|
fromMerge :: Merge -> Printer
|
|
fromMerge Merge {..} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "MERGE " <+> fromAliased (fmap fromTableName mergeTableAsTarget),
|
|
fromMergeUsing mergeUsing,
|
|
fromMergeOn mergeOn,
|
|
fromMergeWhenMatched mergeWhenMatched,
|
|
fromMergeWhenNotMatched mergeWhenNotMatched,
|
|
fromInsertOutput mergeInsertOutput,
|
|
"INTO " <+> fromTempTable mergeOutputTempTable,
|
|
";" -- Always, a Merge statement should end with a ";"
|
|
]
|
|
where
|
|
mergeTableAsTarget :: Aliased TableName
|
|
mergeTableAsTarget = Aliased mergeTargetTable mergeTargetAlias
|
|
|
|
-- | Generate a delete statement
|
|
--
|
|
-- > Delete
|
|
-- > (Aliased (TableName "table" "schema") "alias")
|
|
-- > [ColumnName "id", ColumnName "name"]
|
|
-- > (Where [OpExpression EQ' (ValueExpression (IntValue 1)) (ValueExpression (IntValue 1))])
|
|
--
|
|
-- Becomes:
|
|
--
|
|
-- > DELETE [alias] OUTPUT DELETED.[id], DELETED.[name] INTO #deleted([id], [name]) FROM [schema].[table] AS [alias] WHERE ((1) = (1))
|
|
fromDelete :: Delete -> Printer
|
|
fromDelete Delete {deleteTable, deleteOutput, deleteTempTable, deleteWhere} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "DELETE " <+> fromNameText (aliasedAlias deleteTable),
|
|
fromDeleteOutput deleteOutput,
|
|
"INTO " <+> fromTempTable deleteTempTable,
|
|
"FROM " <+> fromAliased (fmap fromTableName deleteTable),
|
|
fromWhere deleteWhere
|
|
]
|
|
|
|
-- | Generate an update statement
|
|
--
|
|
-- > Update
|
|
-- > (Aliased (TableName "table" "schema") "alias")
|
|
-- > (fromList [(ColumnName "name", ValueExpression (TextValue "updated_name"))])
|
|
-- > (Output Inserted)
|
|
-- > (TempTable (TempTableName "updated") [ColumnName "id", ColumnName "name"])
|
|
-- > (Where [OpExpression EQ' (ColumnName "id") (ValueExpression (IntValue 1))])
|
|
--
|
|
-- Becomes:
|
|
--
|
|
-- > UPDATE [alias] SET [alias].[name] = 'updated_name' OUTPUT INSERTED.[id], INSERTED.[name] INTO
|
|
-- > #updated([id], [name]) FROM [schema].[table] AS [alias] WHERE (id = 1)
|
|
fromUpdate :: Update -> Printer
|
|
fromUpdate Update {..} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "UPDATE " <+> fromNameText (aliasedAlias updateTable),
|
|
fromUpdateSet updateSet,
|
|
fromUpdateOutput updateOutput,
|
|
"INTO " <+> fromTempTable updateTempTable,
|
|
"FROM " <+> fromAliased (fmap fromTableName updateTable),
|
|
fromWhere updateWhere
|
|
]
|
|
|
|
fromUpdateSet :: UpdateSet -> Printer
|
|
fromUpdateSet setColumns =
|
|
let updateColumnValue (column, updateOp) =
|
|
fromColumnName column <+> fromUpdateOperator (fromExpression <$> updateOp)
|
|
in "SET " <+> SepByPrinter ", " (map updateColumnValue (HashMap.toList setColumns))
|
|
where
|
|
fromUpdateOperator :: UpdateOperator Printer -> Printer
|
|
fromUpdateOperator = \case
|
|
UpdateSet p -> " = " <+> p
|
|
UpdateInc p -> " += " <+> p
|
|
|
|
fromTempTableDDL :: TempTableDDL -> Printer
|
|
fromTempTableDDL = \case
|
|
CreateTemp tempTableName tempColumns ->
|
|
"CREATE TABLE "
|
|
<+> fromTempTableName tempTableName
|
|
<+> " ( "
|
|
<+> columns
|
|
<+> " ) "
|
|
where
|
|
columns =
|
|
SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(map columnNameAndType tempColumns)
|
|
columnNameAndType (UnifiedColumn name ty) =
|
|
fromColumnName name
|
|
<+> " "
|
|
<+> fromString (T.unpack (scalarTypeDBName DataLengthMax ty))
|
|
<+> " null"
|
|
InsertTemp declares tempTableName interpolatedQuery ->
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
( map fromDeclare declares
|
|
<> [ "INSERT INTO "
|
|
<+> fromTempTableName tempTableName
|
|
<+> " "
|
|
<+> renderInterpolatedQuery interpolatedQuery
|
|
]
|
|
)
|
|
DropTemp tempTableName ->
|
|
"DROP TABLE "
|
|
<+> fromTempTableName tempTableName
|
|
|
|
fromDeclare :: Declare -> Printer
|
|
fromDeclare (Declare dName dType dValue) =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "DECLARE @" <+> fromRawUnescapedText dName <+> " " <+> fromRawUnescapedText (scalarTypeDBName DataLengthMax dType) <+> ";",
|
|
"SET @" <+> fromRawUnescapedText dName <+> " = " <+> fromExpression dValue <+> ";"
|
|
]
|
|
|
|
-- | Converts `SelectIntoTempTable`.
|
|
--
|
|
-- > SelectIntoTempTable (TempTableName "deleted") [UnifiedColumn "id" IntegerType, UnifiedColumn "name" TextType] (TableName "table" "schema")
|
|
--
|
|
-- Becomes:
|
|
--
|
|
-- > SELECT [id], [name] INTO #deleted([id], [name]) FROM [schema].[table] WHERE (1<>1) UNION ALL SELECT [id], [name] FROM [schema].[table];
|
|
--
|
|
-- We add the `UNION ALL` part to avoid copying identity constraints, and we cast columns with types such as `timestamp`
|
|
-- which are non-insertable to a different type.
|
|
fromSelectIntoTempTable :: SelectIntoTempTable -> Printer
|
|
fromSelectIntoTempTable SelectIntoTempTable {sittTempTableName, sittColumns, sittFromTableName, sittConstraints} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
$ [ "SELECT "
|
|
<+> columns,
|
|
"INTO " <+> fromTempTableName sittTempTableName,
|
|
"FROM " <+> fromTableName sittFromTableName,
|
|
"WHERE " <+> falsePrinter
|
|
]
|
|
<> case sittConstraints of
|
|
RemoveConstraints ->
|
|
[ "UNION ALL SELECT " <+> columns,
|
|
"FROM " <+> fromTableName sittFromTableName,
|
|
"WHERE " <+> falsePrinter
|
|
]
|
|
KeepConstraints ->
|
|
[]
|
|
where
|
|
-- column names separated by commas
|
|
columns =
|
|
SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(map columnNameFromUnifiedColumn sittColumns)
|
|
|
|
-- column name with potential modifications of types
|
|
columnNameFromUnifiedColumn (UnifiedColumn columnName columnType) =
|
|
case columnType of
|
|
-- The "timestamp" is type synonym for "rowversion" and it is just an incrementing number and does not preserve a date or a time.
|
|
-- So, the "timestamp" type is neither insertable nor explicitly updatable. Its values are unique binary numbers within a database.
|
|
-- We're using "binary" type instead so that we can copy a timestamp row value safely into the temporary table.
|
|
-- See https://docs.microsoft.com/en-us/sql/t-sql/data-types/rowversion-transact-sql for more details.
|
|
TimestampType -> "CAST(" <+> fromColumnName columnName <+> " AS binary(8)) AS " <+> fromColumnName columnName
|
|
_ -> fromColumnName columnName
|
|
|
|
-- | @TempTableName "deleted"@ becomes @\#deleted@
|
|
fromTempTableName :: TempTableName -> Printer
|
|
fromTempTableName (TempTableName v) = QueryPrinter (fromString . T.unpack $ "#" <> v)
|
|
|
|
fromTempTable :: TempTable -> Printer
|
|
fromTempTable (TempTable table columns) =
|
|
fromTempTableName table <+> parens (SepByPrinter ", " (map fromColumnName columns))
|
|
|
|
-- | @TempTableName "temp_table" is converted to "DROP TABLE #temp_table"
|
|
dropTempTableQuery :: TempTableName -> Printer
|
|
dropTempTableQuery tempTableName =
|
|
QueryPrinter "DROP TABLE " <+> fromTempTableName tempTableName
|
|
|
|
fromSelect :: Select -> Printer
|
|
fromSelect Select {..} = fmap fromWith selectWith ?<+> result
|
|
where
|
|
result =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
$ [ "SELECT "
|
|
<+> IndentPrinter
|
|
7
|
|
( SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(map fromProjection (toList selectProjections))
|
|
)
|
|
]
|
|
<> ["FROM " <+> IndentPrinter 5 (fromFrom f) | Just f <- [selectFrom]]
|
|
<> [ SepByPrinter
|
|
NewlinePrinter
|
|
( map
|
|
( \Join {..} ->
|
|
SeqPrinter
|
|
[ "OUTER APPLY (",
|
|
IndentPrinter 13 (fromJoinSource joinSource),
|
|
") ",
|
|
NewlinePrinter,
|
|
"AS ",
|
|
fromJoinAlias joinJoinAlias
|
|
]
|
|
)
|
|
selectJoins
|
|
),
|
|
fromWhere selectWhere,
|
|
fromOrderBys selectTop selectOffset selectOrderBy,
|
|
fromFor selectFor
|
|
]
|
|
|
|
fromWith :: With -> Printer
|
|
fromWith (With withSelects) =
|
|
"WITH " <+> SepByPrinter ", " (map fromAliasedSelect (toList withSelects)) <+> NewlinePrinter
|
|
where
|
|
fromAliasedSelect (Aliased {..}) =
|
|
fromNameText aliasedAlias
|
|
<+> " AS "
|
|
<+> "( "
|
|
<+> ( case aliasedThing of
|
|
CTESelect select ->
|
|
fromSelect select
|
|
CTEUnsafeRawSQL nativeQuery ->
|
|
renderInterpolatedQuery nativeQuery <+> "\n"
|
|
)
|
|
<+> " )"
|
|
|
|
renderInterpolatedQuery :: InterpolatedQuery Expression -> Printer
|
|
renderInterpolatedQuery = foldr (<+>) "" . renderedParts
|
|
where
|
|
renderedParts :: InterpolatedQuery Expression -> [Printer]
|
|
renderedParts (InterpolatedQuery parts) =
|
|
( \case
|
|
IIText t -> fromRawUnescapedText t
|
|
IIVariable v -> fromExpression v
|
|
)
|
|
<$> parts
|
|
|
|
fromJoinSource :: JoinSource -> Printer
|
|
fromJoinSource =
|
|
\case
|
|
JoinSelect sel -> fromSelect sel
|
|
JoinReselect reselect -> fromReselect reselect
|
|
|
|
fromReselect :: Reselect -> Printer
|
|
fromReselect Reselect {..} = result
|
|
where
|
|
result =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "SELECT "
|
|
<+> IndentPrinter
|
|
7
|
|
( SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(map fromProjection (toList reselectProjections))
|
|
),
|
|
fromWhere reselectWhere,
|
|
fromFor reselectFor
|
|
]
|
|
|
|
fromOrderBys ::
|
|
Top -> Maybe Expression -> Maybe (NonEmpty OrderBy) -> Printer
|
|
fromOrderBys NoTop Nothing Nothing = "" -- An ORDER BY is wasteful if not needed.
|
|
fromOrderBys top moffset morderBys =
|
|
SeqPrinter
|
|
[ "ORDER BY ",
|
|
IndentPrinter
|
|
9
|
|
( SepByPrinter
|
|
NewlinePrinter
|
|
[ case morderBys of
|
|
-- If you ORDER BY 1, a text field will signal an
|
|
-- error. What we want instead is to just order by
|
|
-- nothing, but also satisfy the syntactic
|
|
-- requirements. Thus ORDER BY (SELECT NULL).
|
|
--
|
|
-- This won't create consistent orderings, but that's
|
|
-- why you should specify an order_by in your GraphQL
|
|
-- query anyway, to define the ordering.
|
|
Nothing -> "(SELECT NULL) /* ORDER BY is required for OFFSET */"
|
|
Just orderBys ->
|
|
SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(concatMap fromOrderBy (toList orderBys)),
|
|
case (top, moffset) of
|
|
(NoTop, Nothing) -> ""
|
|
(NoTop, Just offset) ->
|
|
"OFFSET " <+> fromExpression offset <+> " ROWS"
|
|
(Top n, Nothing) ->
|
|
"OFFSET 0 ROWS FETCH NEXT "
|
|
<+> QueryPrinter (toSql (IntValue n))
|
|
<+> " ROWS ONLY"
|
|
(Top n, Just offset) ->
|
|
"OFFSET "
|
|
<+> fromExpression offset
|
|
<+> " ROWS FETCH NEXT "
|
|
<+> QueryPrinter (toSql (IntValue n))
|
|
<+> " ROWS ONLY"
|
|
]
|
|
)
|
|
]
|
|
|
|
fromOrderBy :: OrderBy -> [Printer]
|
|
fromOrderBy OrderBy {..} =
|
|
[ fromNullsOrder orderByFieldName orderByNullsOrder,
|
|
-- Above: This doesn't do anything when using text, ntext or image
|
|
-- types. See below on CAST commentary.
|
|
wrapNullHandling (fromFieldName orderByFieldName)
|
|
<+> " "
|
|
<+> fromOrder orderByOrder
|
|
]
|
|
where
|
|
wrapNullHandling inner =
|
|
case orderByType of
|
|
Just TextType -> castTextish inner
|
|
Just WtextType -> castTextish inner
|
|
-- Above: For some types, we have to do null handling manually
|
|
-- ourselves:
|
|
_ -> inner
|
|
-- Direct quote from SQL Server error response:
|
|
--
|
|
-- > The text, ntext, and image data types cannot be compared or
|
|
-- > sorted, except when using IS NULL or LIKE operator.
|
|
--
|
|
-- So we cast it to a varchar, maximum length.
|
|
castTextish inner = "CAST(" <+> inner <+> " AS VARCHAR(MAX))"
|
|
|
|
fromOrder :: Order -> Printer
|
|
fromOrder =
|
|
\case
|
|
AscOrder -> "ASC"
|
|
DescOrder -> "DESC"
|
|
|
|
fromNullsOrder :: FieldName -> NullsOrder -> Printer
|
|
fromNullsOrder fieldName =
|
|
\case
|
|
NullsAnyOrder -> ""
|
|
NullsFirst -> "IIF(" <+> fromFieldName fieldName <+> " IS NULL, 0, 1)"
|
|
NullsLast -> "IIF(" <+> fromFieldName fieldName <+> " IS NULL, 1, 0)"
|
|
|
|
fromJoinAlias :: JoinAlias -> Printer
|
|
fromJoinAlias JoinAlias {..} =
|
|
fromNameText joinAliasEntity
|
|
<+>? fmap (\name -> "(" <+> fromNameText name <+> ")") joinAliasField
|
|
|
|
fromFor :: For -> Printer
|
|
fromFor =
|
|
\case
|
|
NoFor -> ""
|
|
JsonFor ForJson {jsonCardinality} ->
|
|
"FOR JSON PATH, INCLUDE_NULL_VALUES"
|
|
<+> case jsonCardinality of
|
|
JsonArray -> ""
|
|
JsonSingleton -> ", WITHOUT_ARRAY_WRAPPER"
|
|
|
|
fromProjection :: Projection -> Printer
|
|
fromProjection =
|
|
\case
|
|
ExpressionProjection aliasedExpression ->
|
|
fromAliased (fmap fromExpression aliasedExpression)
|
|
FieldNameProjection aliasedFieldName ->
|
|
fromAliased (fmap fromFieldName aliasedFieldName)
|
|
AggregateProjection aliasedAggregate ->
|
|
fromAliased (fmap fromAggregate aliasedAggregate)
|
|
StarProjection -> "*"
|
|
|
|
fromAggregate :: Aggregate -> Printer
|
|
fromAggregate =
|
|
\case
|
|
CountAggregate countable -> "COUNT(" <+> fromCountable countable <+> ")"
|
|
OpAggregate op args ->
|
|
QueryPrinter (rawUnescapedText op)
|
|
<+> "("
|
|
<+> SepByPrinter ", " (map fromExpression (toList args))
|
|
<+> ")"
|
|
TextAggregate text -> fromExpression (ValueExpression (TextValue text))
|
|
|
|
fromCountable :: Countable FieldName -> Printer
|
|
fromCountable =
|
|
\case
|
|
StarCountable -> "*"
|
|
NonNullFieldCountable field -> fromFieldName field
|
|
DistinctCountable field -> "DISTINCT " <+> fromFieldName field
|
|
|
|
fromWhere :: Where -> Printer
|
|
fromWhere =
|
|
\case
|
|
Where expressions
|
|
| Just whereExp <- collapseWhere (AndExpression expressions) ->
|
|
"WHERE " <+> IndentPrinter 6 (fromExpression whereExp)
|
|
| otherwise -> ""
|
|
|
|
-- | Drop useless examples like this from the output:
|
|
--
|
|
-- WHERE (((1<>1))
|
|
-- AND ((1=1)))
|
|
-- AND ((1=1))
|
|
--
|
|
-- And
|
|
--
|
|
-- WHERE ((1<>1))
|
|
--
|
|
-- They're redundant, but make the output less readable.
|
|
collapseWhere :: Expression -> Maybe Expression
|
|
collapseWhere = go
|
|
where
|
|
go =
|
|
\case
|
|
ValueExpression (BoolValue True) -> Nothing
|
|
AndExpression xs ->
|
|
case mapMaybe go xs of
|
|
[] -> Nothing
|
|
ys -> pure (AndExpression ys)
|
|
e -> pure e
|
|
|
|
fromFrom :: From -> Printer
|
|
fromFrom =
|
|
\case
|
|
FromQualifiedTable aliasedQualifiedTableName ->
|
|
fromAliased (fmap fromTableName aliasedQualifiedTableName)
|
|
FromOpenJson openJson -> fromAliased (fmap fromOpenJson openJson)
|
|
FromSelect select -> fromAliased (fmap (parens . fromSelect) select)
|
|
FromIdentifier identifier -> fromNameText identifier
|
|
FromTempTable aliasedTempTable -> fromAliased (fmap fromTempTableName aliasedTempTable)
|
|
|
|
fromOpenJson :: OpenJson -> Printer
|
|
fromOpenJson OpenJson {openJsonExpression, openJsonWith} =
|
|
SepByPrinter
|
|
NewlinePrinter
|
|
[ "OPENJSON("
|
|
<+> IndentPrinter 9 (fromExpression openJsonExpression)
|
|
<+> ")",
|
|
case openJsonWith of
|
|
Nothing -> ""
|
|
Just openJsonWith' ->
|
|
"WITH ("
|
|
<+> IndentPrinter
|
|
5
|
|
( SepByPrinter
|
|
("," <+> NewlinePrinter)
|
|
(fromJsonFieldSpec <$> toList openJsonWith')
|
|
)
|
|
<+> ")"
|
|
]
|
|
|
|
fromJsonFieldSpec :: JsonFieldSpec -> Printer
|
|
fromJsonFieldSpec =
|
|
\case
|
|
StringField name mPath -> fromNameText name <+> " NVARCHAR(MAX)" <+> quote mPath
|
|
JsonField name mPath -> fromJsonFieldSpec (StringField name mPath) <+> " AS JSON"
|
|
ScalarField fieldType fieldLength name mPath ->
|
|
fromNameText name
|
|
<+> " "
|
|
<+> fromString (T.unpack $ scalarTypeDBName fieldLength fieldType)
|
|
<+> quote mPath
|
|
where
|
|
quote mPath = maybe "" ((\p -> " '" <+> p <+> "'") . go) mPath
|
|
go = \case
|
|
RootPath -> "$"
|
|
IndexPath r i -> go r <+> "[" <+> fromString (show i) <+> "]"
|
|
FieldPath r f -> go r <+> ".\"" <+> fromString (T.unpack f) <+> "\""
|
|
|
|
fromTableName :: TableName -> Printer
|
|
fromTableName (TableName tableName (SchemaName tableSchema)) =
|
|
fromNameText tableSchema <+> "." <+> fromNameText tableName
|
|
|
|
fromAliased :: Aliased Printer -> Printer
|
|
fromAliased Aliased {..} =
|
|
aliasedThing
|
|
<+> ((" AS " <+>) . fromNameText) aliasedAlias
|
|
|
|
fromColumnName :: ColumnName -> Printer
|
|
fromColumnName (ColumnName colname) = quoteIdentifier colname
|
|
|
|
fromNameText :: Text -> Printer
|
|
fromNameText = quoteIdentifier
|
|
|
|
fromRawUnescapedText :: Text -> Printer
|
|
fromRawUnescapedText t = QueryPrinter (rawUnescapedText t)
|
|
|
|
-- | In Sql Server identifiers can be quoted using square brackets or double
|
|
-- quotes, "Delimited Identifiers" in T-SQL parlance, which gives full freedom
|
|
-- in what can syntactically constitute a name of a thing.
|
|
--
|
|
-- The delimiting characters may themselves appear in a delimited identifier,
|
|
-- in which case they are quoted by duplication of the terminal delimiter. This
|
|
-- is the only character escaping that happens within a delimited identifier.
|
|
--
|
|
-- (TODO: That fact does not seem to be documented anywhere I could find, but
|
|
-- seems to be folklore. I verified it myself at any rate)
|
|
--
|
|
-- Reference: https://learn.microsoft.com/en-us/sql/relational-databases/databases/database-identifiers?view=sql-server-ver16
|
|
quoteIdentifier :: Text -> Printer
|
|
quoteIdentifier ident = QueryPrinter (rawUnescapedText ("[" <> duplicateBrackets ident <> "]"))
|
|
where
|
|
duplicateBrackets :: Text -> Text
|
|
duplicateBrackets = T.replace "]" "]]"
|
|
|
|
truePrinter :: Printer
|
|
truePrinter = "(1=1)"
|
|
|
|
falsePrinter :: Printer
|
|
falsePrinter = "(1<>1)"
|
|
|
|
parens :: Printer -> Printer
|
|
parens p = "(" <+> IndentPrinter 1 p <+> ")"
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- * Basic printing API
|
|
|
|
-- | Pretty-prints a 'Printer' as one line, converting 'NewlinePrinter' to space.
|
|
toQueryFlat :: Printer -> Query
|
|
toQueryFlat = go 0
|
|
where
|
|
go level =
|
|
\case
|
|
QueryPrinter q -> q
|
|
SeqPrinter xs -> mconcat (filter notEmpty (map (go level) xs))
|
|
SepByPrinter x xs ->
|
|
mconcat
|
|
(intersperse (go level x) (filter notEmpty (map (go level) xs)))
|
|
NewlinePrinter -> " "
|
|
IndentPrinter n p -> go (level + n) p
|
|
notEmpty = (/= mempty) . renderQuery
|
|
|
|
-- | Pretty-prints a 'Printer' as multiple lines as defined by the printer.
|
|
toQueryPretty :: Printer -> Query
|
|
toQueryPretty = go 0
|
|
where
|
|
go level =
|
|
\case
|
|
QueryPrinter q -> q
|
|
SeqPrinter xs -> mconcat (filter notEmpty (map (go level) xs))
|
|
SepByPrinter x xs ->
|
|
mconcat
|
|
(intersperse (go level x) (filter notEmpty (map (go level) xs)))
|
|
NewlinePrinter -> "\n" <> indentation level
|
|
IndentPrinter n p -> go (level + n) p
|
|
indentation n = rawUnescapedText (T.replicate n " ")
|
|
notEmpty = (/= mempty) . renderQuery
|