graphql-engine/server/src-lib/Hasura/RQL/GBoolExp.hs
2018-09-07 17:45:28 +05:30

506 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
| AContains !a
| AContainedIn !a
| AHasKey !a
| AHasKeysAny [Text]
| AHasKeysAll [Text]
| 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
AContains val -> mkSimpleBoolExpBuilder (S.BECompare S.SContains) val
AContainedIn val -> mkSimpleBoolExpBuilder (S.BECompare S.SContainedIn) val
AHasKey val -> mkSimpleBoolExpBuilder (S.BECompare S.SHasKey) val
AHasKeysAny keys -> return $ S.BECompare S.SHasKeysAny lhs $ toTextArray keys
AHasKeysAll keys -> return $ S.BECompare S.SHasKeysAll lhs $ toTextArray keys
ANISNULL -> return $ S.BENull lhs
ANISNOTNULL -> return $ S.BENotNull lhs
where
toTextArray arr =
S.SETyAnn (S.SEArray $ map (txtEncoder . PGValText) arr) S.textArrType
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