graphql-engine/server/src-lib/Hasura/Backends/Postgres/DDL/BoolExp.hs
Brandon Simmons 6e8da71ece server: migrate to aeson-2 in preparation for ghc 9.2 upgrade
(Work here originally done by awjchen, rebased and fixed up for merge by
jberryman)

This is part of a merge train towards GHC 9.2 compatibility. The main
issue is the use of the new abstract `KeyMap` in 2.0. See:
https://hackage.haskell.org/package/aeson-2.0.3.0/changelog

Alex's original work is here:
#4305

BEHAVIOR CHANGE NOTE: This change causes a different arbitrary ordering
of serialized Json, for example during metadata export. CLI users care
about this in particular, and so we need to call it out as a _behavior
change_ as we did in v2.5.0. The good news though is that after this
change ordering should be more stable (alphabetical key order).

See: https://hasurahq.slack.com/archives/C01M20G1YRW/p1654012632634389

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4611
Co-authored-by: awjchen <13142944+awjchen@users.noreply.github.com>
GitOrigin-RevId: 700265162c782739b2bb88300ee3cda3819b2e87
2022-06-08 15:32:27 +00:00

347 lines
16 KiB
Haskell

-- | 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,
buildComputedFieldBooleanExp,
)
where
import Data.Aeson
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.HashMap.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Backends.Postgres.SQL.Types hiding (TableName)
import Hasura.Backends.Postgres.Types.BoolExp
import Hasura.Backends.Postgres.Types.ComputedField as PG
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.RQL.IR.BoolExp
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BoolExp
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.ComputedField
import Hasura.RQL.Types.Function
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 . first K.toText) (KM.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 ()
(ColumnScalar PGSmallInt, PGText) -> return ()
(ColumnScalar PGInteger, PGText) -> return ()
(ColumnScalar PGBigInt, PGText) -> return ()
(ColumnScalar PGFloat, PGText) -> return ()
(ColumnScalar PGDouble, PGText) -> return ()
(ColumnScalar PGNumeric, PGText) -> return ()
(ColumnScalar PGMoney, PGText) -> return ()
(ColumnScalar PGBoolean, PGText) -> return ()
(ColumnScalar PGChar, PGText) -> return ()
(ColumnScalar PGDate, PGText) -> return ()
(ColumnScalar PGTimeStamp, PGText) -> return ()
(ColumnScalar PGTimeStampTZ, PGText) -> return ()
(ColumnScalar PGTimeTZ, PGText) -> return ()
(ColumnScalar PGJSON, PGText) -> return ()
(ColumnScalar PGUUID, 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
buildComputedFieldBooleanExp ::
forall pgKind m v.
( MonadError QErr m,
Backend ('Postgres pgKind),
TableCoreInfoRM ('Postgres pgKind) m
) =>
BoolExpResolver ('Postgres pgKind) m v ->
BoolExpRHSParser ('Postgres pgKind) m v ->
TableName ('Postgres pgKind) ->
FieldInfoMap (FieldInfo ('Postgres pgKind)) ->
ComputedFieldInfo ('Postgres pgKind) ->
Value ->
m (AnnComputedFieldBoolExp ('Postgres pgKind) v)
buildComputedFieldBooleanExp boolExpResolver rhsParser rootTable colInfoMap ComputedFieldInfo {..} colVal = do
let ComputedFieldFunction {..} = _cfiFunction
case toList _cffInputArgs of
[] -> do
let hasuraSession = _berpSessionValue rhsParser
computedFieldFunctionArgs = flip FunctionArgsExp mempty $ PG.fromComputedFieldImplicitArguments hasuraSession _cffComputedFieldImplicitArgs
AnnComputedFieldBoolExp _cfiXComputedFieldInfo _cfiName _cffName computedFieldFunctionArgs
<$> case _cfiReturnType of
CFRScalar scalarType ->
CFBEScalar
<$> parseBoolExpOperations (_berpValueParser rhsParser) rootTable colInfoMap (ColumnReferenceComputedField _cfiName scalarType) colVal
CFRSetofTable table -> do
tableBoolExp <- decodeValue colVal
tableFieldInfoMap <- askFieldInfoMapSource table
annTableBoolExp <- (getBoolExpResolver boolExpResolver) rhsParser table tableFieldInfoMap $ unBoolExp tableBoolExp
pure $ CFBETable table annTableBoolExp
_ ->
throw400
UnexpectedPayload
"Computed columns with input arguments can not be part of the where clause"