graphql-engine/server/src-lib/Hasura/Backends/MySQL/ToQuery.hs

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

-- | Convert the simple AST to an SQL query, ready to be passed
-- to the mysql package's query/exec functions.

module Hasura.Backends.MySQL.ToQuery
  ( Printer
  , toQueryPretty
  , fromSelect
  , toQueryFlat
  , Query(..)
  )
where

import           Data.ByteString             (ByteString)
import           Data.List                   (intersperse)
import           Data.String
import qualified Data.Text                   as T
import           Hasura.Backends.MySQL.Types
import           Hasura.Prelude              hiding (GT, LT)

newtype Query = Query { unQuery :: ByteString } deriving (Show, Eq, Monoid, Semigroup)

data Printer
  = SeqPrinter [Printer]
  | SepByPrinter Printer [Printer]
  | NewlinePrinter
  | QueryPrinter Query
  | IndentPrinter Int Printer
  deriving (Show, Eq)

instance IsString Printer where
  fromString = QueryPrinter . Query . fromString

(<+>) :: Printer -> Printer -> Printer
(<+>) x y = SeqPrinter [x,y]

(<+>?) :: Printer -> Maybe Printer -> Printer
(<+>?) x Nothing  = x
(<+>?) x (Just y) = SeqPrinter [x,y]


-- Printer generators

fromExpression :: Expression -> Printer
fromExpression =
  \case
    ValueExpression value -> QueryPrinter (fromScalarType value)
    AndExpression xs ->
      case xs of
        [] -> ""
        _ ->
          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 <+> ")"
    ColumnExpression fieldName -> fromFieldName fieldName
    MethodExpression field method args ->
      fromExpression field <+> "." <+>
      fromString (T.unpack method) <+>
      "(" <+> SeqPrinter (map fromExpression args) <+> ")"
    OpExpression op x y ->
      "(" <+>
      fromExpression x <+>
      ") " <+> fromOp op <+> " (" <+> fromExpression y <+> ")"

fromScalarType :: ScalarValue -> Query
fromScalarType (IntValue v) = Query $ fromString (show v)
fromScalarType other        = error $ "fromscalartype: not implemented " <> show other

fromOp :: Op -> Printer
fromOp =
  \case
    LT    -> "<"
    GT    -> ">"
    GTE   -> ">="
    LTE   -> "<="
    IN    -> "IN"
    NIN   -> "NOT IN"
    LIKE  -> "LIKE"
    NLIKE -> "NOT LIKE"
    EQ'   -> "="
    NEQ'  -> "!="

fromFieldName :: FieldName -> Printer
fromFieldName (FieldName {..}) =
  fromNameText fNameEntity <+> "." <+> fromNameText fName

fromSelect :: Select -> Printer
fromSelect Select {..} = wrapFor selectFor 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
      ]

fromJoinSource :: JoinSource -> Printer
fromJoinSource =
  \case
    JoinSelect sel        -> fromSelect sel
    JoinReselect reselect -> fromReselect reselect

fromReselect :: Reselect -> Printer
fromReselect Reselect {..} = wrapFor reselectFor result
  where
    result =
      SepByPrinter
        NewlinePrinter
        [ "SELECT " <+>
          IndentPrinter
            7
            (SepByPrinter
               ("," <+> NewlinePrinter)
               (map fromProjection (toList reselectProjections)))
        , fromWhere reselectWhere
        , fromFor reselectFor
        ]

-- https://dev.mysql.com/doc/refman/5.7/en/select.html
fromOffsetAndLimit :: Top -> Maybe Expression -> Printer
fromOffsetAndLimit NoTop Nothing = ""
fromOffsetAndLimit NoTop (Just offset) =
  SeqPrinter
    [ "LIMIT " <+> fromString (show (maxBound :: Int)),
      IndentPrinter 9 (SepByPrinter NewlinePrinter [" OFFSET " <+> fromExpression offset])
    ]
fromOffsetAndLimit (Top val) Nothing = SeqPrinter ["LIMIT " <+> fromString (show val)]
fromOffsetAndLimit (Top val) (Just offset) =
  SeqPrinter
    [ "LIMIT " <+> fromString (show val),
      IndentPrinter 9 (SepByPrinter NewlinePrinter [" OFFSET " <+> fromExpression offset])
    ]

fromOrderBys ::
     Top -> Maybe Expression -> Maybe (NonEmpty OrderBy) -> Printer
fromOrderBys top offset Nothing = fromOffsetAndLimit top offset
fromOrderBys _ moffset morderBys =
  SeqPrinter
    [ "ORDER BY "
    , IndentPrinter
        9
        (SepByPrinter
           NewlinePrinter
           [ case morderBys of
               Nothing -> ""
               Just orderBys ->
                 SepByPrinter
                   ("," <+> NewlinePrinter)
                   (concatMap fromOrderBy (toList orderBys))
           , case moffset of
               Nothing -> ""
               (Just offset) ->
                 "OFFSET " <+> fromExpression offset
           ])
    ]


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 = inner

fromOrder :: Order -> Printer
fromOrder =
  \case
    Asc  -> "ASC"
    Desc -> "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" <+>
      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 text args ->
      QueryPrinter (Query $ fromString $ show text) <+>
      "(" <+> SepByPrinter ", " (map fromExpression (toList args)) <+> ")"
    TextAggregate text -> fromExpression (ValueExpression (TextValue text))

fromCountable :: Countable FieldName -> Printer
fromCountable =
  \case
    StarCountable -> "*"
    NonNullFieldCountable fields ->
      SepByPrinter ", " (map fromFieldName (toList fields))
    DistinctCountable fields ->
      "DISTINCT " <+>
      SepByPrinter ", " (map fromFieldName (toList fields))

fromWhere :: Where -> Printer
fromWhere =
  \case
    Where [] -> ""
    Where expressions ->
      "WHERE " <+>
      IndentPrinter 6 (fromExpression (AndExpression expressions))

fromFrom :: From -> Printer
fromFrom =
  \case
    FromQualifiedTable aliasedQualifiedTableName ->
      fromAliased (fmap fromTableName aliasedQualifiedTableName)
    FromOpenJson openJson -> fromAliased (fmap fromOpenJson openJson)

fromOpenJson :: OpenJson -> Printer
fromOpenJson OpenJson {openJsonExpression, openJsonWith} =
  SepByPrinter
    NewlinePrinter
    [ "OPENJSON(" <+>
      IndentPrinter 9 (fromExpression openJsonExpression) <+> ")"
    , "WITH (" <+>
      IndentPrinter
        5
        (SepByPrinter
           ("," <+> NewlinePrinter)
           (toList (fmap fromJsonFieldSpec openJsonWith))) <+>
      ")"
    ]

fromJsonFieldSpec :: JsonFieldSpec -> Printer
fromJsonFieldSpec =
  \case
    IntField name mPath    -> fromNameText name <+> " INT" <+> quote mPath
    StringField name mPath -> fromNameText name <+> " NVARCHAR(MAX)" <+> quote mPath
    UuidField name mPath   -> fromNameText name <+> " UNIQUEIDENTIFIER" <+> quote mPath
    JsonField name mPath   -> fromJsonFieldSpec (StringField name mPath) <+> " AS JSON"
    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 {name, schema} =
  fromNameText schema <+> "." <+> fromNameText name

fromAliased :: Aliased Printer -> Printer
fromAliased Aliased {..} =
  aliasedThing <+>
  ((" AS " <+>) . fromNameText) aliasedAlias

fromNameText :: Text -> Printer
fromNameText t = QueryPrinter (Query . fromString . T.unpack $ t)

falsePrinter :: Printer
falsePrinter = "(1<>1)"

-- | Wrap a select with things needed when using FOR JSON.
wrapFor :: For -> Printer -> Printer
wrapFor for' inner = nullToArray
  where
    nullToArray =
      case for' of
        NoFor     -> rooted
        JsonFor _ -> rooted
    rooted =
      case for' of
        JsonFor ForJson {jsonRoot, jsonCardinality = JsonSingleton} ->
          case jsonRoot of
            NoRoot -> inner
            -- This is gross, but unfortunately ROOT and
            -- WITHOUT_ARRAY_WRAPPER are not allowed to be used at the
            -- same time (reason not specified). Therefore we just
            -- concatenate the necessary JSON string literals around
            -- the JSON.
            Root text ->
              SeqPrinter
                [ fromString ("SELECT CONCAT('{" <> show text <> ":', (")
                , inner
                , "), '}')"
                ]
        _ -> inner

--------------------------------------------------------------------------------
-- Basic printing API

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 -> Query " "
        IndentPrinter n p -> go (level + n) p
    notEmpty = (/= mempty)

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 -> Query $ fromString $ show $ "\n" <> indentation level
        IndentPrinter n p -> go (level + n) p
    indentation n = T.replicate n " "
    notEmpty = (/= mempty)