mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
492 lines
15 KiB
Haskell
492 lines
15 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
|
|
module Hasura.RQL.GBoolExp 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
|
|
|
|
data AnnValOpExpG a
|
|
= AEQ !a
|
|
| ANE !a
|
|
|
|
| AIN ![a]
|
|
| ANIN ![a]
|
|
|
|
| AGT !a
|
|
| ALT !a
|
|
| AGTE !a
|
|
| ALTE !a
|
|
|
|
| ALIKE !a -- LIKE
|
|
| ANLIKE !a -- NOT LIKE
|
|
|
|
| AILIKE !a -- ILIKE, case insensitive
|
|
| ANILIKE !a-- NOT ILIKE, case insensitive
|
|
|
|
| ASIMILAR !a -- similar, regex
|
|
| ANSIMILAR !a-- not similar, regex
|
|
|
|
| ANISNULL -- IS NULL
|
|
| ANISNOTNULL -- IS NOT NULL
|
|
|
|
deriving (Eq, Show)
|
|
|
|
data OpExpG a
|
|
= OEVal !(AnnValOpExpG a)
|
|
| OECol !ColOp !PGCol
|
|
deriving (Show, Eq)
|
|
|
|
type OpExpJ = OpExpG Value
|
|
type OpExp = OpExpG (PGColType, PGColValue)
|
|
|
|
data AnnValG a
|
|
= AVCol !PGColInfo !a
|
|
| AVRel !RelInfo !(GBoolExp (AnnValG a)) S.BoolExp
|
|
deriving (Show, Eq)
|
|
|
|
type AnnValS = AnnValG [OpExpG S.SQLExp]
|
|
type AnnValO a = AnnValG [OpExpG a]
|
|
type AnnVal = AnnValO (PGColType, PGColValue)
|
|
|
|
type AnnValJ = AnnValG [OpExpJ]
|
|
|
|
type AnnSQLBoolExp = AnnValG S.BoolExp
|
|
|
|
data ColOp
|
|
= CEQ
|
|
| CNE
|
|
| CGT
|
|
| CLT
|
|
| CGTE
|
|
| CLTE
|
|
deriving (Eq)
|
|
|
|
instance Show ColOp where
|
|
show CEQ = "$ceq"
|
|
show CNE = "$cne"
|
|
|
|
show CGT = "$cgt"
|
|
show CLT = "$clt"
|
|
show CGTE = "$cgte"
|
|
show CLTE = "$clte"
|
|
|
|
data RQLOp
|
|
= REQ -- equals
|
|
| RNE -- <>
|
|
|
|
| RIN -- in an array
|
|
| RNIN -- not in an array
|
|
|
|
| RGT -- >
|
|
| RLT -- <
|
|
| RGTE -- >=
|
|
| RLTE -- <=
|
|
|
|
| RLIKE -- LIKE
|
|
| RNLIKE -- NOT LIKE
|
|
|
|
| RILIKE -- ILIKE, case insensitive
|
|
| RNILIKE -- NOT ILIKE, case insensitive
|
|
|
|
| RSIMILAR -- similar, regex
|
|
| RNSIMILAR -- not similar, regex
|
|
|
|
deriving (Eq)
|
|
|
|
instance Show RQLOp where
|
|
show REQ = "$eq"
|
|
show RNE = "$ne"
|
|
|
|
show RIN = "$in"
|
|
show RNIN = "$nin"
|
|
|
|
show RGT = "$gt"
|
|
show RLT = "$lt"
|
|
show RGTE = "$gte"
|
|
show RLTE = "$lte"
|
|
|
|
show RLIKE = "$like"
|
|
show RNLIKE = "$nlike"
|
|
|
|
show RILIKE = "$ilike"
|
|
show RNILIKE = "$nilike"
|
|
|
|
show RSIMILAR = "$similar"
|
|
show RNSIMILAR = "$nsimilar"
|
|
|
|
instance DQuote RQLOp where
|
|
dquoteTxt op = T.pack $ show op
|
|
|
|
parseOp :: (MonadError QErr m) => T.Text -> m (Either RQLOp ColOp)
|
|
parseOp opStr = case opStr of
|
|
"$eq" -> return $ Left REQ
|
|
"_eq" -> return $ Left REQ
|
|
"$ne" -> return $ Left RNE
|
|
"_ne" -> return $ Left RNE
|
|
"$neq" -> return $ Left RNE
|
|
"_neq" -> return $ Left RNE
|
|
|
|
"$in" -> return $ Left RIN
|
|
"_in" -> return $ Left RIN
|
|
"$nin" -> return $ Left RNIN
|
|
"_nin" -> return $ Left RNIN
|
|
|
|
"$gt" -> return $ Left RGT
|
|
"_gt" -> return $ Left RGT
|
|
"$lt" -> return $ Left RLT
|
|
"_lt" -> return $ Left RLT
|
|
"$gte" -> return $ Left RGTE
|
|
"_gte" -> return $ Left RGTE
|
|
"$lte" -> return $ Left RLTE
|
|
"_lte" -> return $ Left RLTE
|
|
|
|
"$like" -> return $ Left RLIKE
|
|
"_like" -> return $ Left RLIKE
|
|
"$nlike" -> return $ Left RNLIKE
|
|
"_nlike" -> return $ Left RNLIKE
|
|
|
|
"$ilike" -> return $ Left RILIKE
|
|
"_ilike" -> return $ Left RILIKE
|
|
"$nilike" -> return $ Left RNILIKE
|
|
"_nilike" -> return $ Left RNILIKE
|
|
|
|
"$similar" -> return $ Left RSIMILAR
|
|
"_similar" -> return $ Left RSIMILAR
|
|
"$nsimilar" -> return $ Left RNSIMILAR
|
|
"_nsimilar" -> return $ Left RNSIMILAR
|
|
|
|
"$ceq" -> return $ Right CEQ
|
|
"_ceq" -> return $ Right CEQ
|
|
"$cne" -> return $ Right CNE
|
|
"_cne" -> return $ Right CNE
|
|
"$cneq" -> return $ Right CNE
|
|
"_cneq" -> return $ Right CNE
|
|
|
|
"$cgt" -> return $ Right CGT
|
|
"_cgt" -> return $ Right CGT
|
|
"$clt" -> return $ Right CLT
|
|
"_clt" -> return $ Right CLT
|
|
"$cgte" -> return $ Right CGTE
|
|
"_cgte" -> return $ Right CGTE
|
|
"$clte" -> return $ Right CLTE
|
|
"_clte" -> return $ Right CLTE
|
|
|
|
x -> throw400 UnexpectedPayload $ "Unknown operator : " <> x
|
|
|
|
isRQLOp :: T.Text -> Bool
|
|
isRQLOp t = case runIdentity . runExceptT $ parseOp t of
|
|
Left _ -> False
|
|
Right r -> either (const True) (const False) r
|
|
|
|
type ValueParser m a = PGColType -> Value -> m a
|
|
|
|
parseAnnOpExpG
|
|
:: (MonadError QErr m)
|
|
=> (PGColType -> Value -> m a)
|
|
-> RQLOp -> PGColType -> Value -> m (AnnValOpExpG a)
|
|
parseAnnOpExpG parser op ty val = case op of
|
|
REQ -> AEQ <$> parseOne -- equals
|
|
RNE -> ANE <$> parseOne -- <>
|
|
RIN -> AIN <$> parseMany -- in an array
|
|
RNIN -> ANIN <$> parseMany -- not in an array
|
|
RGT -> AGT <$> parseOne -- >
|
|
RLT -> ALT <$> parseOne -- <
|
|
RGTE -> AGTE <$> parseOne -- >=
|
|
RLTE -> ALTE <$> parseOne -- <=
|
|
RLIKE -> ALIKE <$> parseOne -- LIKE
|
|
RNLIKE -> ANLIKE <$> parseOne -- NOT LIKE
|
|
RILIKE -> AILIKE <$> parseOne -- ILIKE, case insensitive
|
|
RNILIKE -> ANILIKE <$> parseOne -- NOT ILIKE, case insensitive
|
|
RSIMILAR -> ASIMILAR <$> parseOne -- similar, regex
|
|
RNSIMILAR -> ANSIMILAR <$> parseOne -- not similar, regex
|
|
where
|
|
parseOne = parser ty val
|
|
-- runAesonParser (parsePGValue ty) val
|
|
parseMany = do
|
|
vals <- runAesonParser parseJSON val
|
|
indexedForM vals (parser ty)
|
|
|
|
parseOpExps
|
|
:: (MonadError QErr m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> PGColInfo
|
|
-> Value
|
|
-> m [OpExpG a]
|
|
parseOpExps valParser cim (PGColInfo cn colTy _) (Object o) =
|
|
forM (M.toList o) $ \(k, v) -> do
|
|
op <- parseOp k
|
|
case (op, v) of
|
|
(Left rqlOp, _) -> do
|
|
modifyErr (cn <<>) $ getOpTypeChecker rqlOp colTy
|
|
annValOp <- withPathK (T.pack $ show rqlOp) $
|
|
parseAnnOpExpG valParser rqlOp colTy v
|
|
return $ OEVal annValOp
|
|
(Right colOp, String c) -> do
|
|
let pgCol = PGCol c
|
|
errMsg = "column operators can only compare postgres columns"
|
|
rhsType <- askPGType cim pgCol errMsg
|
|
when (colTy /= rhsType) $
|
|
throw400 UnexpectedPayload $
|
|
"incompatible column types : " <> cn <<> ", " <>> pgCol
|
|
return $ OECol colOp pgCol
|
|
(Right _, _) -> throw400 UnexpectedPayload "expecting a string for column operator"
|
|
parseOpExps valParser _ (PGColInfo _ colTy _) val = do
|
|
annValOp <- parseAnnOpExpG valParser REQ colTy val
|
|
return [OEVal annValOp]
|
|
|
|
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
|
|
]
|
|
|
|
type OpTypeChecker m = PGColType -> m ()
|
|
|
|
textOnlyOp :: (MonadError QErr m) => OpTypeChecker m
|
|
textOnlyOp PGText = return ()
|
|
textOnlyOp PGVarchar = return ()
|
|
textOnlyOp ty =
|
|
throwError $ buildMsg ty [PGVarchar, PGText]
|
|
|
|
validOnAllTypes :: (MonadError QErr m) => OpTypeChecker m
|
|
validOnAllTypes _ = return ()
|
|
|
|
getOpTypeChecker :: (MonadError QErr m) => RQLOp -> OpTypeChecker m
|
|
getOpTypeChecker REQ = validOnAllTypes
|
|
getOpTypeChecker RNE = validOnAllTypes
|
|
getOpTypeChecker RIN = validOnAllTypes
|
|
getOpTypeChecker RNIN = validOnAllTypes
|
|
getOpTypeChecker RGT = validOnAllTypes
|
|
getOpTypeChecker RLT = validOnAllTypes
|
|
getOpTypeChecker RGTE = validOnAllTypes
|
|
getOpTypeChecker RLTE = validOnAllTypes
|
|
getOpTypeChecker RLIKE = textOnlyOp
|
|
getOpTypeChecker RNLIKE = textOnlyOp
|
|
getOpTypeChecker RILIKE = textOnlyOp
|
|
getOpTypeChecker RNILIKE = textOnlyOp
|
|
getOpTypeChecker RSIMILAR = textOnlyOp
|
|
getOpTypeChecker RNSIMILAR = textOnlyOp
|
|
|
|
-- 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))
|
|
|
|
mapBoolExp :: (Monad m)
|
|
=> (a -> m b)
|
|
-> GBoolExp a -> m (GBoolExp b)
|
|
mapBoolExp f (BoolAnd bes) = BoolAnd <$> mapM (mapBoolExp f) bes
|
|
mapBoolExp f (BoolOr bes) = BoolOr <$> mapM (mapBoolExp f) bes
|
|
mapBoolExp f (BoolCol ce) = BoolCol <$> f ce
|
|
mapBoolExp f (BoolNot notExp) = BoolNot <$> mapBoolExp f notExp
|
|
|
|
annBoolExp
|
|
:: (QErrM m, CacheRM m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> GBoolExp ColExp
|
|
-> m (GBoolExp (AnnValG [OpExpG a]))
|
|
annBoolExp valParser cim = \case
|
|
(BoolAnd bes) -> BoolAnd <$> mapM (annBoolExp valParser cim) bes
|
|
(BoolOr bes) -> BoolOr <$> mapM (annBoolExp valParser cim) bes
|
|
(BoolCol ce) -> BoolCol <$> annColExp valParser cim ce
|
|
(BoolNot notExp) -> BoolNot <$> annBoolExp valParser cim notExp
|
|
|
|
annColExp
|
|
:: (QErrM m, CacheRM m)
|
|
=> ValueParser m a
|
|
-> FieldInfoMap
|
|
-> ColExp
|
|
-> m (AnnValG [OpExpG 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 $ S.BELit True
|
|
|
|
type BoolExpBuilder m a = S.SQLExp -> AnnValOpExpG a -> m S.BoolExp
|
|
|
|
convBoolRhs
|
|
:: (Monad m)
|
|
=> BoolExpBuilder m a -> S.Qual
|
|
-> GBoolExp (AnnValO a) -> m (GBoolExp AnnSQLBoolExp)
|
|
convBoolRhs vp tq =
|
|
traverse (convColRhs vp tq )
|
|
|
|
convColRhs
|
|
:: (Monad m)
|
|
=> BoolExpBuilder m a
|
|
-> S.Qual -> AnnValO a -> m (AnnValG S.BoolExp)
|
|
convColRhs bExpBuilder tableQual annVal = case annVal of
|
|
AVCol pci@(PGColInfo cn _ _) opExps -> do
|
|
let qualColExp = S.SEQIden $ S.QIden tableQual (toIden cn)
|
|
bExps <- forM opExps $ \case
|
|
OEVal annOpValExp -> bExpBuilder qualColExp annOpValExp
|
|
OECol op rCol -> do
|
|
let rhsColExp = S.SEQIden $ S.QIden tableQual (toIden rCol)
|
|
return $ mkColOpSQLExp op qualColExp rhsColExp
|
|
-- And them all
|
|
return $ AVCol pci $ foldr (S.BEBin S.AndOp) (S.BELit True) bExps
|
|
|
|
AVRel ri@(RelInfo _ _ colMapping relTN _) nesAnn fltr -> do
|
|
-- Convert the where clause on the relationship
|
|
annRelBoolExp <- convBoolRhs bExpBuilder (S.mkQual relTN) nesAnn
|
|
let backCompExp = foldr (S.BEBin S.AndOp) (S.BELit True) $
|
|
flip map colMapping $ \(lCol, rCol) ->
|
|
S.BECompare S.SEQ (S.mkSIdenExp rCol)
|
|
(S.SEQIden $ S.QIden tableQual (toIden lCol))
|
|
return $ AVRel ri annRelBoolExp $ S.BEBin S.AndOp fltr backCompExp
|
|
|
|
cBoolExp
|
|
:: GBoolExp AnnSQLBoolExp
|
|
-> S.BoolExp
|
|
cBoolExp be =
|
|
runIdentity $ flip foldBoolExp be $ \ace ->
|
|
return $ cColExp ace
|
|
|
|
cColExp
|
|
:: AnnSQLBoolExp
|
|
-> S.BoolExp
|
|
cColExp annVal = case annVal of
|
|
AVCol _ be -> be
|
|
AVRel (RelInfo _ _ _ relTN _) nesAnn backCompExp -> do
|
|
-- Convert the where clause on the relationship
|
|
let annRelBoolExp = cBoolExp nesAnn
|
|
innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp
|
|
S.mkExists relTN innerBoolExp
|
|
|
|
inBoolExpBuilder :: S.SQLExp -> [S.SQLExp] -> S.BoolExp
|
|
inBoolExpBuilder qualColExp rhsExps =
|
|
foldr (S.BEBin S.OrOp) (S.BELit False) eqExps
|
|
where
|
|
eqExps = map (equalsBoolExpBuilder qualColExp) rhsExps
|
|
|
|
-- txtValParser
|
|
-- :: (MonadError QErr m)
|
|
-- => ValueParser m (AnnValOpExpG S.SQLExp)
|
|
-- txtValParser =
|
|
-- undefined
|
|
|
|
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
|
|
|
|
-- this does not parse the value
|
|
noValParser
|
|
:: (MonadError QErr m)
|
|
=> ValueParser m Value
|
|
noValParser _ = return
|
|
|
|
-- binExpBuilder
|
|
-- :: (Monad m)
|
|
-- => BoolExpBuilder m PGColValue
|
|
-- binExpBuilder =
|
|
-- mkBoolExpBuilder
|
|
|
|
mkBoolExpBuilder
|
|
:: (Monad m)
|
|
=> (a -> m S.SQLExp)
|
|
-> BoolExpBuilder m a
|
|
mkBoolExpBuilder rhsBldr lhs = \case
|
|
AEQ val -> mkSimpleBoolExpBuilder equalsBoolExpBuilder val
|
|
ANE val -> mkSimpleBoolExpBuilder notEqualsBoolExpBuilder val
|
|
AIN vals -> mkInOrNotBoolExpBuilder True vals
|
|
ANIN vals -> mkInOrNotBoolExpBuilder False vals
|
|
AGT val -> mkSimpleBoolExpBuilder (S.BECompare S.SGT) val
|
|
ALT val -> mkSimpleBoolExpBuilder (S.BECompare S.SLT) val
|
|
AGTE val -> mkSimpleBoolExpBuilder (S.BECompare S.SGTE) val
|
|
ALTE val -> mkSimpleBoolExpBuilder (S.BECompare S.SLTE) val
|
|
ALIKE val -> mkSimpleBoolExpBuilder (S.BECompare S.SLIKE) val
|
|
ANLIKE val -> mkSimpleBoolExpBuilder (S.BECompare S.SNLIKE) val
|
|
AILIKE val -> mkSimpleBoolExpBuilder (S.BECompare S.SILIKE) val
|
|
ANILIKE val -> mkSimpleBoolExpBuilder (S.BECompare S.SNILIKE) val
|
|
ASIMILAR val -> mkSimpleBoolExpBuilder (S.BECompare S.SSIMILAR) val
|
|
ANSIMILAR val -> mkSimpleBoolExpBuilder (S.BECompare S.SNSIMILAR) val
|
|
ANISNULL -> return $ S.BENull lhs
|
|
ANISNOTNULL -> return $ S.BENotNull lhs
|
|
where
|
|
mkSimpleBoolExpBuilder beF pgColVal =
|
|
beF lhs <$> rhsBldr pgColVal
|
|
|
|
mkInOrNotBoolExpBuilder isIn arrVals = do
|
|
rhsExps <- mapM rhsBldr arrVals
|
|
let boolExp = inBoolExpBuilder lhs rhsExps
|
|
return $ bool (S.BENot boolExp) boolExp isIn
|
|
|
|
-- txtRHSBuilder :: (MonadError QErr m) => RHSBuilder m
|
|
-- txtRHSBuilder colType = runAesonParser (convToTxt colType)
|
|
|
|
mkColOpSQLExp :: ColOp -> S.SQLExp -> S.SQLExp -> S.BoolExp
|
|
mkColOpSQLExp colOp =
|
|
case colOp of
|
|
CEQ -> S.BECompare S.SEQ
|
|
CNE -> S.BECompare S.SNE
|
|
CGT -> S.BECompare S.SGT
|
|
CLT -> S.BECompare S.SLT
|
|
CGTE -> S.BECompare S.SGTE
|
|
CLTE -> S.BECompare S.SLTE
|
|
|
|
getColExpDeps :: QualifiedTable -> AnnValG a -> [SchemaDependency]
|
|
getColExpDeps tn (AVCol pgCI _) =
|
|
[SchemaDependency (SOTableObj tn (TOCol $ pgiName pgCI)) "on_type"]
|
|
getColExpDeps tn (AVRel relInfo nesAnn _) =
|
|
pd : getBoolExpDeps (riRTable relInfo) nesAnn
|
|
where
|
|
pd = SchemaDependency (SOTableObj tn (TORel $ riName relInfo)) "on_type"
|
|
|
|
getBoolExpDeps :: QualifiedTable -> GBoolExp (AnnValG a) -> [SchemaDependency]
|
|
getBoolExpDeps tn (BoolAnd exps) =
|
|
mconcat $ map (getBoolExpDeps tn) exps
|
|
getBoolExpDeps tn (BoolOr exps) =
|
|
mconcat $ map (getBoolExpDeps tn) exps
|
|
getBoolExpDeps tn (BoolCol colExp) =
|
|
getColExpDeps tn colExp
|
|
getBoolExpDeps tn (BoolNot notExp) =
|
|
getBoolExpDeps tn notExp
|