mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 18:42:30 +03:00
319 lines
9.9 KiB
Haskell
319 lines
9.9 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
|
|
module Hasura.RQL.GBoolExp
|
|
( toSQLBoolExp
|
|
, getBoolExpDeps
|
|
, annBoolExp
|
|
, txtRHSBuilder
|
|
, pgValParser
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types
|
|
import Hasura.SQL.Types
|
|
import Hasura.SQL.Value
|
|
|
|
import qualified Hasura.SQL.DML as S
|
|
|
|
import Data.Aeson
|
|
|
|
import qualified Data.HashMap.Strict as M
|
|
import qualified Data.Text.Extended as T
|
|
|
|
parseOpExp
|
|
:: (MonadError QErr m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> PGColInfo
|
|
-> (T.Text, Value) -> m (OpExpG a)
|
|
parseOpExp parser fim (PGColInfo cn colTy _) (opStr, val) = case opStr of
|
|
"$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
|
|
|
|
"$is_null" -> parseIsNull
|
|
"_is_null" -> parseIsNull
|
|
|
|
"$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
|
|
|
|
x -> throw400 UnexpectedPayload $ "Unknown operator : " <> x
|
|
where
|
|
parseEq = AEQ <$> parseOne -- equals
|
|
parseNe = ANE <$> parseOne -- <>
|
|
parseIn = AIN <$> parseMany -- in an array
|
|
parseNin = ANIN <$> parseMany -- not in an array
|
|
parseGt = AGT <$> parseOne -- >
|
|
parseLt = ALT <$> parseOne -- <
|
|
parseGte = AGTE <$> parseOne -- >=
|
|
parseLte = ALTE <$> parseOne -- <=
|
|
parseLike = textOnlyOp colTy >> ALIKE <$> parseOne
|
|
parseNlike = textOnlyOp colTy >> ANLIKE <$> parseOne
|
|
parseIlike = textOnlyOp colTy >> AILIKE <$> parseOne
|
|
parseNilike = textOnlyOp colTy >> ANILIKE <$> parseOne
|
|
parseSimilar = textOnlyOp colTy >> ASIMILAR <$> parseOne
|
|
parseNsimilar = textOnlyOp colTy >> ANSIMILAR <$> parseOne
|
|
|
|
parseIsNull = bool ANISNOTNULL ANISNULL -- is null
|
|
<$> decodeValue val
|
|
parseCeq = CEQ <$> decodeAndValidateRhsCol
|
|
parseCne = CNE <$> decodeAndValidateRhsCol
|
|
parseCgt = CGT <$> decodeAndValidateRhsCol
|
|
parseClt = CLT <$> decodeAndValidateRhsCol
|
|
parseCgte = CGTE <$> decodeAndValidateRhsCol
|
|
parseClte = CLTE <$> decodeAndValidateRhsCol
|
|
|
|
decodeAndValidateRhsCol =
|
|
decodeValue val >>= validateRhsCol
|
|
|
|
validateRhsCol rhsCol = do
|
|
let errMsg = "column operators can only compare postgres columns"
|
|
rhsType <- askPGType fim rhsCol errMsg
|
|
if colTy /= rhsType
|
|
then throw400 UnexpectedPayload $
|
|
"incompatible column types : " <> cn <<> ", " <>> rhsCol
|
|
else return rhsCol
|
|
|
|
parseOne = parser colTy val
|
|
parseMany = do
|
|
vals <- runAesonParser parseJSON val
|
|
indexedForM vals (parser colTy)
|
|
|
|
parseOpExps
|
|
:: (MonadError QErr m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> PGColInfo
|
|
-> Value
|
|
-> m [OpExpG a]
|
|
parseOpExps valParser cim colInfo = \case
|
|
(Object o) -> mapM (parseOpExp valParser cim colInfo)(M.toList o)
|
|
val -> pure . AEQ <$> valParser (pgiType colInfo) val
|
|
|
|
type ValueParser m a = PGColType -> Value -> m a
|
|
|
|
buildMsg :: PGColType -> [PGColType] -> QErr
|
|
buildMsg ty expTys =
|
|
err400 UnexpectedPayload $ mconcat
|
|
[ " is of type " <> T.pack (show ty)
|
|
, "; this operator works "
|
|
, "only on columns of type "
|
|
, T.intercalate "/" $ map (T.dquote . T.pack . show) expTys
|
|
]
|
|
|
|
textOnlyOp :: (MonadError QErr m) => PGColType -> m ()
|
|
textOnlyOp PGText = return ()
|
|
textOnlyOp PGVarchar = return ()
|
|
textOnlyOp ty =
|
|
throwError $ buildMsg ty [PGVarchar, PGText]
|
|
|
|
-- This convoluted expression instead of col = val
|
|
-- to handle the case of col : null
|
|
equalsBoolExpBuilder :: S.SQLExp -> S.SQLExp -> S.BoolExp
|
|
equalsBoolExpBuilder qualColExp rhsExp =
|
|
S.BEBin S.OrOp (S.BECompare S.SEQ qualColExp rhsExp)
|
|
(S.BEBin S.AndOp
|
|
(S.BENull qualColExp)
|
|
(S.BENull rhsExp))
|
|
|
|
notEqualsBoolExpBuilder :: S.SQLExp -> S.SQLExp -> S.BoolExp
|
|
notEqualsBoolExpBuilder qualColExp rhsExp =
|
|
S.BEBin S.OrOp (S.BECompare S.SNE qualColExp rhsExp)
|
|
(S.BEBin S.AndOp
|
|
(S.BENotNull qualColExp)
|
|
(S.BENull rhsExp))
|
|
|
|
annBoolExp
|
|
:: (QErrM m, CacheRM m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> BoolExp
|
|
-> m (AnnBoolExp a)
|
|
annBoolExp valParser fim (BoolExp boolExp) =
|
|
traverse (annColExp valParser fim) boolExp
|
|
|
|
annColExp
|
|
:: (QErrM m, CacheRM m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> ColExp
|
|
-> m (AnnBoolExpFld a)
|
|
annColExp valueParser colInfoMap (ColExp fieldName colVal) = do
|
|
colInfo <- askFieldInfo colInfoMap fieldName
|
|
case colInfo of
|
|
FIColumn (PGColInfo _ PGJSON _) ->
|
|
throwError (err400 UnexpectedPayload "JSON column can not be part of where clause")
|
|
FIColumn (PGColInfo _ PGJSONB _) ->
|
|
throwError (err400 UnexpectedPayload "JSONB column can not be part of where clause")
|
|
FIColumn pgi ->
|
|
AVCol pgi <$> parseOpExps valueParser colInfoMap pgi colVal
|
|
FIRelationship relInfo -> do
|
|
relBoolExp <- decodeValue colVal
|
|
relFieldInfoMap <- askFieldInfoMap $ riRTable relInfo
|
|
annRelBoolExp <- annBoolExp valueParser relFieldInfoMap relBoolExp
|
|
return $ AVRel relInfo annRelBoolExp
|
|
|
|
toSQLBoolExp
|
|
:: S.Qual -> AnnBoolExpSQL -> S.BoolExp
|
|
toSQLBoolExp tq e =
|
|
evalState (convBoolRhs' tq e) 0
|
|
|
|
convBoolRhs'
|
|
:: S.Qual -> AnnBoolExpSQL -> State Word64 S.BoolExp
|
|
convBoolRhs' tq =
|
|
foldBoolExp (convColRhs tq)
|
|
|
|
convColRhs
|
|
:: S.Qual -> AnnBoolExpFldSQL -> State Word64 S.BoolExp
|
|
convColRhs tableQual = \case
|
|
AVCol (PGColInfo cn _ _) opExps -> do
|
|
let bExps = map (mkColCompExp tableQual cn) opExps
|
|
return $ foldr (S.BEBin S.AndOp) (S.BELit True) bExps
|
|
|
|
AVRel (RelInfo _ _ colMapping relTN _) nesAnn -> do
|
|
-- Convert the where clause on the relationship
|
|
curVarNum <- get
|
|
put $ curVarNum + 1
|
|
let newIden = Iden $ "_be_" <> T.pack (show curVarNum) <> "_"
|
|
<> snakeCaseTable relTN
|
|
newIdenQ = S.QualIden newIden
|
|
annRelBoolExp <- convBoolRhs' newIdenQ nesAnn
|
|
let backCompExp = foldr (S.BEBin S.AndOp) (S.BELit True) $
|
|
flip map colMapping $ \(lCol, rCol) ->
|
|
S.BECompare S.SEQ
|
|
(mkQCol (S.QualIden newIden) rCol)
|
|
(mkQCol tableQual lCol)
|
|
innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp
|
|
return $ S.mkExists (S.FISimple relTN $ Just $ S.Alias newIden) innerBoolExp
|
|
where
|
|
mkQCol q = S.SEQIden . S.QIden q . toIden
|
|
|
|
pgValParser
|
|
:: (MonadError QErr m)
|
|
=> PGColType -> Value -> m PGColValue
|
|
pgValParser ty =
|
|
runAesonParser (parsePGValue ty)
|
|
|
|
txtRHSBuilder
|
|
:: (MonadError QErr m)
|
|
=> PGColType -> Value -> m S.SQLExp
|
|
txtRHSBuilder ty val =
|
|
txtEncoder <$> pgValParser ty val
|
|
|
|
mkColCompExp
|
|
:: S.Qual -> PGCol -> OpExpG S.SQLExp -> S.BoolExp
|
|
mkColCompExp qual lhsCol = \case
|
|
AEQ val -> equalsBoolExpBuilder lhs val
|
|
ANE val -> notEqualsBoolExpBuilder lhs val
|
|
AIN vals -> handleEmptyAny vals
|
|
ANIN vals -> S.BENot $ handleEmptyAny vals
|
|
AGT val -> S.BECompare S.SGT lhs val
|
|
ALT val -> S.BECompare S.SLT lhs val
|
|
AGTE val -> S.BECompare S.SGTE lhs val
|
|
ALTE val -> S.BECompare S.SLTE lhs val
|
|
ALIKE val -> S.BECompare S.SLIKE lhs val
|
|
ANLIKE val -> S.BECompare S.SNLIKE lhs val
|
|
AILIKE val -> S.BECompare S.SILIKE lhs val
|
|
ANILIKE val -> S.BECompare S.SNILIKE lhs val
|
|
ASIMILAR val -> S.BECompare S.SSIMILAR lhs val
|
|
ANSIMILAR val -> S.BECompare S.SNSIMILAR lhs val
|
|
AContains val -> S.BECompare S.SContains lhs val
|
|
AContainedIn val -> S.BECompare S.SContainedIn lhs val
|
|
AHasKey val -> S.BECompare S.SHasKey lhs val
|
|
AHasKeysAny keys -> S.BECompare S.SHasKeysAny lhs $ toTextArray keys
|
|
AHasKeysAll keys -> S.BECompare S.SHasKeysAll lhs $ toTextArray keys
|
|
ANISNULL -> S.BENull lhs
|
|
ANISNOTNULL -> S.BENotNull lhs
|
|
CEQ rhsCol -> S.BECompare S.SEQ lhs $ mkQCol rhsCol
|
|
CNE rhsCol -> S.BECompare S.SNE lhs $ mkQCol rhsCol
|
|
CGT rhsCol -> S.BECompare S.SGT lhs $ mkQCol rhsCol
|
|
CLT rhsCol -> S.BECompare S.SLT lhs $ mkQCol rhsCol
|
|
CGTE rhsCol -> S.BECompare S.SGTE lhs $ mkQCol rhsCol
|
|
CLTE rhsCol -> S.BECompare S.SLTE lhs $ mkQCol rhsCol
|
|
where
|
|
mkQCol = S.SEQIden . S.QIden qual . toIden
|
|
lhs = mkQCol lhsCol
|
|
|
|
toTextArray arr =
|
|
S.SETyAnn (S.SEArray $ map (txtEncoder . PGValText) arr) S.textArrType
|
|
|
|
handleEmptyAny [] = S.BELit False
|
|
handleEmptyAny vals = S.BEEqualsAny lhs vals
|
|
|
|
getColExpDeps :: QualifiedTable -> AnnBoolExpFld a -> [SchemaDependency]
|
|
getColExpDeps tn = \case
|
|
AVCol colInfo _ ->
|
|
let cn = pgiName colInfo
|
|
in [SchemaDependency (SOTableObj tn (TOCol cn)) "on_type"]
|
|
AVRel relInfo relBoolExp ->
|
|
let rn = riName relInfo
|
|
relTN = riRTable relInfo
|
|
pd = SchemaDependency (SOTableObj tn (TORel rn)) "on_type"
|
|
in pd : getBoolExpDeps relTN relBoolExp
|
|
|
|
getBoolExpDeps :: QualifiedTable -> AnnBoolExp a -> [SchemaDependency]
|
|
getBoolExpDeps tn =
|
|
foldr (\annFld deps -> getColExpDeps tn annFld <> deps) []
|