graphql-engine/server/src-lib/Hasura/Backends/Postgres/DDL/BoolExp.hs

-- | Postgres DDL BoolExp
--
-- How to parse the boolean expressions, specifically for Postgres.
--
-- See 'Hasura.RQL.DDL.Schema.Cache' and 'Hasura.RQL.Types.Eventing.Backend'.
module Hasura.Backends.Postgres.DDL.BoolExp
  ( parseBoolExpOperations,
  )
where

import Data.Aeson
import Data.HashMap.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Backends.Postgres.SQL.Types
import Hasura.Backends.Postgres.Types.BoolExp
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.RQL.IR.BoolExp
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.Table
import Hasura.SQL.Backend
import Hasura.SQL.Types

parseBoolExpOperations ::
  forall pgKind m v.
  ( Backend ('Postgres pgKind),
    MonadError QErr m,
    TableCoreInfoRM ('Postgres pgKind) m
  ) =>
  ValueParser ('Postgres pgKind) m v ->
  QualifiedTable ->
  FieldInfoMap (FieldInfo ('Postgres pgKind)) ->
  ColumnReference ('Postgres pgKind) ->
  Value ->
  m [OpExpG ('Postgres pgKind) v]
parseBoolExpOperations rhsParser rootTable fim columnRef value = do
  restrictJSONColumn
  withPathK (toTxt columnRef) $ parseOperations columnRef value
  where
    restrictJSONColumn :: m ()
    restrictJSONColumn = case columnReferenceType columnRef of
      ColumnScalar PGJSON ->
        throwError (err400 UnexpectedPayload "JSON column can not be part of boolean expression")
      _ -> pure ()

    parseOperations :: ColumnReference ('Postgres pgKind) -> Value -> m [OpExpG ('Postgres pgKind) v]
    parseOperations column = \case
      Object o -> mapM (parseOperation column) (Map.toList o)
      val -> pure . AEQ False <$> rhsParser columnType val
      where
        columnType = CollectableTypeScalar $ columnReferenceType column

    parseOperation :: ColumnReference ('Postgres pgKind) -> (Text, Value) -> m (OpExpG ('Postgres pgKind) v)
    parseOperation column (opStr, val) = withPathK opStr $
      case opStr of
        "$cast" -> parseCast
        "_cast" -> parseCast
        "$eq" -> parseEq
        "_eq" -> parseEq
        "$ne" -> parseNe
        "_ne" -> parseNe
        "$neq" -> parseNe
        "_neq" -> parseNe
        "$in" -> parseIn
        "_in" -> parseIn
        "$nin" -> parseNin
        "_nin" -> parseNin
        "$gt" -> parseGt
        "_gt" -> parseGt
        "$lt" -> parseLt
        "_lt" -> parseLt
        "$gte" -> parseGte
        "_gte" -> parseGte
        "$lte" -> parseLte
        "_lte" -> parseLte
        "$like" -> parseLike
        "_like" -> parseLike
        "$nlike" -> parseNlike
        "_nlike" -> parseNlike
        "$ilike" -> parseIlike
        "_ilike" -> parseIlike
        "$nilike" -> parseNilike
        "_nilike" -> parseNilike
        "$similar" -> parseSimilar
        "_similar" -> parseSimilar
        "$nsimilar" -> parseNsimilar
        "_nsimilar" -> parseNsimilar
        "$regex" -> parseRegex
        "_regex" -> parseRegex
        "$iregex" -> parseIRegex
        "_iregex" -> parseIRegex
        "$nregex" -> parseNRegex
        "_nregex" -> parseNRegex
        "$niregex" -> parseNIRegex
        "_niregex" -> parseNIRegex
        "$is_null" -> parseIsNull
        "_is_null" -> parseIsNull
        -- jsonb type
        "_contains" -> guardType [PGJSONB] >> ABackendSpecific . AContains <$> parseOne
        "$contains" -> guardType [PGJSONB] >> ABackendSpecific . AContains <$> parseOne
        "_contained_in" -> guardType [PGJSONB] >> ABackendSpecific . AContainedIn <$> parseOne
        "$contained_in" -> guardType [PGJSONB] >> ABackendSpecific . AContainedIn <$> parseOne
        "_has_key" -> guardType [PGJSONB] >> ABackendSpecific . AHasKey <$> parseWithTy (ColumnScalar PGText)
        "$has_key" -> guardType [PGJSONB] >> ABackendSpecific . AHasKey <$> parseWithTy (ColumnScalar PGText)
        "_has_keys_any" -> guardType [PGJSONB] >> ABackendSpecific . AHasKeysAny <$> parseManyWithType (ColumnScalar PGText)
        "$has_keys_any" -> guardType [PGJSONB] >> ABackendSpecific . AHasKeysAny <$> parseManyWithType (ColumnScalar PGText)
        "_has_keys_all" -> guardType [PGJSONB] >> ABackendSpecific . AHasKeysAll <$> parseManyWithType (ColumnScalar PGText)
        "$has_keys_all" -> guardType [PGJSONB] >> ABackendSpecific . AHasKeysAll <$> parseManyWithType (ColumnScalar PGText)
        -- geometry types
        "_st_contains" -> parseGeometryOp ASTContains
        "$st_contains" -> parseGeometryOp ASTContains
        "_st_crosses" -> parseGeometryOp ASTCrosses
        "$st_crosses" -> parseGeometryOp ASTCrosses
        "_st_equals" -> parseGeometryOp ASTEquals
        "$st_equals" -> parseGeometryOp ASTEquals
        "_st_overlaps" -> parseGeometryOp ASTOverlaps
        "$st_overlaps" -> parseGeometryOp ASTOverlaps
        "_st_touches" -> parseGeometryOp ASTTouches
        "$st_touches" -> parseGeometryOp ASTTouches
        "_st_within" -> parseGeometryOp ASTWithin
        "$st_within" -> parseGeometryOp ASTWithin
        -- geometry and geography types
        "_st_intersects" -> parseGeometryOrGeographyOp ASTIntersects
        "$st_intersects" -> parseGeometryOrGeographyOp ASTIntersects
        "_st_3d_intersects" -> parseGeometryOp AST3DIntersects
        "$st_3d_intersects" -> parseGeometryOp AST3DIntersects
        "_st_d_within" -> parseSTDWithinObj
        "$st_d_within" -> parseSTDWithinObj
        "_st_3d_d_within" -> parseST3DDWithinObj
        "$st_3d_d_within" -> parseST3DDWithinObj
        "$ceq" -> parseCeq
        "_ceq" -> parseCeq
        "$cne" -> parseCne
        "_cne" -> parseCne
        "$cneq" -> parseCne
        "_cneq" -> parseCne
        "$cgt" -> parseCgt
        "_cgt" -> parseCgt
        "$clt" -> parseClt
        "_clt" -> parseClt
        "$cgte" -> parseCgte
        "_cgte" -> parseCgte
        "$clte" -> parseClte
        "_clte" -> parseClte
        -- ltree types
        "_ancestor" -> guardType [PGLtree] >> ABackendSpecific . AAncestor <$> parseOne
        "$ancestor" -> guardType [PGLtree] >> ABackendSpecific . AAncestor <$> parseOne
        "_ancestor_any" -> guardType [PGLtree] >> ABackendSpecific . AAncestorAny <$> parseManyWithType (ColumnScalar PGLtree)
        "$ancestor_any" -> guardType [PGLtree] >> ABackendSpecific . AAncestorAny <$> parseManyWithType (ColumnScalar PGLtree)
        "_descendant" -> guardType [PGLtree] >> ABackendSpecific . ADescendant <$> parseOne
        "$descendant" -> guardType [PGLtree] >> ABackendSpecific . ADescendant <$> parseOne
        "_descendant_any" -> guardType [PGLtree] >> ABackendSpecific . ADescendantAny <$> parseManyWithType (ColumnScalar PGLtree)
        "$descendant_any" -> guardType [PGLtree] >> ABackendSpecific . ADescendantAny <$> parseManyWithType (ColumnScalar PGLtree)
        "_matches" -> guardType [PGLtree] >> ABackendSpecific . AMatches <$> parseWithTy (ColumnScalar PGLquery)
        "$matches" -> guardType [PGLtree] >> ABackendSpecific . AMatches <$> parseWithTy (ColumnScalar PGLquery)
        "_matches_any" -> guardType [PGLtree] >> ABackendSpecific . AMatchesAny <$> parseManyWithType (ColumnScalar PGLquery)
        "$matches_any" -> guardType [PGLtree] >> ABackendSpecific . AMatchesAny <$> parseManyWithType (ColumnScalar PGLquery)
        "_matches_fulltext" -> guardType [PGLtree] >> ABackendSpecific . AMatchesFulltext <$> parseWithTy (ColumnScalar PGLtxtquery)
        "$matches_fulltext" -> guardType [PGLtree] >> ABackendSpecific . AMatchesFulltext <$> parseWithTy (ColumnScalar PGLtxtquery)
        x -> throw400 UnexpectedPayload $ "Unknown operator : " <> x
      where
        colTy = columnReferenceType column

        parseIsNull = bool ANISNOTNULL ANISNULL <$> parseVal -- is null
        parseEq = AEQ False <$> parseOne -- equals
        parseNe = ANE False <$> parseOne -- <>
        parseIn = AIN <$> parseManyWithType colTy -- in an array
        parseNin = ANIN <$> parseManyWithType colTy -- not in an array
        parseGt = AGT <$> parseOne -- >
        parseLt = ALT <$> parseOne -- <
        parseGte = AGTE <$> parseOne -- >=
        parseLte = ALTE <$> parseOne -- <=
        parseCeq = CEQ <$> decodeAndValidateRhsCol val
        parseCne = CNE <$> decodeAndValidateRhsCol val
        parseCgt = CGT <$> decodeAndValidateRhsCol val
        parseClt = CLT <$> decodeAndValidateRhsCol val
        parseCgte = CGTE <$> decodeAndValidateRhsCol val
        parseClte = CLTE <$> decodeAndValidateRhsCol val

        parseLike = guardType stringTypes >> ALIKE <$> parseOne
        parseNlike = guardType stringTypes >> ANLIKE <$> parseOne
        parseIlike = guardType stringTypes >> ABackendSpecific . AILIKE <$> parseOne
        parseNilike = guardType stringTypes >> ABackendSpecific . ANILIKE <$> parseOne

        parseRegex = guardType stringTypes >> ABackendSpecific . AREGEX <$> parseOne
        parseIRegex = guardType stringTypes >> ABackendSpecific . AIREGEX <$> parseOne
        parseNRegex = guardType stringTypes >> ABackendSpecific . ANREGEX <$> parseOne
        parseNIRegex = guardType stringTypes >> ABackendSpecific . ANIREGEX <$> parseOne
        parseSimilar = guardType stringTypes >> ABackendSpecific . ASIMILAR <$> parseOne
        parseNsimilar = guardType stringTypes >> ABackendSpecific . ANSIMILAR <$> parseOne

        parseCast = do
          castOperations <- parseVal
          parsedCastOperations <-
            forM (Map.toList castOperations) $ \(targetTypeName, castedComparisons) -> do
              let targetType = textToPGScalarType targetTypeName
                  castedColumn = ColumnReferenceCast column (ColumnScalar targetType)
              checkValidCast targetType
              parsedCastedComparisons <-
                withPathK targetTypeName $
                  parseOperations castedColumn castedComparisons
              return (targetType, parsedCastedComparisons)
          return . ACast $ Map.fromList parsedCastOperations

        checkValidCast targetType = case (colTy, targetType) of
          (ColumnScalar PGGeometry, PGGeography) -> return ()
          (ColumnScalar PGGeography, PGGeometry) -> return ()
          (ColumnScalar PGJSONB, PGText) -> return ()
          _ ->
            throw400 UnexpectedPayload $
              "cannot cast column of type " <> colTy <<> " to type " <>> targetType

        parseGeometryOp f =
          guardType [PGGeometry] >> ABackendSpecific . f <$> parseOneNoSess colTy val
        parseGeometryOrGeographyOp f =
          guardType geoTypes >> ABackendSpecific . f <$> parseOneNoSess colTy val

        parseSTDWithinObj =
          ABackendSpecific <$> case colTy of
            ColumnScalar PGGeometry -> do
              DWithinGeomOp distVal fromVal <- parseVal
              dist <- withPathK "distance" $ parseOneNoSess (ColumnScalar PGFloat) distVal
              from <- withPathK "from" $ parseOneNoSess colTy fromVal
              return $ ASTDWithinGeom $ DWithinGeomOp dist from
            ColumnScalar PGGeography -> do
              DWithinGeogOp distVal fromVal sphVal <- parseVal
              dist <- withPathK "distance" $ parseOneNoSess (ColumnScalar PGFloat) distVal
              from <- withPathK "from" $ parseOneNoSess colTy fromVal
              useSpheroid <- withPathK "use_spheroid" $ parseOneNoSess (ColumnScalar PGBoolean) sphVal
              return $ ASTDWithinGeog $ DWithinGeogOp dist from useSpheroid
            _ -> throwError $ buildMsg colTy [PGGeometry, PGGeography]

        decodeAndValidateRhsCol :: Value -> m (RootOrCurrentColumn ('Postgres pgKind))
        decodeAndValidateRhsCol v = case v of
          String _ -> go IsCurrent fim v
          Array path -> case toList path of
            [] -> throw400 Unexpected "path cannot be empty"
            [col] -> go IsCurrent fim col
            [String "$", col] -> do
              rootTableInfo <-
                lookupTableCoreInfo rootTable
                  >>= flip onNothing (throw500 $ "unexpected: " <> rootTable <<> " doesn't exist")
              go IsRoot (_tciFieldInfoMap rootTableInfo) col
            _ -> throw400 NotSupported "Relationship references are not supported in column comparison RHS"
          _ -> throw400 Unexpected "a boolean expression JSON must be either a string or an array"
          where
            go rootInfo fieldsInfoMap columnValue = do
              colName <- decodeValue columnValue
              colInfo <- validateRhsCol fieldsInfoMap colName
              pure $ RootOrCurrentColumn rootInfo colInfo

        parseST3DDWithinObj =
          ABackendSpecific <$> do
            guardType [PGGeometry]
            DWithinGeomOp distVal fromVal <- parseVal
            dist <- withPathK "distance" $ parseOneNoSess (ColumnScalar PGFloat) distVal
            from <- withPathK "from" $ parseOneNoSess colTy fromVal
            return $ AST3DDWithinGeom $ DWithinGeomOp dist from

        validateRhsCol fieldInfoMap rhsCol = do
          rhsType <- askColumnType fieldInfoMap rhsCol "column operators can only compare postgres columns"
          when (colTy /= rhsType) $
            throw400 UnexpectedPayload $
              "incompatible column types: "
                <> column <<> " has type "
                <> colTy <<> ", but "
                <> rhsCol <<> " has type " <>> rhsType
          pure rhsCol

        parseWithTy ty = rhsParser (CollectableTypeScalar ty) val

        -- parse one with the column's type
        parseOne = parseWithTy colTy
        parseOneNoSess ty = rhsParser (CollectableTypeScalar ty)

        parseManyWithType ty = rhsParser (CollectableTypeArray ty) val

        guardType validTys =
          unless (isScalarColumnWhere (`elem` validTys) colTy) $
            throwError $ buildMsg colTy validTys
        buildMsg ty expTys =
          err400 UnexpectedPayload $
            " is of type " <> ty <<> "; this operator works only on columns of type "
              <> T.intercalate "/" (map dquote expTys)

        parseVal :: (FromJSON a) => m a
        parseVal = decodeValue val