From bc133e7f89235957683a5239bb9a157aa4f783c8 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 9 Nov 2018 18:30:20 +0530 Subject: [PATCH 01/12] wip --- server/graphql-engine.cabal | 3 +- .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 139 ++-- .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 7 +- .../src-lib/Hasura/GraphQL/Resolve/Insert.hs | 18 +- .../Hasura/GraphQL/Resolve/Mutation.hs | 14 +- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 30 +- server/src-lib/Hasura/GraphQL/Schema.hs | 30 +- server/src-lib/Hasura/Prelude.hs | 1 + server/src-lib/Hasura/RQL/DDL/Permission.hs | 30 +- .../Hasura/RQL/DDL/Permission/Internal.hs | 49 +- .../src-lib/Hasura/RQL/DDL/QueryTemplate.hs | 16 +- server/src-lib/Hasura/RQL/DDL/Relationship.hs | 16 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 102 +-- server/src-lib/Hasura/RQL/DML/Count.hs | 11 +- server/src-lib/Hasura/RQL/DML/Delete.hs | 7 +- server/src-lib/Hasura/RQL/DML/Internal.hs | 76 +- .../src-lib/Hasura/RQL/DML/QueryTemplate.hs | 2 +- server/src-lib/Hasura/RQL/DML/Returning.hs | 5 +- server/src-lib/Hasura/RQL/DML/Select.hs | 84 +- server/src-lib/Hasura/RQL/DML/Update.hs | 8 +- server/src-lib/Hasura/RQL/GBoolExp.hs | 765 +++++++++--------- server/src-lib/Hasura/RQL/Types.hs | 3 +- server/src-lib/Hasura/RQL/Types/BoolExp.hs | 344 ++++++++ server/src-lib/Hasura/RQL/Types/Common.hs | 97 +-- server/src-lib/Hasura/RQL/Types/DML.hs | 27 +- server/src-lib/Hasura/RQL/Types/Permission.hs | 1 - .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 341 ++++---- server/src-lib/Hasura/SQL/DML.hs | 12 +- 28 files changed, 1322 insertions(+), 916 deletions(-) create mode 100644 server/src-lib/Hasura/RQL/Types/BoolExp.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 9eb307d74e061..368d5ba302b16 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -144,8 +144,9 @@ library , Hasura.Server.CheckUpdates , Hasura.RQL.Types , Hasura.RQL.Instances - , Hasura.RQL.Types.SchemaCache , Hasura.RQL.Types.Common + , Hasura.RQL.Types.BoolExp + , Hasura.RQL.Types.SchemaCache , Hasura.RQL.Types.Permission , Hasura.RQL.Types.Error , Hasura.RQL.Types.DML diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index 8eb1c37f56aae..2208c3c068b6c 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -8,7 +8,7 @@ module Hasura.GraphQL.Resolve.BoolExp ( parseBoolExp , pgColValToBoolExpG , pgColValToBoolExp - , convertBoolExpG + -- , convertBoolExpG , convertBoolExp , prepare ) where @@ -20,8 +20,8 @@ import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Language.GraphQL.Draft.Syntax as G -import qualified Hasura.RQL.GBoolExp as RA -import qualified Hasura.RQL.GBoolExp as RG +-- import qualified Hasura.RQL.GBoolExp as RA +-- import qualified Hasura.RQL.GBoolExp as RG import qualified Hasura.SQL.DML as S import Hasura.GraphQL.Resolve.Context @@ -32,40 +32,42 @@ import Hasura.RQL.Types import Hasura.SQL.Types import Hasura.SQL.Value +type OpExp = OpExpG (PGColType, PGColValue) + parseOpExps :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => AnnGValue -> m [RA.OpExp] + => AnnGValue -> m [OpExp] parseOpExps annVal = do opExpsM <- flip withObjectM annVal $ \nt objM -> forM objM $ \obj -> forM (OMap.toList obj) $ \(k, v) -> case k of - "_eq" -> fmap RA.AEQ <$> asPGColValM v - "_ne" -> fmap RA.ANE <$> asPGColValM v - "_neq" -> fmap RA.ANE <$> asPGColValM v + "_eq" -> fmap AEQ <$> asPGColValM v + "_ne" -> fmap ANE <$> asPGColValM v + "_neq" -> fmap ANE <$> asPGColValM v "_is_null" -> resolveIsNull v - "_in" -> fmap (RA.AIN . catMaybes) <$> parseMany asPGColValM v - "_nin" -> fmap (RA.ANIN . catMaybes) <$> parseMany asPGColValM v + "_in" -> fmap (AIN . catMaybes) <$> parseMany asPGColValM v + "_nin" -> fmap (ANIN . catMaybes) <$> parseMany asPGColValM v - "_gt" -> fmap RA.AGT <$> asPGColValM v - "_lt" -> fmap RA.ALT <$> asPGColValM v - "_gte" -> fmap RA.AGTE <$> asPGColValM v - "_lte" -> fmap RA.ALTE <$> asPGColValM v + "_gt" -> fmap AGT <$> asPGColValM v + "_lt" -> fmap ALT <$> asPGColValM v + "_gte" -> fmap AGTE <$> asPGColValM v + "_lte" -> fmap ALTE <$> asPGColValM v - "_like" -> fmap RA.ALIKE <$> asPGColValM v - "_nlike" -> fmap RA.ANLIKE <$> asPGColValM v + "_like" -> fmap ALIKE <$> asPGColValM v + "_nlike" -> fmap ANLIKE <$> asPGColValM v - "_ilike" -> fmap RA.AILIKE <$> asPGColValM v - "_nilike" -> fmap RA.ANILIKE <$> asPGColValM v + "_ilike" -> fmap AILIKE <$> asPGColValM v + "_nilike" -> fmap ANILIKE <$> asPGColValM v - "_similar" -> fmap RA.ASIMILAR <$> asPGColValM v - "_nsimilar" -> fmap RA.ANSIMILAR <$> asPGColValM v + "_similar" -> fmap ASIMILAR <$> asPGColValM v + "_nsimilar" -> fmap ANSIMILAR <$> asPGColValM v -- jsonb related operators - "_contains" -> fmap RA.AContains <$> asPGColValM v - "_contained_in" -> fmap RA.AContainedIn <$> asPGColValM v - "_has_key" -> fmap RA.AHasKey <$> asPGColValM v - "_has_keys_any" -> fmap RA.AHasKeysAny <$> parseMany asPGColText v - "_has_keys_all" -> fmap RA.AHasKeysAll <$> parseMany asPGColText v + "_contains" -> fmap AContains <$> asPGColValM v + "_contained_in" -> fmap AContainedIn <$> asPGColValM v + "_has_key" -> fmap AHasKey <$> asPGColValM v + "_has_keys_any" -> fmap AHasKeysAny <$> parseMany asPGColText v + "_has_keys_all" -> fmap AHasKeysAll <$> parseMany asPGColText v _ -> throw500 @@ -73,88 +75,91 @@ parseOpExps annVal = do <> showNamedTy nt <> ": " <> showName k - return $ map RA.OEVal $ catMaybes $ fromMaybe [] opExpsM + return $ catMaybes $ fromMaybe [] opExpsM where resolveIsNull v = case v of AGScalar _ Nothing -> return Nothing AGScalar _ (Just (PGValBoolean b)) -> - return $ Just $ bool RA.ANISNOTNULL RA.ANISNULL b + return $ Just $ bool ANISNOTNULL ANISNULL b AGScalar _ _ -> throw500 "boolean value is expected" _ -> tyMismatch "pgvalue" v parseAsEqOp :: (MonadError QErr m) - => AnnGValue -> m [RA.OpExp] + => AnnGValue -> m [OpExp] parseAsEqOp annVal = do - annValOpExp <- RA.AEQ <$> asPGColVal annVal - return [RA.OEVal annValOpExp] + annValOpExp <- AEQ <$> asPGColVal annVal + return [annValOpExp] parseColExp :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => G.NamedType + => ((PGColType, PGColValue) -> m S.SQLExp) + -> G.NamedType -> G.Name -> AnnGValue - -> (AnnGValue -> m [RA.OpExp]) - -> m RA.AnnVal -parseColExp nt n val expParser = do + -> (AnnGValue -> m [OpExp]) + -> m AnnBoolExpFldSQL +parseColExp f nt n val expParser = do fldInfo <- getFldInfo nt n case fldInfo of - Left pgColInfo -> RA.AVCol pgColInfo <$> expParser val + Left pgColInfo -> do + opExps <- expParser val + AVCol pgColInfo <$> traverse (traverse f) opExps Right (relInfo, _, permExp, _) -> do - relBoolExp <- parseBoolExp val - return $ RA.AVRel relInfo relBoolExp permExp + relBoolExp <- parseBoolExp f val + return $ AVRel relInfo $ andAnnBoolExps relBoolExp permExp parseBoolExp :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => AnnGValue - -> m (GBoolExp RA.AnnVal) -parseBoolExp annGVal = do + => ((PGColType, PGColValue) -> m S.SQLExp) + -> AnnGValue + -> m AnnBoolExpSQL +parseBoolExp f annGVal = do boolExpsM <- flip withObjectM annGVal $ \nt objM -> forM objM $ \obj -> forM (OMap.toList obj) $ \(k, v) -> if - | k == "_or" -> BoolOr . fromMaybe [] <$> parseMany parseBoolExp v - | k == "_and" -> BoolAnd . fromMaybe [] <$> parseMany parseBoolExp v - | k == "_not" -> BoolNot <$> parseBoolExp v - | otherwise -> BoolCol <$> parseColExp nt k v parseOpExps + | k == "_or" -> BoolOr . fromMaybe [] + <$> parseMany (parseBoolExp f) v + | k == "_and" -> BoolAnd . fromMaybe [] + <$> parseMany (parseBoolExp f) v + | k == "_not" -> BoolNot <$> parseBoolExp f v + | otherwise -> BoolFld <$> parseColExp f nt k v parseOpExps return $ BoolAnd $ fromMaybe [] boolExpsM -convertBoolExpG - :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable - -> AnnGValue - -> m (GBoolExp RG.AnnSQLBoolExp) -convertBoolExpG f tn whereArg = do - whereExp <- parseBoolExp whereArg - RG.convBoolRhs (RG.mkBoolExpBuilder f) (S.mkQual tn) whereExp +-- convertBoolExpG +-- :: (MonadError QErr m, MonadReader r m, Has FieldMap r) +-- => ((PGColType, PGColValue) -> m S.SQLExp) +-- -> QualifiedTable +-- -> AnnGValue +-- -> m AnnBoolExpSQL +-- convertBoolExpG f tn whereArg = do +-- whereExp <- parseBoolExp f whereArg +-- traverse f whereExp convertBoolExp - :: QualifiedTable - -> AnnGValue - -> Convert (GBoolExp RG.AnnSQLBoolExp) -convertBoolExp = convertBoolExpG prepare + :: AnnGValue + -> Convert AnnBoolExpSQL +convertBoolExp = + parseBoolExp prepare type PGColValMap = Map.HashMap G.Name AnnGValue pgColValToBoolExpG :: (MonadError QErr m, MonadReader r m, Has FieldMap r) => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable -> PGColValMap - -> m (GBoolExp RG.AnnSQLBoolExp) -pgColValToBoolExpG f tn colValMap = do - colExps <- forM colVals $ \(name, val) -> do - (ty, _) <- asPGColVal val + -> m AnnBoolExpSQL +pgColValToBoolExpG f colValMap = do + colExps <- forM colVals $ \(name, valR) -> do + (ty, val) <- asPGColVal valR let namedTy = mkScalarTy ty - BoolCol <$> parseColExp namedTy name val parseAsEqOp - let whereExp = BoolAnd colExps - RG.convBoolRhs (RG.mkBoolExpBuilder f) (S.mkQual tn) whereExp + BoolFld <$> parseColExp f namedTy name valR parseAsEqOp + return $ BoolAnd colExps where colVals = Map.toList colValMap pgColValToBoolExp - :: QualifiedTable - -> PGColValMap - -> Convert (GBoolExp RG.AnnSQLBoolExp) + :: PGColValMap + -> Convert AnnBoolExpSQL pgColValToBoolExp = pgColValToBoolExpG prepare diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index e144caae833be..5da6f2d2bdf56 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -59,7 +59,7 @@ $(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp) type FieldMap = Map.HashMap (G.NamedType, G.Name) - (Either PGColInfo (RelInfo, Bool, S.BoolExp, Maybe Int)) + (Either PGColInfo (RelInfo, Bool, AnnBoolExpSQL, Maybe Int)) -- data OrdTy -- = OAsc @@ -76,7 +76,7 @@ type RespTx = Q.TxE QErr BL.ByteString -- order by context data OrdByItem = OBIPGCol !PGColInfo - | OBIRel !RelInfo !S.BoolExp + | OBIRel !RelInfo !AnnBoolExpSQL deriving (Show, Eq) type OrdByItemMap = Map.HashMap G.Name OrdByItem @@ -98,7 +98,8 @@ type InsCtxMap = Map.HashMap QualifiedTable InsCtx getFldInfo :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => G.NamedType -> G.Name -> m (Either PGColInfo (RelInfo, Bool, S.BoolExp, Maybe Int)) + => G.NamedType -> G.Name + -> m (Either PGColInfo (RelInfo, Bool, AnnBoolExpSQL, Maybe Int)) getFldInfo nt n = do fldMap <- asks getter onNothing (Map.lookup (nt,n) fldMap) $ diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs index 2cbdd45f4fc22..21cb6f40b61cc 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs @@ -381,13 +381,15 @@ insertObj role insCtxMap tn annObj ctx addCols onConflictValM errP = do mkBoolExp :: (MonadError QErr m, MonadState PrepArgs m) => QualifiedTable -> [(PGColInfo, PGColValue)] - -> m (GBoolExp RG.AnnSQLBoolExp) + -> m S.BoolExp mkBoolExp tn colInfoVals = - RG.convBoolRhs (RG.mkBoolExpBuilder prepare) (S.mkQual tn) boolExp + RB.toSQLBoolExp (S.mkQual tn) <$> boolExp where - boolExp = BoolAnd $ map (BoolCol . uncurry f) colInfoVals - f ci@(PGColInfo _ colTy _) colVal = - RB.AVCol ci [RB.OEVal $ RB.AEQ (colTy, colVal)] + boolExp = BoolAnd <$> mapM (fmap BoolFld . uncurry f) colInfoVals + + f ci@(PGColInfo _ colTy _) colVal = do + sqlExp <- prepare (colTy, colVal) + return $ AVCol ci [AEQ sqlExp] mkSelQ :: QualifiedTable -> [PGColInfo] -> [PGColWithValue] -> Q.TxE QErr WithExp @@ -395,7 +397,7 @@ mkSelQ tn allColInfos pgColsWithVal = do (whereExp, args) <- flip runStateT Seq.Empty $ mkBoolExp tn colWithInfos let sqlSel = S.mkSelect { S.selExtr = [S.selectStar] , S.selFrom = Just $ S.mkSimpleFromExp tn - , S.selWhere = Just $ S.WhereFrag $ RG.cBoolExp whereExp + , S.selWhere = Just $ S.WhereFrag whereExp } return (S.CTESelect sqlSel, args) @@ -418,8 +420,8 @@ execWithExp tn (withExp, args) annFlds = do <$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder sqlBuilder) (toList args) True where selFlds = RS.ASFSimple annFlds - tabFrom = RS.TableFrom tn frmItemM - tabPerm = RS.TablePerm (S.BELit True) Nothing + tabFrom = RS.TableFrom $ Right $ toIden alias + tabPerm = RS.TablePerm annBoolExpTrue Nothing alias = S.Alias $ Iden $ snakeCaseTable tn <> "__rel_insert_result" frmItemM = Just $ S.FIIden $ toIden alias diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index 676de0d7f8902..1cad726748a73 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -37,11 +37,9 @@ convertReturning convertReturning qt ty selSet = do annFlds <- fromSelSet prepare ty selSet let selFlds = RS.ASFSimple annFlds - tabFrom = RS.TableFrom qt $ Just frmItem - tabPerm = RS.TablePerm (S.BELit True) Nothing + tabFrom = RS.TableFrom $ Right $ RR.qualTableToAliasIden qt + tabPerm = RS.TablePerm annBoolExpTrue Nothing return $ RS.AnnSel selFlds tabFrom tabPerm RS.noTableArgs - where - frmItem = S.FIIden $ RR.qualTableToAliasIden qt convertMutResp :: QualifiedTable -> G.NamedType -> SelSet -> Convert RR.MutFlds @@ -105,14 +103,14 @@ convDeleteAtPathObj val = convertUpdate :: QualifiedTable -- table - -> S.BoolExp -- the filter expression + -> AnnBoolExpSQL -- the filter expression -> Field -- the mutation field -> Convert RespTx convertUpdate tn filterExp fld = do -- a set expression is same as a row object setExpM <- withArgM args "_set" $ convertRowObj Map.empty -- where bool expression to filter column - whereExp <- withArg args "where" $ convertBoolExp tn + whereExp <- withArg args "where" convertBoolExp -- increment operator on integer columns incExpM <- withArgM args "_inc" $ convObjWithOp $ rhsExpOp S.incOp S.intType @@ -148,11 +146,11 @@ convertUpdate tn filterExp fld = do convertDelete :: QualifiedTable -- table - -> S.BoolExp -- the filter expression + -> AnnBoolExpSQL -- the filter expression -> Field -- the mutation field -> Convert RespTx convertDelete tn filterExp fld = do - whereExp <- withArg (_fArguments fld) "where" $ convertBoolExp tn + whereExp <- withArg (_fArguments fld) "where" convertBoolExp mutFlds <- convertMutResp tn (_fType fld) $ _fSelSet fld args <- get let p1 = RD.DeleteQueryP1 tn (filterExp, whereExp) mutFlds diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 2f7c40ab554b6..5b969a2350b93 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -75,9 +75,9 @@ fieldAsPath = nameAsPath . _fName parseTableArgs :: (MonadError QErr m, MonadReader r m, Has FieldMap r, Has OrdByCtx r) => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable -> ArgsMap -> m RS.TableArgs -parseTableArgs f tn args = do - whereExpM <- withArgM args "where" $ convertBoolExpG f tn + -> ArgsMap -> m RS.TableArgs +parseTableArgs f args = do + whereExpM <- withArgM args "where" $ parseBoolExp f ordByExpML <- withArgM args "order_by" parseOrderBy let ordByExpM = NE.nonEmpty =<< ordByExpML limitExpM <- withArgM args "limit" parseLimit @@ -87,13 +87,13 @@ parseTableArgs f tn args = do fromField :: (MonadError QErr m, MonadReader r m, Has FieldMap r, Has OrdByCtx r) => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> m RS.AnnSel + -> QualifiedTable -> AnnBoolExpSQL -> Maybe Int -> Field -> m RS.AnnSel fromField f tn permFilter permLimitM fld = fieldAsPath fld $ do - tableArgs <- parseTableArgs f tn args + tableArgs <- parseTableArgs f args annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld let selFlds = RS.ASFSimple annFlds - tabFrom = RS.TableFrom tn Nothing + tabFrom = RS.TableFrom $ Left tn tabPerm = RS.TablePerm permFilter permLimitM return $ RS.AnnSel selFlds tabFrom tabPerm tableArgs where @@ -170,18 +170,18 @@ parseLimit v = do fromFieldByPKey :: (MonadError QErr m, MonadReader r m, Has FieldMap r, Has OrdByCtx r) => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable -> S.BoolExp -> Field -> m RS.AnnSel + -> QualifiedTable -> AnnBoolExpSQL -> Field -> m RS.AnnSel fromFieldByPKey f tn permFilter fld = fieldAsPath fld $ do - boolExp <- pgColValToBoolExpG f tn $ _fArguments fld + boolExp <- pgColValToBoolExpG f $ _fArguments fld annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld let selFlds = RS.ASFSimple annFlds - tabFrom = RS.TableFrom tn Nothing + tabFrom = RS.TableFrom $ Left tn tabPerm = RS.TablePerm permFilter Nothing return $ RS.AnnSel selFlds tabFrom tabPerm $ RS.noTableArgs { RS._taWhere = Just boolExp} convertSelect - :: QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> Convert RespTx + :: QualifiedTable -> AnnBoolExpSQL -> Maybe Int -> Field -> Convert RespTx convertSelect qt permFilter permLimit fld = do selData <- withPathK "selectionSet" $ fromField prepare qt permFilter permLimit fld @@ -189,7 +189,7 @@ convertSelect qt permFilter permLimit fld = do return $ RS.selectP2 False (selData, prepArgs) convertSelectByPKey - :: QualifiedTable -> S.BoolExp -> Field -> Convert RespTx + :: QualifiedTable -> AnnBoolExpSQL -> Field -> Convert RespTx convertSelectByPKey qt permFilter fld = do selData <- withPathK "selectionSet" $ fromFieldByPKey prepare qt permFilter fld @@ -224,12 +224,12 @@ convertAggFld ty selSet = fromAggField :: (MonadError QErr m, MonadReader r m, Has FieldMap r, Has OrdByCtx r) => ((PGColType, PGColValue) -> m S.SQLExp) - -> QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> m RS.AnnSel + -> QualifiedTable -> AnnBoolExpSQL -> Maybe Int -> Field -> m RS.AnnSel fromAggField fn tn permFilter permLimitM fld = fieldAsPath fld $ do - tableArgs <- parseTableArgs fn tn args + tableArgs <- parseTableArgs fn args aggSelFlds <- fromAggSel (_fType fld) $ _fSelSet fld let selFlds = RS.ASFWithAgg aggSelFlds - tabFrom = RS.TableFrom tn Nothing + tabFrom = RS.TableFrom $ Left tn tabPerm = RS.TablePerm permFilter permLimitM return $ RS.AnnSel selFlds tabFrom tabPerm tableArgs where @@ -245,7 +245,7 @@ fromAggField fn tn permFilter permLimitM fld = fieldAsPath fld $ do G.Name t -> throw500 $ "unexpected field in _agg node: " <> t convertAggSelect - :: QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> Convert RespTx + :: QualifiedTable -> AnnBoolExpSQL -> Maybe Int -> Field -> Convert RespTx convertAggSelect qt permFilter permLimit fld = do selData <- withPathK "selectionSet" $ fromAggField prepare qt permFilter permLimit fld diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index fa7cf7d9b774c..c79cf96abf99c 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -35,8 +35,6 @@ import Hasura.RQL.DML.Internal (mkAdminRolePermInfo) import Hasura.RQL.Types import Hasura.SQL.Types -import qualified Hasura.SQL.DML as S - defaultTypes :: [TypeInfo] defaultTypes = $(fromSchemaDocQ defaultSchema) @@ -60,15 +58,15 @@ data OpCtx -- table, req hdrs = OCInsert QualifiedTable [T.Text] -- tn, filter exp, limit, req hdrs - | OCSelect QualifiedTable S.BoolExp (Maybe Int) [T.Text] + | OCSelect QualifiedTable AnnBoolExpSQL (Maybe Int) [T.Text] -- tn, filter exp, reqt hdrs - | OCSelectPkey QualifiedTable S.BoolExp [T.Text] + | OCSelectPkey QualifiedTable AnnBoolExpSQL [T.Text] -- tn, filter exp, limit, req hdrs - | OCSelectAgg QualifiedTable S.BoolExp (Maybe Int) [T.Text] + | OCSelectAgg QualifiedTable AnnBoolExpSQL (Maybe Int) [T.Text] -- tn, filter exp, req hdrs - | OCUpdate QualifiedTable S.BoolExp [T.Text] + | OCUpdate QualifiedTable AnnBoolExpSQL [T.Text] -- tn, filter exp, req hdrs - | OCDelete QualifiedTable S.BoolExp [T.Text] + | OCDelete QualifiedTable AnnBoolExpSQL [T.Text] deriving (Show, Eq) data GCtx @@ -102,7 +100,7 @@ instance Monoid TyAgg where mempty = TyAgg Map.empty Map.empty Map.empty mappend = (<>) -type SelField = Either PGColInfo (RelInfo, Bool, S.BoolExp, Maybe Int, Bool) +type SelField = Either PGColInfo (RelInfo, Bool, AnnBoolExpSQL, Maybe Int, Bool) qualTableToName :: QualifiedTable -> G.Name qualTableToName = G.Name <$> \case @@ -115,7 +113,7 @@ isValidTableName = isValidName . qualTableToName isValidField :: FieldInfo -> Bool isValidField = \case FIColumn (PGColInfo col _ _) -> isColEligible col - FIRelationship (RelInfo rn _ _ remTab _ _) -> isRelEligible rn remTab + FIRelationship (RelInfo rn _ _ remTab _) -> isRelEligible rn remTab where isColEligible = isValidName . G.Name . getPGColTxt isRelEligible rn rt = isValidName (G.Name $ getRelTxt rn) @@ -317,7 +315,7 @@ mkRelFld -> RelInfo -> Bool -> [ObjFldInfo] -mkRelFld allowAgg (RelInfo rn rTy _ remTab _ isManual) isNullable = case rTy of +mkRelFld allowAgg (RelInfo rn rTy _ remTab isManual) isNullable = case rTy of ArrRel -> bool [arrRelFld] [arrRelFld, aggArrRelFld] allowAgg ObjRel -> [objRelFld] where @@ -553,7 +551,7 @@ mkBoolExpInp tn fields = mkFldExpInp = \case Left (PGColInfo colName colTy _) -> mk (mkColName colName) (mkCompExpTy colTy) - Right (RelInfo relName _ _ remTab _ _, _, _, _, _) -> + Right (RelInfo relName _ _ remTab _, _, _, _, _) -> mk (G.Name $ getRelTxt relName) (mkBoolExpTy remTab) mkPGColInp :: PGColInfo -> InpValInfo @@ -1268,9 +1266,9 @@ getRootFldsRole' -> [TableConstraint] -> FieldInfoMap -> Maybe ([T.Text], Bool) -- insert perm - -> Maybe (S.BoolExp, Maybe Int, [T.Text], Bool) -- select filter - -> Maybe ([PGCol], S.BoolExp, [T.Text]) -- update filter - -> Maybe (S.BoolExp, [T.Text]) -- delete filter + -> Maybe (AnnBoolExpSQL, Maybe Int, [T.Text], Bool) -- select filter + -> Maybe ([PGCol], AnnBoolExpSQL, [T.Text]) -- update filter + -> Maybe (AnnBoolExpSQL, [T.Text]) -- delete filter -> Maybe ViewInfo -> RootFlds getRootFldsRole' tn primCols constraints fields insM selM updM delM viM = @@ -1473,8 +1471,8 @@ mkGCtxMapTable tableCache (TableInfo tn _ fields rolePerms constraints pkeyCols (Just (allCols, noFilter, [])) (Just (noFilter, [])) viewInfo -noFilter :: S.BoolExp -noFilter = S.BELit True +noFilter :: AnnBoolExpSQL +noFilter = annBoolExpTrue mkScalarTyInfo :: PGColType -> ScalarTyInfo mkScalarTyInfo = ScalarTyInfo Nothing diff --git a/server/src-lib/Hasura/Prelude.hs b/server/src-lib/Hasura/Prelude.hs index 0a9c511e64acf..66649e1c316a2 100644 --- a/server/src-lib/Hasura/Prelude.hs +++ b/server/src-lib/Hasura/Prelude.hs @@ -21,6 +21,7 @@ import Data.Ord as M (comparing) import Data.Semigroup as M (Semigroup (..)) import Data.String as M (IsString) import Data.Text as M (Text) +import Data.Word as M (Word64) import GHC.Generics as M (Generic) import Prelude as M hiding (fail, init, lookup) import Text.Read as M (readEither, readMaybe) diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index 338c56098233c..55498866ab55f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -53,6 +53,7 @@ import Hasura.RQL.DDL.Permission.Internal import Hasura.RQL.DDL.Permission.Triggers import Hasura.RQL.DML.Internal (onlyPositiveInt) import Hasura.RQL.Types +import Hasura.RQL.GBoolExp import Hasura.SQL.Types import qualified Database.PG.Query as Q @@ -108,10 +109,11 @@ buildInsPermInfo :: (QErrM m, CacheRM m) => TableInfo -> PermDef InsPerm - -> m InsPermInfo + -> m (WithDeps InsPermInfo) buildInsPermInfo tabInfo (PermDef rn (InsPerm chk upsrt set) _) = withPathK "permission" $ do (be, beDeps) <- withPathK "check" $ - procBoolExp tn fieldInfoMap (S.QualVar "NEW") chk + -- procBoolExp tn fieldInfoMap (S.QualVar "NEW") chk + procBoolExp tn fieldInfoMap chk let deps = mkParentDep tn : beDeps fltrHeaders = getDependentHeaders chk setObj = fromMaybe mempty set @@ -125,7 +127,7 @@ buildInsPermInfo tabInfo (PermDef rn (InsPerm chk upsrt set) _) = withPathK "per return (pgCol, sqlExp) let setHdrs = mapMaybe (fetchHdr . snd) (HM.toList setObj) reqHdrs = fltrHeaders `union` setHdrs - return $ InsPermInfo vn be allowUpsrt setColsSQL deps reqHdrs + return (InsPermInfo vn be allowUpsrt setColsSQL reqHdrs, deps) where fieldInfoMap = tiFieldInfoMap tabInfo tn = tiName tabInfo @@ -136,8 +138,8 @@ buildInsPermInfo tabInfo (PermDef rn (InsPerm chk upsrt set) _) = withPathK "per fetchHdr _ = Nothing buildInsInfra :: QualifiedTable -> InsPermInfo -> Q.TxE QErr () -buildInsInfra tn (InsPermInfo vn be _ _ _ _) = do - trigFnQ <- buildInsTrigFn vn tn be +buildInsInfra tn (InsPermInfo vn be _ _ _) = do + trigFnQ <- buildInsTrigFn vn tn $ toSQLBoolExp (S.QualVar "NEW") be Q.catchE defaultTxErrorHandler $ do -- Create the view Q.unitQ (buildView tn vn) () False @@ -192,12 +194,12 @@ buildSelPermInfo :: (QErrM m, CacheRM m) => TableInfo -> SelPerm - -> m SelPermInfo + -> m (WithDeps SelPermInfo) buildSelPermInfo tabInfo sp = do let pgCols = convColSpec fieldInfoMap $ spColumns sp (be, beDeps) <- withPathK "filter" $ - procBoolExp tn fieldInfoMap (S.mkQual tn) $ spFilter sp + procBoolExp tn fieldInfoMap $ spFilter sp -- check if the columns exist void $ withPathK "columns" $ indexedForM pgCols $ \pgCol -> @@ -209,7 +211,7 @@ buildSelPermInfo tabInfo sp = do withPathK "limit" $ mapM_ onlyPositiveInt mLimit - return $ SelPermInfo (HS.fromList pgCols) tn be mLimit allowAgg deps depHeaders + return (SelPermInfo (HS.fromList pgCols) tn be mLimit allowAgg depHeaders, deps) where tn = tiName tabInfo @@ -258,10 +260,10 @@ buildUpdPermInfo :: (QErrM m, CacheRM m) => TableInfo -> UpdPerm - -> m UpdPermInfo + -> m (WithDeps UpdPermInfo) buildUpdPermInfo tabInfo (UpdPerm colSpec fltr) = do (be, beDeps) <- withPathK "filter" $ - procBoolExp tn fieldInfoMap (S.mkQual tn) fltr + procBoolExp tn fieldInfoMap fltr -- check if the columns exist _ <- withPathK "columns" $ indexedForM updCols $ \updCol -> @@ -270,7 +272,7 @@ buildUpdPermInfo tabInfo (UpdPerm colSpec fltr) = do let deps = mkParentDep tn : beDeps ++ map (mkColDep "untyped" tn) updCols depHeaders = getDependentHeaders fltr - return $ UpdPermInfo (HS.fromList updCols) tn be deps depHeaders + return (UpdPermInfo (HS.fromList updCols) tn be depHeaders, deps) where tn = tiName tabInfo @@ -315,13 +317,13 @@ buildDelPermInfo :: (QErrM m, CacheRM m) => TableInfo -> DelPerm - -> m DelPermInfo + -> m (WithDeps DelPermInfo) buildDelPermInfo tabInfo (DelPerm fltr) = do (be, beDeps) <- withPathK "filter" $ - procBoolExp tn fieldInfoMap (S.mkQual tn) fltr + procBoolExp tn fieldInfoMap fltr let deps = mkParentDep tn : beDeps depHeaders = getDependentHeaders fltr - return $ DelPermInfo tn be deps depHeaders + return (DelPermInfo tn be depHeaders, deps) where tn = tiName tabInfo fieldInfoMap = tiFieldInfoMap tabInfo diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs index 09d7a3d2f5405..59b200d4f8d3e 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Internal.hs @@ -172,23 +172,19 @@ createPermP1 tn = do procBoolExp :: (QErrM m, CacheRM m) - => QualifiedTable -> FieldInfoMap -> S.Qual -> BoolExp - -> m (S.BoolExp, [SchemaDependency]) -procBoolExp tn fieldInfoMap tq be = do - abe <- annBoolExp valueParser fieldInfoMap be - sqlbe <- convFilterExp tq abe + => QualifiedTable -> FieldInfoMap -> BoolExp + -> m (AnnBoolExpSQL, [SchemaDependency]) +procBoolExp tn fieldInfoMap be = do + abe <- annBoolExp valueParser fieldInfoMap be let deps = getBoolExpDeps tn abe - return (sqlbe, deps) + return (abe, deps) isReqUserId :: T.Text -> Bool isReqUserId = (== "req_user_id") . T.toLower getDependentHeaders :: BoolExp -> [T.Text] -getDependentHeaders boolExp = case boolExp of - BoolAnd exps -> concatMap getDependentHeaders exps - BoolOr exps -> concatMap getDependentHeaders exps - BoolCol (ColExp _ v) -> parseValue v - BoolNot be -> getDependentHeaders be +getDependentHeaders (BoolExp boolExp) = + flip foldMap boolExp $ \(ColExp _ v) -> parseValue v where parseValue val = case val of (Object o) -> parseObject o @@ -200,10 +196,11 @@ getDependentHeaders boolExp = case boolExp of | isReqUserId t -> [userIdHeader] | otherwise -> [] _ -> [] - parseObject o = flip concatMap (M.toList o) $ \(k, v) -> - if isRQLOp k - then parseOnlyString v - else [] + parseObject o = + concatMap parseOnlyString (M.elems o) + -- if isRQLOp k + -- then parseOnlyString v + -- else [] valueParser :: (MonadError QErr m) => PGColType -> Value -> m S.SQLExp valueParser columnType = \case @@ -220,14 +217,6 @@ valueParser columnType = \case S.SEOpApp (S.SQLOp "->>") [curSess, S.SELit $ T.toLower hdr] `S.SETyAnn` (S.AnnType $ T.pack $ show columnType) --- Convert where clause into SQL BoolExp -convFilterExp :: (MonadError QErr m) - => S.Qual -> GBoolExp AnnValS -> m S.BoolExp -convFilterExp tq be = - cBoolExp <$> convBoolRhs builderStrategy tq be - where - builderStrategy = mkBoolExpBuilder return - injectDefaults :: QualifiedTable -> QualifiedTable -> Q.Query injectDefaults qv qt = Q.fromText $ mconcat @@ -267,7 +256,7 @@ class (ToJSON a) => IsPerm a where :: (QErrM m, CacheRM m) => TableInfo -> PermDef a - -> m (PermInfo a) + -> m (WithDeps (PermInfo a)) addPermP2Setup :: (MonadTx m, QErrM m) => QualifiedTable -> PermDef a -> PermInfo a -> m () @@ -301,16 +290,18 @@ validateViewPerm permDef tableInfo = viewInfo = tiViewInfo tableInfo permAcc = getPermAcc1 permDef -addPermP1 :: (QErrM m, CacheRM m, IsPerm a) => TableInfo -> PermDef a -> m (PermInfo a) +addPermP1 + :: (QErrM m, CacheRM m, IsPerm a) + => TableInfo -> PermDef a -> m (WithDeps (PermInfo a)) addPermP1 tabInfo pd = do assertPermNotDefined (pdRole pd) (getPermAcc1 pd) tabInfo buildPermInfo tabInfo pd addPermP2 :: (IsPerm a, QErrM m, CacheRWM m, MonadTx m) - => QualifiedTable -> PermDef a -> PermInfo a -> m () -addPermP2 tn pd permInfo = do + => QualifiedTable -> PermDef a -> WithDeps (PermInfo a) -> m () +addPermP2 tn pd (permInfo, deps) = do addPermP2Setup tn pd permInfo - addPermToCache tn (pdRole pd) pa permInfo + addPermToCache tn (pdRole pd) pa permInfo deps liftTx $ savePermToCatalog pt tn pd where pa = getPermAcc1 pd @@ -318,7 +309,7 @@ addPermP2 tn pd permInfo = do instance (IsPerm a) => HDBQuery (CreatePerm a) where - type Phase1Res (CreatePerm a) = PermInfo a + type Phase1Res (CreatePerm a) = WithDeps (PermInfo a) phaseOne (WithTable tn pd) = do tabInfo <- createPermP1 tn diff --git a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs index 190dff51c0b0c..37e6e994afaaf 100644 --- a/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DDL/QueryTemplate.hs @@ -124,7 +124,9 @@ collectDeps qt = case qt of QTP1Bulk qp1 -> concatMap collectDeps qp1 createQueryTemplateP1 - :: (P1C m) => CreateQueryTemplate -> m QueryTemplateInfo + :: (P1C m) + => CreateQueryTemplate + -> m (WithDeps QueryTemplateInfo) createQueryTemplateP1 (CreateQueryTemplate qtn qt _) = do adminOnly ui <- askUserInfo @@ -134,7 +136,7 @@ createQueryTemplateP1 (CreateQueryTemplate qtn qt _) = do let qCtx = QCtx ui sc qtp1 <- withPathK "template" $ liftP1 qCtx $ validateTQuery qt let deps = collectDeps qtp1 - return $ QueryTemplateInfo qtn qt deps + return (QueryTemplateInfo qtn qt, deps) addQTemplateToCatalog :: CreateQueryTemplate @@ -149,15 +151,17 @@ addQTemplateToCatalog (CreateQueryTemplate qtName qtDef mComment) = createQueryTemplateP2 :: (P2C m) - => CreateQueryTemplate -> QueryTemplateInfo -> m RespBody -createQueryTemplateP2 cqt qti = do - addQTemplateToCache qti + => CreateQueryTemplate + -> WithDeps QueryTemplateInfo + -> m RespBody +createQueryTemplateP2 cqt (qti, deps) = do + addQTemplateToCache qti deps liftTx $ addQTemplateToCatalog cqt return successMsg instance HDBQuery CreateQueryTemplate where - type Phase1Res CreateQueryTemplate = QueryTemplateInfo + type Phase1Res CreateQueryTemplate = WithDeps QueryTemplateInfo phaseOne = createQueryTemplateP1 phaseTwo = createQueryTemplateP2 diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index fb07fe58d081c..6019520f440e4 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -172,13 +172,13 @@ createObjRelP1 (WithTable qt rd) = do objRelP2Setup :: (P2C m) => QualifiedTable -> RelDef ObjRelUsing -> m () objRelP2Setup qt (RelDef rn ru _) = do - relInfo <- case ru of + (relInfo, deps) <- case ru of RUManual (ObjRelManualConfig rm) -> do let refqt = rmTable rm (lCols, rCols) = unzip $ M.toList $ rmColumns rm deps = map (\c -> SchemaDependency (SOTableObj qt $ TOCol c) "lcol") lCols <> map (\c -> SchemaDependency (SOTableObj refqt $ TOCol c) "rcol") rCols - return $ RelInfo rn ObjRel (zip lCols rCols) refqt deps True + return (RelInfo rn ObjRel (zip lCols rCols) refqt True, deps) RUFKeyOn cn -> do res <- liftTx $ Q.catchE defaultTxErrorHandler $ fetchFKeyDetail cn case mapMaybe processRes res of @@ -190,10 +190,10 @@ objRelP2Setup qt (RelDef rn ru _) = do ] refqt = QualifiedTable refsn reftn void $ askTabInfo refqt - return $ RelInfo rn ObjRel colMapping refqt deps False + return (RelInfo rn ObjRel colMapping refqt False, deps) _ -> throw400 ConstraintError "more than one foreign key constraint exists on the given column" - addFldToCache (fromRel rn) (FIRelationship relInfo) qt + addFldToCache (fromRel rn) (FIRelationship relInfo) deps qt where QualifiedTable sn tn = qt fetchFKeyDetail cn = @@ -267,13 +267,13 @@ arrRelP1 tabInfo (RelDef rn ru _) = do arrRelP2Setup :: (P2C m) => QualifiedTable -> ArrRelDef -> m () arrRelP2Setup qt (RelDef rn ru _) = do - relInfo <- case ru of + (relInfo, deps) <- case ru of RUManual (ArrRelManualConfig rm) -> do let refqt = rmTable rm (lCols, rCols) = unzip $ M.toList $ rmColumns rm deps = map (\c -> SchemaDependency (SOTableObj qt $ TOCol c) "lcol") lCols <> map (\c -> SchemaDependency (SOTableObj refqt $ TOCol c) "rcol") rCols - return $ RelInfo rn ArrRel (zip lCols rCols) refqt deps True + return (RelInfo rn ArrRel (zip lCols rCols) refqt True, deps) RUFKeyOn (ArrRelUsingFKeyOn refqt refCol) -> do let QualifiedTable refSn refTn = refqt res <- liftTx $ Q.catchE defaultTxErrorHandler $ @@ -285,10 +285,10 @@ arrRelP2Setup qt (RelDef rn ru _) = do let deps = [ SchemaDependency (SOTableObj refqt $ TOCons consName) "remote_fkey" , SchemaDependency (SOTableObj refqt $ TOCol refCol) "using_col" ] - return $ RelInfo rn ArrRel (map swap mapping) refqt deps False + return (RelInfo rn ArrRel (map swap mapping) refqt False, deps) _ -> throw400 ConstraintError "more than one foreign key constraint exists on the given column" - addFldToCache (fromRel rn) (FIRelationship relInfo) qt + addFldToCache (fromRel rn) (FIRelationship relInfo) deps qt where QualifiedTable sn tn = qt fetchFKeyDetail refsn reftn refcn = Q.listQ [Q.sql| diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 048ebb74f6dfc..16471f6a55e6c 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -199,7 +200,7 @@ processTableChanges ti tableDiff = do throw400 AlreadyExists $ "cannot add column " <> colName <<> " in table " <> tn <<> " as a relationship with the name already exists" - _ -> addFldToCache (fromPGCol colName) (FIColumn colInfo) tn + _ -> addFldToCache (fromPGCol colName) (FIColumn colInfo) [] tn sc <- askSchemaCache -- for rest of the columns @@ -219,10 +220,28 @@ processTableChanges ti tableDiff = do where updateFldInCache cn ci = do delFldFromCache (fromPGCol cn) tn - addFldToCache (fromPGCol cn) ci tn + addFldToCache (fromPGCol cn) ci [] tn tn = tiName ti TableDiff mNewName droppedCols addedCols alteredCols _ = tableDiff +delTableAndDirectDeps :: (P2C m) => QualifiedTable -> m () +delTableAndDirectDeps qtn@(QualifiedTable sn tn) = do + liftTx $ Q.catchE defaultTxErrorHandler $ do + Q.unitQ [Q.sql| + DELETE FROM "hdb_catalog"."hdb_relationship" + WHERE table_schema = $1 AND table_name = $2 + |] (sn, tn) False + Q.unitQ [Q.sql| + DELETE FROM "hdb_catalog"."hdb_permission" + WHERE table_schema = $1 AND table_name = $2 + |] (sn, tn) False + Q.unitQ [Q.sql| + DELETE FROM "hdb_catalog"."event_triggers" + WHERE schema_name = $1 AND table_name = $2 + |] (sn, tn) False + delTableFromCatalog qtn + delTableFromCache qtn + processSchemaChanges :: (P2C m) => SchemaDiff -> m () processSchemaChanges schemaDiff = do -- Purge the dropped tables @@ -259,81 +278,48 @@ data UntrackTable = } deriving (Show, Eq, Lift) $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UntrackTable) -unTrackExistingTableOrViewP1 :: UntrackTable -> P1 (UntrackTable, TableInfo) -unTrackExistingTableOrViewP1 ut@(UntrackTable vn _) = do +unTrackExistingTableOrViewP1 :: UntrackTable -> P1 () +unTrackExistingTableOrViewP1 (UntrackTable vn _) = do adminOnly rawSchemaCache <- getSchemaCache <$> lift ask case M.lookup vn (scTables rawSchemaCache) of - Just ti -> do + Just ti -> -- Check if table/view is system defined when (tiSystemDefined ti) $ throw400 NotSupported $ vn <<> " is system defined, cannot untrack" - return (ut, ti) Nothing -> throw400 AlreadyUntracked $ "view/table already untracked : " <>> vn -unTrackExistingTableOrViewP2 :: (P2C m) - => UntrackTable -> TableInfo -> m RespBody -unTrackExistingTableOrViewP2 (UntrackTable vn cascade) tableInfo = do +unTrackExistingTableOrViewP2 + :: (P2C m) + => UntrackTable -> m RespBody +unTrackExistingTableOrViewP2 (UntrackTable qtn cascade) = do sc <- askSchemaCache - -- Get Foreign key constraints to this table - fKeyTables <- liftTx getFKeyTables - let fKeyDepIds = mkFKeyObjIds $ filterTables fKeyTables $ scTables sc - - -- Report back with an error if any fkey object ids are present - when (fKeyDepIds /= []) $ reportDepsExt fKeyDepIds [] - -- Get relational and query template dependants - let allRels = getAllRelations $ scTables sc - directRelDep = (vn, getRels $ tiFieldInfoMap tableInfo) - relDeps = directRelDep : foldl go [] allRels - relDepIds = concatMap mkObjIdFromRel relDeps - queryTDepIds = getDependentObjsOfQTemplateCache (SOTable vn) - (scQTemplates sc) - allDepIds = relDepIds <> queryTDepIds + let allDeps = getDependentObjs sc (SOTable qtn) + indirectDeps = filter (not . isDirectDep) allDeps -- Report bach with an error if cascade is not set - when (allDepIds /= [] && not (or cascade)) $ reportDepsExt allDepIds [] + when (indirectDeps /= [] && not (or cascade)) $ reportDepsExt indirectDeps [] -- Purge all the dependants from state - mapM_ purgeDep allDepIds + mapM_ purgeDep indirectDeps - -- update the schema cache with the changes - processSchemaChanges $ SchemaDiff [vn] [] + -- delete the table and its direct dependencies + delTableAndDirectDeps qtn return successMsg where - QualifiedTable sn tn = vn - getFKeyTables = Q.catchE defaultTxErrorHandler $ Q.listQ [Q.sql| - SELECT constraint_name, - table_schema, - table_name - FROM hdb_catalog.hdb_foreign_key_constraint - WHERE ref_table_table_schema = $1 - AND ref_table = $2 - |] (sn, tn) False - filterTables tables tc = flip filter tables $ \(_, s, t) -> - isJust $ M.lookup (QualifiedTable s t) tc - - mkFKeyObjIds tables = flip map tables $ \(cn, s, t) -> - SOTableObj (QualifiedTable s t) (TOCons cn) - - getAllRelations tc = map getRelInfo $ M.toList tc - getRelInfo (qt, ti) = (qt, getRels $ tiFieldInfoMap ti) - - go l (qt, ris) = if any isDep ris - then (qt, filter isDep ris):l - else l - isDep relInfo = vn == riRTable relInfo - mkObjIdFromRel (qt, ris) = flip map ris $ \ri -> - SOTableObj qt (TORel $ riName ri) + isDirectDep = \case + (SOTableObj dtn _) -> qtn == dtn + _ -> False instance HDBQuery UntrackTable where - type Phase1Res UntrackTable = (UntrackTable, TableInfo) + type Phase1Res UntrackTable = () phaseOne = unTrackExistingTableOrViewP1 - phaseTwo _ = uncurry unTrackExistingTableOrViewP2 + phaseTwo q _ = unTrackExistingTableOrViewP2 q schemaCachePolicy = SCPReload @@ -371,9 +357,9 @@ buildSchemaCache = flip execStateT emptySchemaCache $ do forM_ qtemplates $ \(qtn, Q.AltJ qtDefVal) -> do qtDef <- decodeValue qtDefVal qCtx <- mkAdminQCtx <$> get - qti <- liftP1 qCtx $ createQueryTemplateP1 $ + (qti, deps) <- liftP1 qCtx $ createQueryTemplateP1 $ CreateQueryTemplate qtn qtDef Nothing - addQTemplateToCache qti + addQTemplateToCache qti deps eventTriggers <- lift $ Q.catchE defaultTxErrorHandler fetchEventTriggers forM_ eventTriggers $ \(sn, tn, trid, trn, Q.AltJ tDefVal, webhook, nr, rint, Q.AltJ mheaders) -> do @@ -391,9 +377,9 @@ buildSchemaCache = flip execStateT emptySchemaCache $ do let qt = QualifiedTable sn tn permDef = PermDef rn perm Nothing createPerm = WithTable qt permDef - p1Res <- liftP1 qCtx $ phaseOne createPerm - addPermP2Setup qt permDef p1Res - addPermToCache qt rn pa p1Res + (permInfo, deps) <- liftP1 qCtx $ phaseOne createPerm + addPermP2Setup qt permDef permInfo + addPermToCache qt rn pa permInfo deps -- p2F qt rn p1Res fetchTables = diff --git a/server/src-lib/Hasura/RQL/DML/Count.hs b/server/src-lib/Hasura/RQL/DML/Count.hs index a95a543e61dfd..722713b481244 100644 --- a/server/src-lib/Hasura/RQL/DML/Count.hs +++ b/server/src-lib/Hasura/RQL/DML/Count.hs @@ -23,7 +23,7 @@ import qualified Hasura.SQL.DML as S data CountQueryP1 = CountQueryP1 { cqp1Table :: !QualifiedTable - , cqp1Where :: !(S.BoolExp, Maybe (GBoolExp AnnSQLBoolExp)) + , cqp1Where :: !(AnnBoolExpSQL, Maybe AnnBoolExpSQL) , cqp1Distinct :: !(Maybe [PGCol]) } deriving (Show, Eq) @@ -48,8 +48,8 @@ mkSQLCount (CountQueryP1 tn (permFltr, mWc) mDistCols) = where finalWC = - S.BEBin S.AndOp permFltr $ - maybe (S.BELit True) cBoolExp mWc + toSQLBoolExp (S.QualTable tn) $ + maybe permFltr (andAnnBoolExps permFltr) mWc innerSel = partSel { S.selFrom = Just $ S.mkSimpleFromExp tn @@ -90,7 +90,7 @@ countP1 prepValBuilder (CountQuery qt mDistCols mWhere) = do -- convert the where clause annSQLBoolExp <- forM mWhere $ \be -> withPathK "where" $ - convBoolExp' colInfoMap qt selPerm be prepValBuilder + convBoolExp' colInfoMap selPerm be prepValBuilder return $ CountQueryP1 qt @@ -105,7 +105,8 @@ countP1 prepValBuilder (CountQuery qt mDistCols mWhere) = do countP2 :: (P2C m) => (CountQueryP1, DS.Seq Q.PrepArg) -> m RespBody countP2 (u, p) = do - qRes <- liftTx $ Q.rawQE dmlTxErrorHandler (Q.fromBuilder countSQL) (toList p) True + qRes <- liftTx $ Q.rawQE dmlTxErrorHandler + (Q.fromBuilder countSQL) (toList p) True return $ BB.toLazyByteString $ encodeCount qRes where countSQL = toSQL $ mkSQLCount u diff --git a/server/src-lib/Hasura/RQL/DML/Delete.hs b/server/src-lib/Hasura/RQL/DML/Delete.hs index d2c46e4a1e9cf..b08ea0efc0325 100644 --- a/server/src-lib/Hasura/RQL/DML/Delete.hs +++ b/server/src-lib/Hasura/RQL/DML/Delete.hs @@ -23,7 +23,7 @@ import qualified Hasura.SQL.DML as S data DeleteQueryP1 = DeleteQueryP1 { dqp1Table :: !QualifiedTable - , dqp1Where :: !(S.BoolExp, GBoolExp AnnSQLBoolExp) + , dqp1Where :: !(AnnBoolExpSQL, AnnBoolExpSQL) , dqp1MutFlds :: !MutFlds } deriving (Show, Eq) @@ -33,7 +33,8 @@ mkSQLDelete (DeleteQueryP1 tn (fltr, wc) mutFlds) = mkSelWith tn (S.CTEDelete delete) mutFlds where delete = S.SQLDelete tn Nothing tableFltr $ Just S.returningStar - tableFltr = Just $ S.WhereFrag $ S.BEBin S.AndOp fltr $ cBoolExp wc + tableFltr = Just $ S.WhereFrag $ + toSQLBoolExp (S.QualTable tn) $ andAnnBoolExps fltr wc getDeleteDeps :: DeleteQueryP1 -> [SchemaDependency] @@ -74,7 +75,7 @@ convDeleteQuery prepValBuilder (DeleteQuery tableName rqlBE mRetCols) = do -- convert the where clause annSQLBoolExp <- withPathK "where" $ - convBoolExp' fieldInfoMap tableName selPerm rqlBE prepValBuilder + convBoolExp' fieldInfoMap selPerm rqlBE prepValBuilder return $ DeleteQueryP1 tableName (dpiFilter delPerm, annSQLBoolExp) diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index 6aa598e592b9f..aceaafbe69537 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -55,10 +55,11 @@ mkAdminRolePermInfo ti = . map fieldInfoToEither . M.elems $ tiFieldInfoMap ti tn = tiName ti - i = InsPermInfo tn (S.BELit True) True M.empty [] [] - s = SelPermInfo (HS.fromList pgCols) tn (S.BELit True) Nothing True [] [] - u = UpdPermInfo (HS.fromList pgCols) tn (S.BELit True) [] [] - d = DelPermInfo tn (S.BELit True) [] [] + i = InsPermInfo tn annBoolExpTrue True M.empty [] + s = SelPermInfo (HS.fromList pgCols) tn annBoolExpTrue + Nothing True [] + u = UpdPermInfo (HS.fromList pgCols) tn annBoolExpTrue [] + d = DelPermInfo tn annBoolExpTrue [] askPermInfo' :: (P1C m) @@ -178,47 +179,50 @@ fetchRelDet relName refTabName = do , " table " <>> rTable ] -checkOnColExp :: (P1C m) - => SelPermInfo -> AnnValS -> m AnnValS -checkOnColExp spi annVal = - case annVal of - AVCol pci@(PGColInfo cn _ _) opExps -> do - checkSelOnCol spi cn - return $ AVCol pci opExps - AVRel relInfo nesAnn _ -> do - relSPI <- snd <$> fetchRelDet (riName relInfo) (riRTable relInfo) - modAnn <- checkSelPerm relSPI nesAnn - return $ AVRel relInfo modAnn $ spiFilter relSPI - -checkSelPerm :: (P1C m) - => SelPermInfo -> GBoolExp AnnValS -> m (GBoolExp AnnValS) -checkSelPerm spi = mapBoolExp (checkOnColExp spi) - -convBoolExp +checkOnColExp :: (P1C m) - => FieldInfoMap - -> QualifiedTable - -> SelPermInfo - -> BoolExp - -> (PGColType -> Value -> m S.SQLExp) - -> m S.BoolExp -convBoolExp cim tn spi be prepValBuilder = - cBoolExp <$> convBoolExp' cim tn spi be prepValBuilder + => SelPermInfo + -> AnnBoolExpFldSQL + -> m AnnBoolExpFldSQL +checkOnColExp spi annFld = case annFld of + AVCol (PGColInfo cn _ _) _ -> do + checkSelOnCol spi cn + return annFld + AVRel relInfo nesAnn -> do + relSPI <- snd <$> fetchRelDet (riName relInfo) (riRTable relInfo) + modAnn <- checkSelPerm relSPI nesAnn + return $ AVRel relInfo $ + andAnnBoolExps modAnn $ spiFilter relSPI + +checkSelPerm + :: (P1C m) + => SelPermInfo + -> AnnBoolExpSQL + -> m AnnBoolExpSQL +checkSelPerm spi = + traverse (checkOnColExp spi) + +-- convBoolExp +-- :: (P1C m) +-- => FieldInfoMap +-- -> QualifiedTable +-- -> SelPermInfo +-- -> BoolExp +-- -> (PGColType -> Value -> m S.SQLExp) +-- -> m S.BoolExp +-- convBoolExp cim tn spi be prepValBuilder = +-- cBoolExp <$> convBoolExp' cim tn spi be prepValBuilder convBoolExp' :: (P1C m) => FieldInfoMap - -> QualifiedTable -> SelPermInfo -> BoolExp -> (PGColType -> Value -> m S.SQLExp) - -> m (GBoolExp AnnSQLBoolExp) -convBoolExp' cim tn spi be prepValBuilder = do + -> m AnnBoolExpSQL +convBoolExp' cim spi be prepValBuilder = do abe <- annBoolExp prepValBuilder cim be - modABE <- checkSelPerm spi abe - convBoolRhs binStrat (S.mkQual tn) modABE - where - binStrat = mkBoolExpBuilder return + checkSelPerm spi abe dmlTxErrorHandler :: Q.PGTxErr -> QErr dmlTxErrorHandler p2Res = diff --git a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs index e6403e5afd167..b9b28b9407be1 100644 --- a/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs +++ b/server/src-lib/Hasura/RQL/DML/QueryTemplate.hs @@ -125,7 +125,7 @@ convQT args qt = case qt of execQueryTemplateP1 :: ExecQueryTemplate -> P1 QueryTProc execQueryTemplateP1 (ExecQueryTemplate qtn args) = do - (QueryTemplateInfo _ qt _) <- askQTemplateInfo qtn + (QueryTemplateInfo _ qt) <- askQTemplateInfo qtn convQT args qt execQueryTP2 :: (P2C m) => QueryTProc -> m RespBody diff --git a/server/src-lib/Hasura/RQL/DML/Returning.hs b/server/src-lib/Hasura/RQL/DML/Returning.hs index 51e8f2a3fb1b3..b42f579118e3b 100644 --- a/server/src-lib/Hasura/RQL/DML/Returning.hs +++ b/server/src-lib/Hasura/RQL/DML/Returning.hs @@ -38,11 +38,10 @@ pgColsToSelData qt cols = AnnSel selFlds tabFrom tabPerm noTableArgs where selFlds = ASFSimple flds - tabFrom = TableFrom qt $ Just frmItem - tabPerm = TablePerm (S.BELit True) Nothing + tabFrom = TableFrom $ Right $ qualTableToAliasIden qt + tabPerm = TablePerm annBoolExpTrue Nothing flds = flip map cols $ \pgColInfo -> (fromPGCol $ pgiName pgColInfo, FCol pgColInfo) - frmItem = S.FIIden $ qualTableToAliasIden qt pgColsFromMutFlds :: MutFlds -> [(PGCol, PGColType)] pgColsFromMutFlds = concatMap (pgColsFromMutFld . snd) diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index 7f99b60e972ae..1e8a559a0d9e1 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -67,17 +67,17 @@ data AnnRel , arType :: !RelType -- Relationship type (ObjRel, ArrRel) , arMapping :: ![(PGCol, PGCol)] -- Column of the left table to join with , arAnnSel :: !AnnSel -- Current table. Almost ~ to SQL Select - } deriving (Show, Eq) + } deriving (Eq, Show) data AnnFld = FCol !PGColInfo | FExp !T.Text | FRel !AnnRel - deriving (Show, Eq) + deriving (Eq, Show) data TableArgs = TableArgs - { _taWhere :: !(Maybe (GBoolExp AnnSQLBoolExp)) + { _taWhere :: !(Maybe AnnBoolExpSQL) , _taOrderBy :: !(Maybe (NE.NonEmpty AnnOrderByItem)) , _taLimit :: !(Maybe Int) , _taOffset :: !(Maybe S.SQLExp) @@ -108,12 +108,12 @@ data TableAggFld = TAFAgg !AggFlds | TAFNodes ![(FieldName, AnnFld)] | TAFExp !T.Text - deriving (Show, Eq) + deriving (Eq, Show) data AnnSelFields = ASFSimple ![(FieldName, AnnFld)] | ASFWithAgg ![(T.Text, TableAggFld)] - deriving (Show, Eq) + deriving (Eq, Show) fetchAnnFlds :: AnnSelFields -> [(FieldName, AnnFld)] fetchAnnFlds (ASFSimple flds) = flds @@ -125,15 +125,24 @@ fetchAnnFlds (ASFWithAgg aggFlds) = data TableFrom = TableFrom - { _tfTable :: !QualifiedTable - , _tfFrom :: !(Maybe S.FromItem) + { _tfTable :: !(Either QualifiedTable Iden) } deriving (Show, Eq) +tableFromToFromItem :: TableFrom -> S.FromItem +tableFromToFromItem (TableFrom tf) = case tf of + Left t -> S.FISimple t Nothing + Right i -> S.FIIden i + +tableFromToQual :: TableFrom -> S.Qual +tableFromToQual (TableFrom tf) = case tf of + Left t -> S.QualTable t + Right i -> S.QualIden i + data TablePerm = TablePerm - { _tpFilter :: !S.BoolExp + { _tpFilter :: !AnnBoolExpSQL , _tpLimit :: !(Maybe Int) - } deriving (Show, Eq) + } deriving (Eq, Show) data AnnSel = AnnSel @@ -141,7 +150,7 @@ data AnnSel , _asnFrom :: !TableFrom , _asnPerm :: !TablePerm , _asnArgs :: !TableArgs - } deriving (Show, Eq) + } deriving (Eq, Show) data BaseNode = BaseNode @@ -381,12 +390,13 @@ processAnnOrderByCol pfx = \case , Nothing ) -- "pfx.or.relname"."pfx.ob.or.relname.rest" AS "pfx.ob.or.relname.rest" - AOCRel (RelInfo rn _ colMapping relTab _ _) relFltr rest -> + AOCRel (RelInfo rn _ colMapping relTab _) relFltr rest -> let relPfx = mkObjRelTableAls pfx rn ((nesAls, nesCol), nesNodeM) = processAnnOrderByCol relPfx rest qualCol = S.mkQIdenExp relPfx nesAls relBaseNode = ANSimple $ - BaseNode relPfx (S.FISimple relTab Nothing) relFltr + BaseNode relPfx (S.FISimple relTab Nothing) + (toSQLBoolExp (S.QualTable relTab) relFltr) Nothing Nothing Nothing (HM.singleton nesAls nesCol) (maybe HM.empty (uncurry HM.singleton) nesNodeM) @@ -402,8 +412,7 @@ mkEmptyBaseNode pfx tableFrom = selOne HM.empty HM.empty where selOne = HM.singleton (S.Alias $ pfx <> Iden "__one") (S.SEUnsafe "1") - TableFrom tn fromItemM = tableFrom - fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM + fromItem = tableFromToFromItem tableFrom mkBaseNode :: Iden @@ -417,7 +426,6 @@ mkBaseNode pfx fldAls annSelFlds tableFrom tablePerm tableArgs = BaseNode pfx fromItem finalWhere ordByExpM finalLimit offsetM allExtrs allObjsWithOb allArrs where - TableFrom tn fromItemM = tableFrom TablePerm fltr permLimitM = tablePerm TableArgs whereM orderByM limitM offsetM = tableArgs (allExtrs, allObjsWithOb, allArrs) = case annSelFlds of @@ -457,10 +465,13 @@ mkBaseNode pfx fldAls annSelFlds tableFrom tablePerm tableArgs = in Just (S.Alias colAls, qualCol) mkColExp _ = Nothing - finalWhere = maybe fltr (S.BEBin S.AndOp fltr . cBoolExp) whereM + finalWhere = + toSQLBoolExp tableQual $ maybe fltr (andAnnBoolExps fltr) whereM + finalLimit = applyPermLimit permLimitM limitM - fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM + fromItem = tableFromToFromItem tableFrom + tableQual = tableFromToQual tableFrom _1 (a, _, _) = a _2 (_, b, _) = b @@ -626,7 +637,7 @@ convSelCol fieldInfoMap _ (SCExtRel rn malias selQ) = do let pgWhenRelErr = "only relationships can be expanded" relInfo <- withPathK "name" $ askRelType fieldInfoMap rn pgWhenRelErr - let (RelInfo _ _ _ relTab _ _) = relInfo + let (RelInfo _ _ _ relTab _) = relInfo (rfim, rspi) <- fetchRelDet rn relTab resolvedSelQ <- resolveStar rfim rspi selQ return [ECRel rn malias resolvedSelQ] @@ -639,7 +650,7 @@ convWildcard -> SelPermInfo -> Wildcard -> m [ExtCol] -convWildcard fieldInfoMap (SelPermInfo cols _ _ _ _ _ _) wildcard = +convWildcard fieldInfoMap (SelPermInfo cols _ _ _ _ _) wildcard = case wildcard of Star -> return simpleCols (StarDot wc) -> (simpleCols ++) <$> (catMaybes <$> relExtCols wc) @@ -689,7 +700,7 @@ resolveStar fim spi (SelectG selCols mWh mOb mLt mOf) = do data AnnObCol = AOCPG !PGColInfo - | AOCRel !RelInfo !S.BoolExp !AnnObCol + | AOCRel !RelInfo !AnnBoolExpSQL !AnnObCol deriving (Show, Eq) type AnnOrderByItem = OrderByItemG AnnObCol @@ -772,12 +783,12 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do annRel <- convExtRel fieldInfoMap relName mAlias relSelQ prepValBuilder return (fromRel $ fromMaybe relName mAlias, FRel annRel) - let spiT = spiTable selPermInfo + -- let spiT = spiTable selPermInfo -- Convert where clause wClause <- forM (sqWhere selQ) $ \be -> withPathK "where" $ - convBoolExp' fieldInfoMap spiT selPermInfo be prepValBuilder + convBoolExp' fieldInfoMap selPermInfo be prepValBuilder annOrdByML <- forM (sqOrderBy selQ) $ \(OrderByExp obItems) -> withPathK "order_by" $ indexedForM obItems $ mapM $ @@ -790,7 +801,7 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do withPathK "offset" $ mapM_ onlyPositiveInt mQueryOffset let selFlds = ASFSimple annFlds - tabFrom = TableFrom (spiTable selPermInfo) Nothing + tabFrom = TableFrom $ Left (spiTable selPermInfo) tabPerm = TablePerm (spiFilter selPermInfo) mPermLimit return $ AnnSel selFlds tabFrom tabPerm $ TableArgs wClause annOrdByM mQueryLimit (S.intToSQLExp <$> mQueryOffset) @@ -824,7 +835,7 @@ convExtRel fieldInfoMap relName mAlias selQ prepValBuilder = do -- Point to the name key relInfo <- withPathK "name" $ askRelType fieldInfoMap relName pgWhenRelErr - let (RelInfo _ relTy colMapping relTab _ _) = relInfo + let (RelInfo _ relTy colMapping relTab _) = relInfo (relCIM, relSPI) <- fetchRelDet relName relTab when (relTy == ObjRel && misused) $ throw400 UnexpectedPayload objRelMisuseMsg @@ -854,20 +865,23 @@ getSelectDeps :: AnnSel -> [SchemaDependency] getSelectDeps (AnnSel flds tabFrm _ tableArgs) = - mkParentDep tn - : fromMaybe [] whereDeps - <> colDeps - <> relDeps - <> nestedDeps + case tabFrm of + TableFrom (Left tn) -> + mkParentDep tn + : fromMaybe [] (whereDeps tn) + <> colDeps tn + <> relDeps tn + <> nestedDeps + TableFrom (Right _) -> [] where - TableFrom tn _ = tabFrm + -- TableFrom tn _ = tabFrm annWc = _taWhere tableArgs (sCols, rCols) = partAnnFlds $ map snd $ fetchAnnFlds flds - colDeps = map (mkColDep "untyped" tn . fst) sCols - relDeps = map (mkRelDep . arName) rCols - nestedDeps = concatMap (getSelectDeps . arAnnSel) rCols - whereDeps = getBoolExpDeps tn <$> annWc - mkRelDep rn = + colDeps tn = map (mkColDep "untyped" tn . fst) sCols + relDeps tn = map (mkRelDep tn . arName) rCols + nestedDeps = concatMap (getSelectDeps . arAnnSel) rCols + whereDeps tn = getBoolExpDeps tn <$> annWc + mkRelDep tn rn = SchemaDependency (SOTableObj tn (TORel rn)) "untyped" convSelectQuery diff --git a/server/src-lib/Hasura/RQL/DML/Update.hs b/server/src-lib/Hasura/RQL/DML/Update.hs index 3574cb6fc2487..e094834e39aa9 100644 --- a/server/src-lib/Hasura/RQL/DML/Update.hs +++ b/server/src-lib/Hasura/RQL/DML/Update.hs @@ -26,7 +26,7 @@ data UpdateQueryP1 = UpdateQueryP1 { uqp1Table :: !QualifiedTable , uqp1SetExps :: ![(PGCol, S.SQLExp)] - , uqp1Where :: !(S.BoolExp, GBoolExp AnnSQLBoolExp) + , uqp1Where :: !(AnnBoolExpSQL, AnnBoolExpSQL) , pqp1MutFlds :: !MutFlds } deriving (Show, Eq) @@ -37,7 +37,8 @@ mkSQLUpdate (UpdateQueryP1 tn setExps (permFltr, wc) mutFlds) = where update = S.SQLUpdate tn setExp Nothing tableFltr $ Just S.returningStar setExp = S.SetExp $ map S.SetExpItem setExps - tableFltr = Just $ S.WhereFrag $ S.BEBin S.AndOp permFltr $ cBoolExp wc + tableFltr = Just $ S.WhereFrag $ + toSQLBoolExp (S.QualTable tn) $ andAnnBoolExps permFltr wc getUpdateDeps :: UpdateQueryP1 @@ -147,14 +148,13 @@ convUpdateQuery f uq = do withPathK "returning" $ checkRetCols fieldInfoMap selPerm retCols let setExpItems = setItems ++ incItems ++ mulItems ++ defItems - updTable = upiTable updPerm when (null setExpItems) $ throw400 UnexpectedPayload "atleast one of $set, $inc, $mul has to be present" -- convert the where clause annSQLBoolExp <- withPathK "where" $ - convBoolExp' fieldInfoMap updTable selPerm (uqWhere uq) f + convBoolExp' fieldInfoMap selPerm (uqWhere uq) f return $ UpdateQueryP1 tableName diff --git a/server/src-lib/Hasura/RQL/GBoolExp.hs b/server/src-lib/Hasura/RQL/GBoolExp.hs index 0f6455abc8096..4818ee2acba09 100644 --- a/server/src-lib/Hasura/RQL/GBoolExp.hs +++ b/server/src-lib/Hasura/RQL/GBoolExp.hs @@ -6,7 +6,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -module Hasura.RQL.GBoolExp where +module Hasura.RQL.GBoolExp + ( toSQLBoolExp + , getBoolExpDeps + , annBoolExp + , txtRHSBuilder + , pgValParser + ) where import Hasura.Prelude import Hasura.RQL.Types @@ -20,221 +26,120 @@ 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 +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 - | ALIKE !a -- LIKE - | ANLIKE !a -- NOT LIKE + "$ne" -> parseNe + "_ne" -> parseNe + "$neq" -> parseNe + "_neq" -> parseNe - | AILIKE !a -- ILIKE, case insensitive - | ANILIKE !a-- NOT ILIKE, case insensitive + "$in" -> parseIn + "_in" -> parseIn - | ASIMILAR !a -- similar, regex - | ANSIMILAR !a-- not similar, regex + "$nin" -> parseNin + "_nin" -> parseNin - | AContains !a - | AContainedIn !a - | AHasKey !a - | AHasKeysAny [Text] - | AHasKeysAll [Text] + "$gt" -> parseGt + "_gt" -> parseGt - | ANISNULL -- IS NULL - | ANISNOTNULL -- IS NOT NULL + "$lt" -> parseLt + "_lt" -> parseLt - deriving (Eq, Show) + "$gte" -> parseGte + "_gte" -> parseGte -data OpExpG a - = OEVal !(AnnValOpExpG a) - | OECol !ColOp !PGCol - deriving (Show, Eq) + "$lte" -> parseLte + "_lte" -> parseLte -type OpExpJ = OpExpG Value -type OpExp = OpExpG (PGColType, PGColValue) + "$like" -> parseLike + "_like" -> parseLike -data AnnValG a - = AVCol !PGColInfo !a - | AVRel !RelInfo !(GBoolExp (AnnValG a)) S.BoolExp - deriving (Show, Eq) + "$nlike" -> parseNlike + "_nlike" -> parseNlike -type AnnValS = AnnValG [OpExpG S.SQLExp] -type AnnValO a = AnnValG [OpExpG a] -type AnnVal = AnnValO (PGColType, PGColValue) + "$ilike" -> parseIlike + "_ilike" -> parseIlike -type AnnValJ = AnnValG [OpExpJ] + "$nilike" -> parseNilike + "_nilike" -> parseNilike -type AnnSQLBoolExp = AnnValG S.BoolExp + "$similar" -> parseSimilar + "_similar" -> parseSimilar + "$nsimilar" -> parseNsimilar + "_nsimilar" -> parseNsimilar -data ColOp - = CEQ - | CNE - | CGT - | CLT - | CGTE - | CLTE - deriving (Eq) + "$is_null" -> parseIsNull + "_is_null" -> parseIsNull -instance Show ColOp where - show CEQ = "$ceq" - show CNE = "$cne" + "$ceq" -> parseCeq + "_ceq" -> parseCeq - show CGT = "$cgt" - show CLT = "$clt" - show CGTE = "$cgte" - show CLTE = "$clte" + "$cne" -> parseCne + "_cne" -> parseCne + "$cneq" -> parseCne + "_cneq" -> parseCne -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 - - | RISNULL -- is null - - 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" - - show RISNULL = "$is_null" - -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 - - "$is_null" -> return $ Left RISNULL - "_is_null" -> return $ Left RISNULL - - "$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 + "$cgt" -> parseCgt + "_cgt" -> parseCgt - x -> throw400 UnexpectedPayload $ "Unknown operator : " <> x + "$clt" -> parseClt + "_clt" -> parseClt -isRQLOp :: T.Text -> Bool -isRQLOp t = case runIdentity . runExceptT $ parseOp t of - Left _ -> False - Right r -> either (const True) (const False) r + "$cgte" -> parseCgte + "_cgte" -> parseCgte -type ValueParser m a = PGColType -> Value -> m a + "$clte" -> parseClte + "_clte" -> parseClte -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 - RISNULL -> bool ANISNOTNULL ANISNULL -- is null - <$> decodeValue val + x -> throw400 UnexpectedPayload $ "Unknown operator : " <> x where - parseOne = parser ty val + 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 = ALIKE <$> parseOne -- LIKE + parseNlike = ANLIKE <$> parseOne -- NOT LIKE + parseIlike = AILIKE <$> parseOne -- ILIKE, case insensitive + parseNilike = ANILIKE <$> parseOne -- NOT ILIKE, case insensitive + parseSimilar = ASIMILAR <$> parseOne -- similar, regex + parseNsimilar = ANSIMILAR <$> parseOne -- not similar, regex + 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 -- runAesonParser (parsePGValue ty) val parseMany = do vals <- runAesonParser parseJSON val - indexedForM vals (parser ty) + indexedForM vals (parser colTy) parseOpExps :: (MonadError QErr m) @@ -243,27 +148,73 @@ parseOpExps -> 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] +parseOpExps valParser cim colInfo = \case + (Object o) -> mapM (parseOpExp valParser cim colInfo)(M.toList o) + val -> pure . AEQ <$> valParser (pgiType colInfo) val + +-- 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 +-- RISNULL -> bool ANISNOTNULL ANISNULL -- is null +-- <$> decodeValue val + -- where + -- parseOne = parser ty val + -- -- runAesonParser (parsePGValue ty) val + -- parseMany = do + -- vals <- runAesonParser parseJSON val + -- indexedForM vals (parser ty) + +-- isRQLOp :: T.Text -> Bool +-- isRQLOp t = case runIdentity . runExceptT $ parseOpExp t of +-- Left _ -> False +-- Right r -> either (const True) (const False) r + +type ValueParser m a = PGColType -> Value -> m a + +-- 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 <- parseOpExp 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 rhsCol = PGCol c +-- errMsg = "column operators can only compare postgres columns" +-- rhsType <- askPGType cim rhsCol errMsg +-- when (colTy /= rhsType) $ +-- throw400 UnexpectedPayload $ +-- "incompatible column types : " <> cn <<> ", " <>> rhsCol +-- return $ OECol colOp rhsCol +-- (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 = @@ -282,25 +233,25 @@ 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 -getOpTypeChecker RISNULL = validOnAllTypes +-- 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 +-- getOpTypeChecker RISNULL = validOnAllTypes -- This convoluted expression instead of col = val -- to handle the case of col : null @@ -318,32 +269,34 @@ notEqualsBoolExpBuilder qualColExp rhsExp = (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 +-- 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 (BoolFld ce) = BoolFld <$> 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 + -> BoolExp + -> m (AnnBoolExp a) +annBoolExp valParser fim (BoolExp boolExp) = + traverse (annColExp valParser fim) boolExp +-- annBoolExp valParser cim = \case +-- (BoolAnd bes) -> BoolAnd <$> mapM (annBoolExp valParser cim) bes +-- (BoolOr bes) -> BoolOr <$> mapM (annBoolExp valParser cim) bes +-- (BoolFld ce) -> BoolFld <$> 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]) + -> m (AnnBoolExpFld a) annColExp valueParser colInfoMap (ColExp fieldName colVal) = do colInfo <- askFieldInfo colInfoMap fieldName case colInfo of @@ -357,58 +310,116 @@ annColExp valueParser colInfoMap (ColExp fieldName colVal) = do relBoolExp <- decodeValue colVal relFieldInfoMap <- askFieldInfoMap $ riRTable relInfo annRelBoolExp <- annBoolExp valueParser relFieldInfoMap relBoolExp - return $ AVRel relInfo annRelBoolExp $ S.BELit True + return $ AVRel relInfo annRelBoolExp -type BoolExpBuilder m a = S.SQLExp -> AnnValOpExpG a -> m S.BoolExp +-- toSQLBoolExp +-- :: (Monad m) +-- => BoolExpBuilder m a -> S.Qual +-- -> GBoolExp (AnnValO a) -> m S.BoolExp +-- toSQLBoolExp vp tq e = +-- evalStateT (convBoolRhs' vp tq e) 0 -convBoolRhs - :: (Monad m) - => BoolExpBuilder m a -> S.Qual - -> GBoolExp (AnnValO a) -> m (GBoolExp AnnSQLBoolExp) -convBoolRhs vp tq = - traverse (convColRhs vp tq ) +-- convBoolRhs' +-- :: (Monad m) +-- => BoolExpBuilder m a -> S.Qual +-- -> GBoolExp (AnnValO a) -> StateT Word64 m S.BoolExp +-- convBoolRhs' vp tq = +-- foldBoolExp (convColRhs vp tq) + +-- convColRhs +-- :: (Monad m) +-- => BoolExpBuilder m a +-- -> S.Qual -> AnnValO a -> StateT Word64 m S.BoolExp +-- convColRhs bExpBuilder tableQual annVal = case annVal of +-- AVCol (PGColInfo cn _ _) opExps -> do +-- let qualColExp = mkQCol tableQual cn +-- -- bExps <- forM opExps $ \case +-- -- OEVal annOpValExp -> lift $ bExpBuilder qualColExp annOpValExp +-- -- OECol op rCol -> do +-- -- let rhsColExp = mkQCol tableQual rCol +-- -- return $ mkColOpSQLExp op qualColExp rhsColExp +-- bExps <- forM opExps $ \opExp -> +-- lift $ bExpBuilder tableQual qualColExp annOpValExp +-- 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' bExpBuilder (Just newIdenQ) nesAnn +-- let backCompExp = foldr (S.BEBin S.AndOp) (S.BELit True) $ +-- flip map colMapping $ \(lCol, rCol) -> +-- S.BECompare S.SEQ +-- (S.SEQIden $ S.QIden (S.QualIden newIden) (toIden rCol)) +-- (mkQCol tableQual lCol) +-- innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp +-- -- return $ ABERel rn (relTN, newIden) annRelBoolExp backCompExp +-- return $ S.mkExists (S.FISimple relTN $ Just $ S.Alias newIden) innerBoolExp +-- where +-- mkQCol colQM col = case colQM of +-- Just colQ -> S.SEQIden $ S.QIden colQ $ toIden col +-- Nothing -> S.SEIden $ toIden col + +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 - :: (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 + :: 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 - annRelBoolExp <- convBoolRhs bExpBuilder (S.mkQual relTN) nesAnn - let backCompExp = foldr (S.BEBin S.AndOp) (S.BELit True) $ + 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 (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 + S.BECompare S.SEQ + (mkQCol (S.QualIden newIden) rCol) + (mkQCol tableQual lCol) innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp - S.mkExists relTN innerBoolExp + -- return $ ABERel rn (relTN, newIden) annRelBoolExp backCompExp + return $ S.mkExists (S.FISimple relTN $ Just $ S.Alias newIden) innerBoolExp + where + mkQCol q = S.SEQIden . S.QIden q . toIden + + -- mkQCol colQM col = case colQM of + -- Just colQ -> S.SEQIden $ S.QIden colQ $ toIden col + -- Nothing -> S.SEIden $ toIden col + +-- cBoolExp +-- :: GBoolExp AnnSQLBoolExp +-- -> S.BoolExp +-- cBoolExp be = +-- runIdentity $ flip foldBoolExp be $ \ace -> +-- return $ cColExp ace + +-- cColExp +-- :: AnnSQLBoolExp +-- -> S.BoolExp +-- cColExp annVal = case annVal of +-- ABECol _ be -> be +-- ABERel _ (tn, tIden) nesAnn backCompExp -> do +-- -- Convert the where clause on the relationship +-- let annRelBoolExp = cBoolExp nesAnn +-- innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp +-- S.mkExists (S.FISimple tn $ Just $ S.Alias tIden) innerBoolExp inBoolExpBuilder :: S.SQLExp -> [S.SQLExp] -> S.BoolExp inBoolExpBuilder qualColExp rhsExps = @@ -416,12 +427,6 @@ inBoolExpBuilder qualColExp rhsExps = 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 @@ -440,77 +445,117 @@ noValParser => 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 +-- 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 -> 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 +-- CEQ rhsCol -> return $ S.BECompare S.SEQ lhs rhsCol +-- CNE rhsCol -> return $ S.BECompare S.SNE lhs rhsCol +-- CGT rhsCol -> return $ S.BECompare S.SGT lhs rhsCol +-- CLT rhsCol -> return $ S.BECompare S.SLT lhs rhsCol +-- CGTE rhsCol -> return $ S.BECompare S.SGTE lhs rhsCol +-- CLTE rhsCol -> return $ S.BECompare S.SLTE lhs rhsCol +-- where +-- lhs = undefined + +-- 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 +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 -> 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 + 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 - mkSimpleBoolExpBuilder beF pgColVal = - beF lhs <$> rhsBldr pgColVal + -- mkSimpleBoolExpBuilder beF pgColVal = + -- beF lhs <$> rhsBldr pgColVal - mkInOrNotBoolExpBuilder isIn arrVals = do - rhsExps <- mapM rhsBldr arrVals + mkInOrNotBoolExpBuilder isIn rhsExps = let boolExp = inBoolExpBuilder lhs rhsExps - return $ bool (S.BENot boolExp) boolExp isIn + in 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 +-- 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 -> 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) [] diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index 78e8b899382c2..4be2d438b131d 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -48,6 +48,7 @@ module Hasura.RQL.Types ) where import Hasura.Prelude +import Hasura.RQL.Types.BoolExp as R import Hasura.RQL.Types.Common as R import Hasura.RQL.Types.DML as R import Hasura.RQL.Types.Error as R @@ -117,7 +118,7 @@ data QCtx = QCtx { qcUserInfo :: !UserInfo , qcSchemaCache :: !SchemaCache - } deriving (Show, Eq) + } deriving (Show) class HasQCtx a where getQCtx :: a -> QCtx diff --git a/server/src-lib/Hasura/RQL/Types/BoolExp.hs b/server/src-lib/Hasura/RQL/Types/BoolExp.hs new file mode 100644 index 0000000000000..b091c1504f927 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/BoolExp.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hasura.RQL.Types.BoolExp + ( GBoolExp(..) + , gBoolExpTrue + , gBoolExpToJSON + , parseGBoolExp + + , OpExpG(..) + + , AnnBoolExpFld(..) + , AnnBoolExp + -- , traverseAnnBoolExp + , annBoolExpTrue + , andAnnBoolExps + + , AnnBoolExpFldSQL + , AnnBoolExpSQL + , foldBoolExp + ) where + +import Hasura.Prelude +import Hasura.RQL.Types.Common +import qualified Hasura.SQL.DML as S +import Hasura.SQL.Types +-- import Hasura.SQL.Value + +import Data.Aeson +-- import Data.Aeson.TH +-- import Data.Aeson.Casing +import Data.Aeson.Internal +import qualified Data.Aeson.Types as J +import qualified Data.HashMap.Strict as M +-- import qualified Data.Text.Extended as T +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift) + +data GBoolExp a + = BoolAnd ![GBoolExp a] + | BoolOr ![GBoolExp a] + | BoolNot !(GBoolExp a) + | BoolFld !a + deriving (Show, Eq, Lift, Functor, Foldable, Traversable) + +gBoolExpTrue :: GBoolExp a +gBoolExpTrue = BoolAnd [] + +gBoolExpToJSON :: (a -> (Text, Value)) -> GBoolExp a -> Value +gBoolExpToJSON f = \case + BoolAnd bExps -> object ["$and" .= map (gBoolExpToJSON f) bExps ] + BoolOr bExps -> object ["$or" .= map (gBoolExpToJSON f) bExps ] + BoolNot bExp -> object ["$not" .= gBoolExpToJSON f bExp ] + BoolFld a -> object $ pure $ f a + +-- instance ToJSON (GBoolExp ColExp) where +-- toJSON (BoolAnd bExps) = +-- object $ flip map bExps $ \case +-- BoolOr cbExps -> "$or" .= cbExps +-- BoolAnd cbExps -> "$and" .= cbExps +-- BoolFld (ColExp k v) -> getFieldNameTxt k .= v +-- BoolNot notExp -> "$not" .= notExp +-- toJSON (BoolOr bExps) = +-- object $ flip map bExps $ \case +-- BoolOr cbExps -> "$or" .= cbExps +-- BoolAnd cbExps -> "$and" .= cbExps +-- BoolFld (ColExp k v) -> getFieldNameTxt k .= v +-- BoolNot notExp -> "$not" .= notExp +-- toJSON (BoolFld (ColExp k v)) = +-- object [ getFieldNameTxt k .= v ] +-- toJSON (BoolNot notExp) = +-- object [ "$not" .= notExp ] + +parseGBoolExp + :: ((Text, Value) -> J.Parser a) -> Value -> J.Parser (GBoolExp a) +parseGBoolExp f = \case + Object o -> do + boolExps <- forM (M.toList o) $ \(k, v) -> if + | k == "$or" -> BoolOr <$> parseGBoolExpL v Key k + | k == "_or" -> BoolOr <$> parseGBoolExpL v Key k + | k == "$and" -> BoolAnd <$> parseGBoolExpL v Key k + | k == "_and" -> BoolAnd <$> parseGBoolExpL v Key k + | k == "$not" -> BoolNot <$> parseGBoolExp f v Key k + | k == "_not" -> BoolNot <$> parseGBoolExp f v Key k + | otherwise -> BoolFld <$> f (k, v) + return $ BoolAnd boolExps + _ -> fail "expecting an Object for boolean exp" + where + parseGBoolExpL v = + parseJSON v >>= mapM (parseGBoolExp f) + +-- instance FromJSON (GBoolExp ColExp) where +-- parseJSON (Object o) = do +-- boolExps <- forM (M.toList o) $ \(k, v) -> if +-- | k == "$or" -> BoolOr <$> parseJSON v Key k +-- | k == "_or" -> BoolOr <$> parseJSON v Key k +-- | k == "$and" -> BoolAnd <$> parseJSON v Key k +-- | k == "_and" -> BoolAnd <$> parseJSON v Key k +-- | k == "$not" -> BoolNot <$> parseJSON v Key k +-- | k == "_not" -> BoolNot <$> parseJSON v Key k +-- | otherwise -> BoolFld . ColExp (FieldName k) <$> parseJSON v +-- return $ BoolAnd boolExps +-- parseJSON _ = fail "expecting an Object for boolean exp" + +foldBoolExp :: (Monad m) + => (a -> m S.BoolExp) + -> GBoolExp a + -> m S.BoolExp +foldBoolExp f (BoolAnd bes) = do + sqlBExps <- mapM (foldBoolExp f) bes + return $ foldr (S.BEBin S.AndOp) (S.BELit True) sqlBExps +foldBoolExp f (BoolOr bes) = do + sqlBExps <- mapM (foldBoolExp f) bes + return $ foldr (S.BEBin S.OrOp) (S.BELit False) sqlBExps +foldBoolExp f (BoolNot notExp) = + S.BENot <$> foldBoolExp f notExp +foldBoolExp f (BoolFld ce) = + f ce + +data OpExpG 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 + + | CEQ !PGCol + | CNE !PGCol + | CGT !PGCol + | CLT !PGCol + | CGTE !PGCol + | CLTE !PGCol + deriving (Eq, Show, Functor, Foldable, Traversable) + + +opExpToJPair :: (a -> Value) -> OpExpG a -> (Text, Value) +opExpToJPair f = \case + AEQ a -> ("_eq", f a) + ANE a -> ("_ne", f a) + + AIN a -> ("_in", toJSON $ map f a) + ANIN a -> ("_nin", toJSON $ map f a) + + AGT a -> ("_gt", f a) + ALT a -> ("_lt", f a) + AGTE a -> ("_gte", f a) + ALTE a -> ("_lte", f a) + + ALIKE a -> ("_like", f a) + ANLIKE a -> ("_nlike", f a) + + AILIKE a -> ("_ilike", f a) + ANILIKE a -> ("_nilike", f a) + + ASIMILAR a -> ("_similar", f a) + ANSIMILAR a -> ("_nsimilar", f a) + + AContains a -> ("_contains", f a) + AContainedIn a -> ("_contained_in", f a) + AHasKey a -> ("_has_key", f a) + AHasKeysAny a -> ("_has_keys_any", toJSON a) + AHasKeysAll a -> ("_has_keys_all", toJSON a) + + ANISNULL -> ("_is_null", toJSON True) + ANISNOTNULL -> ("_is_null", toJSON False) + + CEQ a -> ("_ceq", toJSON a) + CNE a -> ("_cne", toJSON a) + CGT a -> ("_cgt", toJSON a) + CLT a -> ("_clt", toJSON a) + CGTE a -> ("_cgte", toJSON a) + CLTE a -> ("_clte", toJSON a) + +-- data OpExpG a +-- = OEVal !(AnnValOpExpG a) +-- | OECol !ColOp !PGCol +-- deriving (Show, Eq) + +-- type OpExp = OpExpG (PGColType, PGColValue) + +-- data AnnBoolExpFldG a b +-- = AVCol !PGColInfo !a +-- | AVRel !RelInfo !b +-- deriving (Show, Eq) + +-- instance Bifunctor AnnBoolExpFldG where +-- bimap f g = \case +-- AVCol ci a -> AVCol ci $ f a +-- AVRel ri b -> AVRel ri $ g b + +-- newtype AnnBoolExpFld a +-- = AnnBoolExpFld { unAnnBoolExpFld :: AnnBoolExpFldG [OpExpG a] (AnnBoolExp a) } +-- deriving (Show, Eq) + +-- instance Functor AnnBoolExpFld where +-- fmap f (AnnBoolExpFld annBoolExpFld) = +-- AnnBoolExpFld $ bimap (map (fmap f)) (fmap f) annBoolExpFld + +data AnnBoolExpFld a + = AVCol !PGColInfo ![OpExpG a] + | AVRel !RelInfo !(AnnBoolExp a) + deriving (Show, Eq, Functor, Foldable, Traversable) + +type AnnBoolExp a + = GBoolExp (AnnBoolExpFld a) + +annBoolExpTrue :: AnnBoolExp a +annBoolExpTrue = gBoolExpTrue + +andAnnBoolExps :: AnnBoolExp a -> AnnBoolExp a -> AnnBoolExp a +andAnnBoolExps l r = + BoolAnd [l, r] + +-- traverseAnnBoolExp +-- :: (Applicative f) +-- => (AnnBoolExpFld a -> f (AnnBoolExpFld b)) +-- -> AnnBoolExp a +-- -> f (AnnBoolExp b) +-- traverseAnnBoolExp f boolExp = +-- traverse f boolExp + +type AnnBoolExpFldSQL = AnnBoolExpFld S.SQLExp +type AnnBoolExpSQL = AnnBoolExp S.SQLExp + +instance ToJSON AnnBoolExpSQL where + toJSON = gBoolExpToJSON f + where + f annFld = case annFld of + AVCol pci opExps -> + ( getPGColTxt $ pgiName pci + , toJSON (pci, map opExpSToJSON opExps) + ) + AVRel ri relBoolExp -> + ( getRelTxt $ riName ri + , toJSON (ri, toJSON relBoolExp) + ) + opExpSToJSON :: OpExpG S.SQLExp -> Value + opExpSToJSON = + object . pure . opExpToJPair (toJSON . toSQLTxt) + +-- $(deriveToJSON +-- defaultOptions{constructorTagModifier = snakeCase . drop 2} +-- ''AnnBoolExpFldG) + +-- type AnnValO a = AnnBoolExpFldG [OpExpG a] +-- type AnnVal = AnnValO (PGColType, PGColValue) + +-- 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 + +-- | RISNULL -- is null + +-- 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" + +-- show RISNULL = "$is_null" + +-- instance DQuote RQLOp where +-- dquoteTxt op = T.pack $ show op diff --git a/server/src-lib/Hasura/RQL/Types/Common.hs b/server/src-lib/Hasura/RQL/Types/Common.hs index c8f9e421044c4..3743adc29ea88 100644 --- a/server/src-lib/Hasura/RQL/Types/Common.hs +++ b/server/src-lib/Hasura/RQL/Types/Common.hs @@ -1,25 +1,22 @@ {-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Hasura.RQL.Types.Common - ( RelName(..) + ( PGColInfo(..) + , RelName(..) , RelType(..) , relTypeToTxt + , RelInfo(..) , FieldName(..) , fromPGCol , fromRel - , ColExp(..) - , GBoolExp(..) - , BoolExp - , foldBoolExp - , TQueryName(..) , TemplateParam(..) @@ -28,18 +25,26 @@ module Hasura.RQL.Types.Common ) where import Hasura.Prelude -import qualified Hasura.SQL.DML as S import Hasura.SQL.Types import Data.Aeson -import Data.Aeson.Internal -import qualified Data.HashMap.Strict as M +import Data.Aeson.TH +import Data.Aeson.Casing import qualified Data.Text as T import qualified Database.PG.Query as Q import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) import qualified PostgreSQL.Binary.Decoding as PD +data PGColInfo + = PGColInfo + { pgiName :: !PGCol + , pgiType :: !PGColType + , pgiIsNullable :: !Bool + } deriving (Show, Eq) + +$(deriveToJSON (aesonDrop 3 snakeCase) ''PGColInfo) + newtype RelName = RelName {getRelTxt :: T.Text} deriving (Show, Eq, Hashable, FromJSON, ToJSON, Q.ToPrepArg, Q.FromCol, Lift) @@ -73,6 +78,17 @@ instance Q.FromCol RelType where "array" -> Just ArrRel _ -> Nothing +data RelInfo + = RelInfo + { riName :: !RelName + , riType :: !RelType + , riMapping :: ![(PGCol, PGCol)] + , riRTable :: !QualifiedTable + , riIsManual :: !Bool + } deriving (Show, Eq) + +$(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo) + newtype FieldName = FieldName { getFieldNameTxt :: T.Text } deriving (Show, Eq, Hashable, FromJSON, ToJSON, FromJSONKey, ToJSONKey, Lift) @@ -89,67 +105,6 @@ fromPGCol (PGCol c) = FieldName c fromRel :: RelName -> FieldName fromRel (RelName r) = FieldName r -type BoolExp = GBoolExp ColExp - -data ColExp - = ColExp - { ceCol :: !FieldName - , ceVal :: !Value - } deriving (Show, Eq, Lift) - -data GBoolExp a - = BoolAnd ![GBoolExp a] - | BoolOr ![GBoolExp a] - | BoolCol !a - | BoolNot !(GBoolExp a) - deriving (Show, Eq, Lift, Functor, Foldable, Traversable) - -instance ToJSON (GBoolExp ColExp) where - toJSON (BoolAnd bExps) = - object $ flip map bExps $ \bExp -> case bExp of - BoolOr cbExps -> "$or" .= cbExps - BoolAnd cbExps -> "$and" .= cbExps - BoolCol (ColExp k v) -> getFieldNameTxt k .= v - BoolNot notExp -> "$not" .= notExp - toJSON (BoolOr bExps) = - object $ flip map bExps $ \bExp -> case bExp of - BoolOr cbExps -> "$or" .= cbExps - BoolAnd cbExps -> "$and" .= cbExps - BoolCol (ColExp k v) -> getFieldNameTxt k .= v - BoolNot notExp -> "$not" .= notExp - toJSON (BoolCol (ColExp k v)) = - object [ getFieldNameTxt k .= v ] - toJSON (BoolNot notExp) = - object [ "$not" .= notExp ] - -instance FromJSON (GBoolExp ColExp) where - parseJSON (Object o) = do - boolExps <- forM (M.toList o) $ \(k, v) -> if - | k == "$or" -> BoolOr <$> parseJSON v Key k - | k == "_or" -> BoolOr <$> parseJSON v Key k - | k == "$and" -> BoolAnd <$> parseJSON v Key k - | k == "_and" -> BoolAnd <$> parseJSON v Key k - | k == "$not" -> BoolNot <$> parseJSON v Key k - | k == "_not" -> BoolNot <$> parseJSON v Key k - | otherwise -> fmap (BoolCol . ColExp (FieldName k)) $ parseJSON v - return $ BoolAnd boolExps - parseJSON _ = fail "expecting an Object for boolean exp" - -foldBoolExp :: (Monad m) - => (a -> m S.BoolExp) - -> GBoolExp a - -> m S.BoolExp -foldBoolExp f (BoolAnd bes) = do - sqlBExps <- mapM (foldBoolExp f) bes - return $ foldr (S.BEBin S.AndOp) (S.BELit True) sqlBExps -foldBoolExp f (BoolOr bes) = do - sqlBExps <- mapM (foldBoolExp f) bes - return $ foldr (S.BEBin S.OrOp) (S.BELit False) sqlBExps -foldBoolExp f (BoolNot notExp) = - S.BENot <$> foldBoolExp f notExp -foldBoolExp f (BoolCol ce) = - f ce - newtype TQueryName = TQueryName { getTQueryName :: T.Text } deriving ( Show, Eq, Hashable, FromJSONKey, ToJSONKey diff --git a/server/src-lib/Hasura/RQL/Types/DML.hs b/server/src-lib/Hasura/RQL/Types/DML.hs index 99ee19ff0f711..97ab63c3165ff 100644 --- a/server/src-lib/Hasura/RQL/Types/DML.hs +++ b/server/src-lib/Hasura/RQL/Types/DML.hs @@ -10,7 +10,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Hasura.RQL.Types.DML - ( DMLQuery(..) + ( BoolExp(..) + , ColExp(..) + , DMLQuery(..) , OrderByExp(..) , OrderByItemG(..) @@ -49,6 +51,7 @@ import qualified Hasura.SQL.DML as S import Hasura.Prelude import Hasura.RQL.Types.Common +import Hasura.RQL.Types.BoolExp import Hasura.SQL.Types import Data.Aeson @@ -63,6 +66,28 @@ import Hasura.RQL.Instances () import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) +data ColExp + = ColExp + { ceCol :: !FieldName + , ceVal :: !Value + } deriving (Show, Eq, Lift) + +newtype BoolExp + = BoolExp { unBoolExp :: GBoolExp ColExp } deriving (Show, Eq, Lift) + +instance ToJSON BoolExp where + toJSON (BoolExp gBoolExp) = + gBoolExpToJSON f gBoolExp + where + f (ColExp k v) = + (getFieldNameTxt k, v) + +instance FromJSON BoolExp where + parseJSON = + fmap BoolExp . parseGBoolExp f + where + f (k, v) = ColExp (FieldName k) <$> parseJSON v + data DMLQuery a = DMLQuery !QualifiedTable a deriving (Show, Eq, Lift) diff --git a/server/src-lib/Hasura/RQL/Types/Permission.hs b/server/src-lib/Hasura/RQL/Types/Permission.hs index e002bfdb48eff..c5918ee0814e7 100644 --- a/server/src-lib/Hasura/RQL/Types/Permission.hs +++ b/server/src-lib/Hasura/RQL/Types/Permission.hs @@ -34,7 +34,6 @@ import qualified Database.PG.Query as Q import Data.Aeson import Data.Hashable -import Data.Word import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index acb94a88c35f0..43956266f77b2 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Hasura.RQL.Types.SchemaCache ( TableCache @@ -27,6 +28,8 @@ module Hasura.RQL.Types.SchemaCache , modTableInCache , delTableFromCache + , WithDeps + , CacheRM(..) , CacheRWM(..) @@ -55,6 +58,7 @@ module Hasura.RQL.Types.SchemaCache , permAccToType , withPermType , RolePermInfoMap + , InsPermInfo(..) , SelPermInfo(..) , UpdPermInfo(..) @@ -84,17 +88,18 @@ module Hasura.RQL.Types.SchemaCache , mkColDep , getDependentObjs , getDependentObjsWith - , getDependentObjsOfTable - , getDependentObjsOfQTemplateCache - , getDependentPermsOfTable - , getDependentRelsOfTable - , getDependentTriggersOfTable - , isDependentOn + -- , getDependentObjsOfTable + -- , getDependentObjsOfQTemplateCache + -- , getDependentPermsOfTable + -- , getDependentRelsOfTable + -- , getDependentTriggersOfTable + -- , isDependentOn ) where import qualified Database.PG.Query as Q import Hasura.Prelude import Hasura.RQL.Types.Common +import Hasura.RQL.Types.BoolExp import Hasura.RQL.Types.DML import Hasura.RQL.Types.Error import Hasura.RQL.Types.Permission @@ -104,6 +109,7 @@ import Hasura.SQL.Types import Control.Lens import Data.Aeson +import Data.Aeson.Types import Data.Aeson.Casing import Data.Aeson.TH import GHC.Generics (Generic) @@ -156,6 +162,9 @@ instance Show SchemaObjId where instance ToJSON SchemaObjId where toJSON = String . reportSchemaObj +instance ToJSONKey SchemaObjId where + toJSONKey = toJSONKeyText reportSchemaObj + data SchemaDependency = SchemaDependency { sdObjId :: !SchemaObjId @@ -171,40 +180,31 @@ mkColDep :: T.Text -> QualifiedTable -> PGCol -> SchemaDependency mkColDep reason tn col = flip SchemaDependency reason . SOTableObj tn $ TOCol col -class CachedSchemaObj a where - dependsOn :: a -> [SchemaDependency] +-- class CachedSchemaObj a where +-- dependsOn :: a -> [SchemaDependency] -isDependentOn :: (CachedSchemaObj a) => (T.Text -> Bool) -> SchemaObjId -> a -> Bool -isDependentOn reasonFn objId = any compareFn . dependsOn - where - compareFn (SchemaDependency depObjId rsn) = induces objId depObjId && reasonFn rsn - induces (SOTable tn1) (SOTable tn2) = tn1 == tn2 - induces (SOTable tn1) (SOTableObj tn2 _) = tn1 == tn2 - induces objId1 objId2 = objId1 == objId2 +-- isDependentOn :: (CachedSchemaObj a) => (T.Text -> Bool) -> SchemaObjId -> a -> Bool +-- isDependentOn reasonFn objId = any compareFn . dependsOn +-- where +-- compareFn (SchemaDependency depObjId rsn) = induces objId depObjId && reasonFn rsn +-- induces (SOTable tn1) (SOTable tn2) = tn1 == tn2 +-- induces (SOTable tn1) (SOTableObj tn2 _) = tn1 == tn2 +-- induces objId1 objId2 = objId1 == objId2 data QueryTemplateInfo = QueryTemplateInfo { qtiName :: !TQueryName , qtiQuery :: !QueryT - , qtiDeps :: ![SchemaDependency] + -- , qtiDeps :: ![SchemaDependency] } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''QueryTemplateInfo) -instance CachedSchemaObj QueryTemplateInfo where - dependsOn = qtiDeps +-- instance CachedSchemaObj QueryTemplateInfo where +-- dependsOn = qtiDeps type QTemplateCache = M.HashMap TQueryName QueryTemplateInfo -data PGColInfo - = PGColInfo - { pgiName :: !PGCol - , pgiType :: !PGColType - , pgiIsNullable :: !Bool - } deriving (Show, Eq) - -$(deriveToJSON (aesonDrop 3 snakeCase) ''PGColInfo) - onlyIntCols :: [PGColInfo] -> [PGColInfo] onlyIntCols = filter (isIntegerType . pgiType) @@ -221,20 +221,16 @@ getColInfos :: [PGCol] -> [PGColInfo] -> [PGColInfo] getColInfos cols allColInfos = flip filter allColInfos $ \ci -> pgiName ci `elem` cols -data RelInfo - = RelInfo - { riName :: !RelName - , riType :: !RelType - , riMapping :: ![(PGCol, PGCol)] - , riRTable :: !QualifiedTable - , riDeps :: ![SchemaDependency] - , riIsManual :: !Bool - } deriving (Show, Eq) +type WithDeps a = (a, [SchemaDependency]) -$(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo) +-- data WithDeps a +-- = WithDeps +-- { _wdObject :: !a +-- , _wdDeps :: ![SchemaDependency] +-- } deriving (Show, Eq) -instance CachedSchemaObj RelInfo where - dependsOn = riDeps +-- instance CachedSchemaObj (WithDeps a) where +-- dependsOn = _wdDeps data FieldInfo = FIColumn !PGColInfo @@ -273,71 +269,86 @@ isPGColInfo :: FieldInfo -> Bool isPGColInfo (FIColumn _) = True isPGColInfo _ = False -instance ToJSON S.BoolExp where - toJSON = String . T.pack . show - instance ToJSON S.SQLExp where toJSON = String . T.pack . show type InsSetCols = M.HashMap PGCol S.SQLExp +-- newtype QualM a +-- = QualM { unQualM :: Reader (Maybe S.Qual) a } +-- deriving (Functor, Applicative, Monad, MonadReader (Maybe S.Qual)) + +-- type BoolExpR = QualM S.BoolExp + +-- runQualM :: Maybe S.Qual -> QualM a -> a +-- runQualM qualM = +-- flip runReader qualM . unQualM + +-- instance (Show a) => Show (QualM a) where +-- show = +-- show . flip runReader Nothing . unQualM + +-- instance ToJSON BoolExpR where +-- toJSON = +-- toJSON . toSQLTxt . flip runReader Nothing . unQualM + data InsPermInfo = InsPermInfo { ipiView :: !QualifiedTable - , ipiCheck :: !S.BoolExp + , ipiCheck :: !AnnBoolExpSQL , ipiAllowUpsert :: !Bool , ipiSet :: !InsSetCols - , ipiDeps :: ![SchemaDependency] + -- , ipiDeps :: ![SchemaDependency] , ipiRequiredHeaders :: ![T.Text] - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''InsPermInfo) -instance CachedSchemaObj InsPermInfo where - dependsOn = ipiDeps +-- instance CachedSchemaObj InsPermInfo where +-- dependsOn = ipiDeps data SelPermInfo = SelPermInfo { spiCols :: !(HS.HashSet PGCol) , spiTable :: !QualifiedTable - , spiFilter :: !S.BoolExp + , spiFilter :: !AnnBoolExpSQL , spiLimit :: !(Maybe Int) , spiAllowAgg :: !Bool - , spiDeps :: ![SchemaDependency] + -- , spiDeps :: ![SchemaDependency] , spiRequiredHeaders :: ![T.Text] - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''SelPermInfo) -instance CachedSchemaObj SelPermInfo where - dependsOn = spiDeps +-- instance CachedSchemaObj SelPermInfo where +-- dependsOn = spiDeps data UpdPermInfo = UpdPermInfo { upiCols :: !(HS.HashSet PGCol) , upiTable :: !QualifiedTable - , upiFilter :: !S.BoolExp - , upiDeps :: ![SchemaDependency] + , upiFilter :: !AnnBoolExpSQL + -- , upiDeps :: ![SchemaDependency] , upiRequiredHeaders :: ![T.Text] - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''UpdPermInfo) -instance CachedSchemaObj UpdPermInfo where - dependsOn = upiDeps +-- instance CachedSchemaObj UpdPermInfo where +-- dependsOn = upiDeps data DelPermInfo = DelPermInfo { dpiTable :: !QualifiedTable - , dpiFilter :: !S.BoolExp - , dpiDeps :: ![SchemaDependency] + , dpiFilter :: !AnnBoolExpSQL + -- , dpiDeps :: ![SchemaDependency] , dpiRequiredHeaders :: ![T.Text] - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''DelPermInfo) -instance CachedSchemaObj DelPermInfo where - dependsOn = dpiDeps +-- instance CachedSchemaObj DelPermInfo where +-- dependsOn = dpiDeps mkRolePermInfo :: RolePermInfo mkRolePermInfo = RolePermInfo Nothing Nothing Nothing Nothing @@ -348,7 +359,7 @@ data RolePermInfo , _permSel :: !(Maybe SelPermInfo) , _permUpd :: !(Maybe UpdPermInfo) , _permDel :: !(Maybe DelPermInfo) - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 5 snakeCase) ''RolePermInfo) makeLenses ''RolePermInfo @@ -364,8 +375,8 @@ data OpTriggerInfo } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''OpTriggerInfo) -instance CachedSchemaObj OpTriggerInfo where - dependsOn = otiDeps +-- instance CachedSchemaObj OpTriggerInfo where +-- dependsOn = otiDeps data EventTriggerInfo = EventTriggerInfo @@ -383,10 +394,10 @@ $(deriveToJSON (aesonDrop 3 snakeCase) ''EventTriggerInfo) type EventTriggerInfoMap = M.HashMap TriggerName EventTriggerInfo -getTriggers :: EventTriggerInfoMap -> [OpTriggerInfo] -getTriggers etim = toOpTriggerInfo $ M.elems etim - where - toOpTriggerInfo etis = catMaybes $ foldl (\acc eti -> acc ++ [etiInsert eti, etiUpdate eti, etiDelete eti]) [] etis +-- getTriggers :: EventTriggerInfoMap -> [OpTriggerInfo] +-- getTriggers etim = toOpTriggerInfo $ M.elems etim +-- where +-- toOpTriggerInfo etis = catMaybes $ foldl (\acc eti -> acc ++ [etiInsert eti, etiUpdate eti, etiDelete eti]) [] etis data ConstraintType @@ -461,7 +472,7 @@ data TableInfo , tiPrimaryKeyCols :: ![PGCol] , tiViewInfo :: !(Maybe ViewInfo) , tiEventTriggerInfoMap :: !EventTriggerInfoMap - } deriving (Show, Eq) + } deriving (Show) $(deriveToJSON (aesonDrop 2 snakeCase) ''TableInfo) @@ -477,11 +488,14 @@ mkTableInfo tn isSystemDefined rawCons cols pcols mVI = type TableCache = M.HashMap QualifiedTable TableInfo -- info of all tables +type DepMap = M.HashMap SchemaObjId [SchemaDependency] + data SchemaCache = SchemaCache { scTables :: !TableCache , scQTemplates :: !QTemplateCache - } deriving (Show, Eq) + , scDepMap :: !DepMap + } deriving (Show) $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaCache) @@ -501,9 +515,12 @@ class (CacheRM m) => CacheRWM m where instance (Monad m) => CacheRWM (StateT SchemaCache m) where writeSchemaCache = put -addQTemplateToCache :: (QErrM m, CacheRWM m) - => QueryTemplateInfo -> m () -addQTemplateToCache qti = do +addQTemplateToCache + :: (QErrM m, CacheRWM m) + => QueryTemplateInfo + -> [SchemaDependency] + -> m () +addQTemplateToCache qti deps = do sc <- askSchemaCache let templateCache = scQTemplates sc case M.lookup qtn templateCache of @@ -529,7 +546,7 @@ delQTemplateFromCache qtn = do -- askSchemaCache = get emptySchemaCache :: SchemaCache -emptySchemaCache = SchemaCache (M.fromList []) (M.fromList []) +emptySchemaCache = SchemaCache (M.fromList []) (M.fromList []) mempty modTableCache :: (CacheRWM m) => TableCache -> m () modTableCache tc = do @@ -580,10 +597,11 @@ modTableInCache f tn = do newTi <- f ti modTableCache $ M.insert tn newTi $ scTables sc -addFldToCache :: (QErrM m, CacheRWM m) - => FieldName -> FieldInfo - -> QualifiedTable -> m () -addFldToCache fn fi = +addFldToCache + :: (QErrM m, CacheRWM m) + => FieldName -> FieldInfo -> [SchemaDependency] + -> QualifiedTable -> m () +addFldToCache fn fi deps = modTableInCache modFieldInfoMap where modFieldInfoMap ti = do @@ -674,15 +692,16 @@ addPermToCache -> RoleName -> PermAccessor a -> a + -> [SchemaDependency] -> m () -addPermToCache tn rn pa i = +addPermToCache tn rn pa i deps = modTableInCache modRolePermInfo tn where paL = permAccToLens pa modRolePermInfo ti = do let rpim = tiRolePermInfoMap ti rpi = fromMaybe mkRolePermInfo $ M.lookup rn rpim - newRPI = rpi & paL .~ Just i + newRPI = rpi & paL ?~ i assertPermNotExists pa rpi return $ ti { tiRolePermInfoMap = M.insert rn newRPI rpim } @@ -723,78 +742,88 @@ data TemplateParamInfo , tpiDefault :: !(Maybe Value) } deriving (Show, Eq) +-- getDependentObjs :: SchemaCache -> SchemaObjId -> [SchemaObjId] +-- getDependentObjs = getDependentObjsWith (const True) + +-- getDependentObjsWith :: (T.Text -> Bool) -> SchemaCache -> SchemaObjId -> [SchemaObjId] +-- getDependentObjsWith f sc objId = +-- HS.toList $ getDependentObjsRWith f HS.empty sc objId + getDependentObjs :: SchemaCache -> SchemaObjId -> [SchemaObjId] getDependentObjs = getDependentObjsWith (const True) -getDependentObjsWith :: (T.Text -> Bool) -> SchemaCache -> SchemaObjId -> [SchemaObjId] +getDependentObjsWith + :: (T.Text -> Bool) -> SchemaCache -> SchemaObjId -> [SchemaObjId] getDependentObjsWith f sc objId = - HS.toList $ getDependentObjsRWith f HS.empty sc objId - -getDependentObjsRWith :: (T.Text -> Bool) - -> HS.HashSet SchemaObjId - -> SchemaCache -> SchemaObjId - -> HS.HashSet SchemaObjId -getDependentObjsRWith f visited sc objId = - foldr go visited thisLevelDeps - where - thisLevelDeps = concatMap (getDependentObjsOfTableWith f objId) (scTables sc) - <> getDependentObjsOfQTemplateCache objId (scQTemplates sc) - go lObjId vis = - if HS.member lObjId vis - then vis - else getDependentObjsRWith f (HS.insert lObjId vis) sc lObjId - -getDependentObjsOfQTemplateCache :: SchemaObjId -> QTemplateCache -> [SchemaObjId] -getDependentObjsOfQTemplateCache objId qtc = - map (SOQTemplate . qtiName) $ filter (isDependentOn (const True) objId) $ - M.elems qtc - -getDependentObjsOfTable :: SchemaObjId -> TableInfo -> [SchemaObjId] -getDependentObjsOfTable objId ti = - rels ++ perms ++ triggers - where - rels = getDependentRelsOfTable (const True) objId ti - perms = getDependentPermsOfTable (const True) objId ti - triggers = getDependentTriggersOfTable (const True) objId ti - - -getDependentObjsOfTableWith :: (T.Text -> Bool) -> SchemaObjId -> TableInfo -> [SchemaObjId] -getDependentObjsOfTableWith f objId ti = - rels ++ perms ++ triggers - where - rels = getDependentRelsOfTable f objId ti - perms = getDependentPermsOfTable f objId ti - triggers = getDependentTriggersOfTable f objId ti - -getDependentRelsOfTable :: (T.Text -> Bool) -> SchemaObjId - -> TableInfo -> [SchemaObjId] -getDependentRelsOfTable rsnFn objId (TableInfo tn _ fim _ _ _ _ _) = - map (SOTableObj tn . TORel . riName) $ - filter (isDependentOn rsnFn objId) $ getRels fim - -getDependentPermsOfTable :: (T.Text -> Bool) -> SchemaObjId - -> TableInfo -> [SchemaObjId] -getDependentPermsOfTable rsnFn objId (TableInfo tn _ _ rpim _ _ _ _) = - concat $ flip M.mapWithKey rpim $ - \rn rpi -> map (SOTableObj tn . TOPerm rn) $ getDependentPerms' rsnFn objId rpi - -getDependentPerms' :: (T.Text -> Bool) -> SchemaObjId -> RolePermInfo -> [PermType] -getDependentPerms' rsnFn objId (RolePermInfo mipi mspi mupi mdpi) = - mapMaybe join - [ forM mipi $ toPermRow PTInsert - , forM mspi $ toPermRow PTSelect - , forM mupi $ toPermRow PTUpdate - , forM mdpi $ toPermRow PTDelete - ] + [ sdObjId sd | sd <- filter (f . sdReason) allDeps] where - toPermRow :: forall a. (CachedSchemaObj a) => PermType -> a -> Maybe PermType - toPermRow pt = - bool Nothing (Just pt) . isDependentOn rsnFn objId - -getDependentTriggersOfTable :: (T.Text -> Bool) -> SchemaObjId - -> TableInfo -> [SchemaObjId] -getDependentTriggersOfTable rsnFn objId (TableInfo tn _ _ _ _ _ _ et) = - map (SOTableObj tn . TOTrigger . otiTriggerName ) $ filter (isDependentOn rsnFn objId) $ getTriggers et + allDeps = fromMaybe [] $ M.lookup objId $ scDepMap sc + +-- getDependentObjsRWith :: (T.Text -> Bool) +-- -> HS.HashSet SchemaObjId +-- -> SchemaCache -> SchemaObjId +-- -> HS.HashSet SchemaObjId +-- getDependentObjsRWith f visited sc objId = +-- foldr go visited thisLevelDeps +-- where +-- thisLevelDeps = concatMap (getDependentObjsOfTableWith f objId) (scTables sc) +-- <> getDependentObjsOfQTemplateCache objId (scQTemplates sc) +-- go lObjId vis = +-- if HS.member lObjId vis +-- then vis +-- else getDependentObjsRWith f (HS.insert lObjId vis) sc lObjId + +-- getDependentObjsOfQTemplateCache :: SchemaObjId -> QTemplateCache -> [SchemaObjId] +-- getDependentObjsOfQTemplateCache objId qtc = +-- map (SOQTemplate . qtiName) $ filter (isDependentOn (const True) objId) $ +-- M.elems qtc + +-- getDependentObjsOfTable :: SchemaObjId -> TableInfo -> [SchemaObjId] +-- getDependentObjsOfTable objId ti = +-- rels ++ perms ++ triggers +-- where +-- rels = getDependentRelsOfTable (const True) objId ti +-- perms = getDependentPermsOfTable (const True) objId ti +-- triggers = getDependentTriggersOfTable (const True) objId ti + + +-- getDependentObjsOfTableWith :: (T.Text -> Bool) -> SchemaObjId -> TableInfo -> [SchemaObjId] +-- getDependentObjsOfTableWith f objId ti = +-- rels ++ perms ++ triggers +-- where +-- rels = getDependentRelsOfTable f objId ti +-- perms = getDependentPermsOfTable f objId ti +-- triggers = getDependentTriggersOfTable f objId ti + +-- getDependentRelsOfTable :: (T.Text -> Bool) -> SchemaObjId +-- -> TableInfo -> [SchemaObjId] +-- getDependentRelsOfTable rsnFn objId (TableInfo tn _ fim _ _ _ _ _) = +-- map (SOTableObj tn . TORel . riName) $ +-- filter (isDependentOn rsnFn objId) $ getRels fim + +-- getDependentPermsOfTable :: (T.Text -> Bool) -> SchemaObjId +-- -> TableInfo -> [SchemaObjId] +-- getDependentPermsOfTable rsnFn objId (TableInfo tn _ _ rpim _ _ _ _) = +-- concat $ flip M.mapWithKey rpim $ +-- \rn rpi -> map (SOTableObj tn . TOPerm rn) $ getDependentPerms' rsnFn objId rpi + +-- getDependentPerms' :: (T.Text -> Bool) -> SchemaObjId -> RolePermInfo -> [PermType] +-- getDependentPerms' rsnFn objId (RolePermInfo mipi mspi mupi mdpi) = +-- mapMaybe join +-- [ forM mipi $ toPermRow PTInsert +-- , forM mspi $ toPermRow PTSelect +-- , forM mupi $ toPermRow PTUpdate +-- , forM mdpi $ toPermRow PTDelete +-- ] +-- where +-- toPermRow :: forall a. (CachedSchemaObj a) => PermType -> a -> Maybe PermType +-- toPermRow pt = +-- bool Nothing (Just pt) . isDependentOn rsnFn objId + +-- getDependentTriggersOfTable :: (T.Text -> Bool) -> SchemaObjId +-- -> TableInfo -> [SchemaObjId] +-- getDependentTriggersOfTable rsnFn objId (TableInfo tn _ _ _ _ _ _ et) = +-- map (SOTableObj tn . TOTrigger . otiTriggerName ) $ filter (isDependentOn rsnFn objId) $ getTriggers et getOpInfo :: TriggerName -> TableInfo -> Maybe SubscribeOpSpec -> Maybe OpTriggerInfo getOpInfo trn ti mos= fromSubscrOpSpec <$> mos diff --git a/server/src-lib/Hasura/SQL/DML.hs b/server/src-lib/Hasura/SQL/DML.hs index 182eddf85686d..917053c91165d 100644 --- a/server/src-lib/Hasura/SQL/DML.hs +++ b/server/src-lib/Hasura/SQL/DML.hs @@ -455,12 +455,12 @@ simplifyBoolExp be = case be of | otherwise -> BEBin OrOp e1s e2s e -> e -mkExists :: QualifiedTable -> BoolExp -> BoolExp -mkExists qt whereFrag = - BEExists mkSelect { - selExtr = [Extractor (SEUnsafe "1") Nothing], - selFrom = Just $ mkSimpleFromExp qt, - selWhere = Just $ WhereFrag whereFrag +mkExists :: FromItem -> BoolExp -> BoolExp +mkExists fromItem whereFrag = + BEExists mkSelect + { selExtr = [Extractor (SEUnsafe "1") Nothing] + , selFrom = Just $ FromExp $ pure fromItem + , selWhere = Just $ WhereFrag whereFrag } instance ToSQL BoolExp where From 33b2a0f1edee7a43da777a1539ce83251c18a9ff Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 13 Nov 2018 16:53:58 +0530 Subject: [PATCH 02/12] clean up boolean exp --- server/src-lib/Hasura/RQL/GBoolExp.hs | 266 +-------------------- server/src-lib/Hasura/RQL/Types/BoolExp.hs | 147 +----------- 2 files changed, 11 insertions(+), 402 deletions(-) diff --git a/server/src-lib/Hasura/RQL/GBoolExp.hs b/server/src-lib/Hasura/RQL/GBoolExp.hs index 32b596d0f5f5c..cd91580ea7c91 100644 --- a/server/src-lib/Hasura/RQL/GBoolExp.hs +++ b/server/src-lib/Hasura/RQL/GBoolExp.hs @@ -109,12 +109,13 @@ parseOpExp parser fim (PGColInfo cn colTy _) (opStr, val) = case opStr of parseLt = ALT <$> parseOne -- < parseGte = AGTE <$> parseOne -- >= parseLte = ALTE <$> parseOne -- <= - parseLike = ALIKE <$> parseOne -- LIKE - parseNlike = ANLIKE <$> parseOne -- NOT LIKE - parseIlike = AILIKE <$> parseOne -- ILIKE, case insensitive - parseNilike = ANILIKE <$> parseOne -- NOT ILIKE, case insensitive - parseSimilar = ASIMILAR <$> parseOne -- similar, regex - parseNsimilar = ANSIMILAR <$> parseOne -- not similar, regex + 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 @@ -136,7 +137,6 @@ parseOpExp parser fim (PGColInfo cn colTy _) (opStr, val) = case opStr of else return rhsCol parseOne = parser colTy val - -- runAesonParser (parsePGValue ty) val parseMany = do vals <- runAesonParser parseJSON val indexedForM vals (parser colTy) @@ -152,70 +152,8 @@ parseOpExps valParser cim colInfo = \case (Object o) -> mapM (parseOpExp valParser cim colInfo)(M.toList o) val -> pure . AEQ <$> valParser (pgiType colInfo) val --- 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 --- RISNULL -> bool ANISNOTNULL ANISNULL -- is null --- <$> decodeValue val - -- where - -- parseOne = parser ty val - -- -- runAesonParser (parsePGValue ty) val - -- parseMany = do - -- vals <- runAesonParser parseJSON val - -- indexedForM vals (parser ty) - --- isRQLOp :: T.Text -> Bool --- isRQLOp t = case runIdentity . runExceptT $ parseOpExp t of --- Left _ -> False --- Right r -> either (const True) (const False) r - type ValueParser m a = PGColType -> Value -> m a --- 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 <- parseOpExp 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 rhsCol = PGCol c --- errMsg = "column operators can only compare postgres columns" --- rhsType <- askPGType cim rhsCol errMsg --- when (colTy /= rhsType) $ --- throw400 UnexpectedPayload $ --- "incompatible column types : " <> cn <<> ", " <>> rhsCol --- return $ OECol colOp rhsCol --- (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 @@ -225,34 +163,12 @@ buildMsg ty expTys = , T.intercalate "/" $ map (T.dquote . T.pack . show) expTys ] -type OpTypeChecker m = PGColType -> m () - -textOnlyOp :: (MonadError QErr m) => OpTypeChecker m +textOnlyOp :: (MonadError QErr m) => PGColType -> 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 --- getOpTypeChecker RISNULL = validOnAllTypes - -- This convoluted expression instead of col = val -- to handle the case of col : null equalsBoolExpBuilder :: S.SQLExp -> S.SQLExp -> S.BoolExp @@ -269,14 +185,6 @@ notEqualsBoolExpBuilder qualColExp rhsExp = (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 (BoolFld ce) = BoolFld <$> f ce --- mapBoolExp f (BoolNot notExp) = BoolNot <$> mapBoolExp f notExp - annBoolExp :: (QErrM m, CacheRM m) => ValueParser m a @@ -285,11 +193,6 @@ annBoolExp -> m (AnnBoolExp a) annBoolExp valParser fim (BoolExp boolExp) = traverse (annColExp valParser fim) boolExp --- annBoolExp valParser cim = \case --- (BoolAnd bes) -> BoolAnd <$> mapM (annBoolExp valParser cim) bes --- (BoolOr bes) -> BoolOr <$> mapM (annBoolExp valParser cim) bes --- (BoolFld ce) -> BoolFld <$> annColExp valParser cim ce --- (BoolNot notExp) -> BoolNot <$> annBoolExp valParser cim notExp annColExp :: (QErrM m, CacheRM m) @@ -312,57 +215,6 @@ annColExp valueParser colInfoMap (ColExp fieldName colVal) = do annRelBoolExp <- annBoolExp valueParser relFieldInfoMap relBoolExp return $ AVRel relInfo annRelBoolExp --- toSQLBoolExp --- :: (Monad m) --- => BoolExpBuilder m a -> S.Qual --- -> GBoolExp (AnnValO a) -> m S.BoolExp --- toSQLBoolExp vp tq e = --- evalStateT (convBoolRhs' vp tq e) 0 - --- convBoolRhs' --- :: (Monad m) --- => BoolExpBuilder m a -> S.Qual --- -> GBoolExp (AnnValO a) -> StateT Word64 m S.BoolExp --- convBoolRhs' vp tq = --- foldBoolExp (convColRhs vp tq) - --- convColRhs --- :: (Monad m) --- => BoolExpBuilder m a --- -> S.Qual -> AnnValO a -> StateT Word64 m S.BoolExp --- convColRhs bExpBuilder tableQual annVal = case annVal of --- AVCol (PGColInfo cn _ _) opExps -> do --- let qualColExp = mkQCol tableQual cn --- -- bExps <- forM opExps $ \case --- -- OEVal annOpValExp -> lift $ bExpBuilder qualColExp annOpValExp --- -- OECol op rCol -> do --- -- let rhsColExp = mkQCol tableQual rCol --- -- return $ mkColOpSQLExp op qualColExp rhsColExp --- bExps <- forM opExps $ \opExp -> --- lift $ bExpBuilder tableQual qualColExp annOpValExp --- 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' bExpBuilder (Just newIdenQ) nesAnn --- let backCompExp = foldr (S.BEBin S.AndOp) (S.BELit True) $ --- flip map colMapping $ \(lCol, rCol) -> --- S.BECompare S.SEQ --- (S.SEQIden $ S.QIden (S.QualIden newIden) (toIden rCol)) --- (mkQCol tableQual lCol) --- innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp --- -- return $ ABERel rn (relTN, newIden) annRelBoolExp backCompExp --- return $ S.mkExists (S.FISimple relTN $ Just $ S.Alias newIden) innerBoolExp --- where --- mkQCol colQM col = case colQM of --- Just colQ -> S.SEQIden $ S.QIden colQ $ toIden col --- Nothing -> S.SEIden $ toIden col - toSQLBoolExp :: S.Qual -> AnnBoolExpSQL -> S.BoolExp toSQLBoolExp tq e = @@ -394,39 +246,10 @@ convColRhs tableQual = \case (mkQCol (S.QualIden newIden) rCol) (mkQCol tableQual lCol) innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp - -- return $ ABERel rn (relTN, newIden) annRelBoolExp backCompExp return $ S.mkExists (S.FISimple relTN $ Just $ S.Alias newIden) innerBoolExp where mkQCol q = S.SEQIden . S.QIden q . toIden - -- mkQCol colQM col = case colQM of - -- Just colQ -> S.SEQIden $ S.QIden colQ $ toIden col - -- Nothing -> S.SEIden $ toIden col - --- cBoolExp --- :: GBoolExp AnnSQLBoolExp --- -> S.BoolExp --- cBoolExp be = --- runIdentity $ flip foldBoolExp be $ \ace -> --- return $ cColExp ace - --- cColExp --- :: AnnSQLBoolExp --- -> S.BoolExp --- cColExp annVal = case annVal of --- ABECol _ be -> be --- ABERel _ (tn, tIden) nesAnn backCompExp -> do --- -- Convert the where clause on the relationship --- let annRelBoolExp = cBoolExp nesAnn --- innerBoolExp = S.BEBin S.AndOp backCompExp annRelBoolExp --- S.mkExists (S.FISimple tn $ Just $ S.Alias tIden) innerBoolExp - --- txtValParser --- :: (MonadError QErr m) --- => ValueParser m (AnnValOpExpG S.SQLExp) --- txtValParser = --- undefined - pgValParser :: (MonadError QErr m) => PGColType -> Value -> m PGColValue @@ -439,62 +262,13 @@ txtRHSBuilder txtRHSBuilder ty val = txtEncoder <$> pgValParser ty val --- this does not parse the value -noValParser - :: (MonadError QErr m) - => ValueParser m Value -noValParser _ = return - --- 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 -> 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 --- CEQ rhsCol -> return $ S.BECompare S.SEQ lhs rhsCol --- CNE rhsCol -> return $ S.BECompare S.SNE lhs rhsCol --- CGT rhsCol -> return $ S.BECompare S.SGT lhs rhsCol --- CLT rhsCol -> return $ S.BECompare S.SLT lhs rhsCol --- CGTE rhsCol -> return $ S.BECompare S.SGTE lhs rhsCol --- CLTE rhsCol -> return $ S.BECompare S.SLTE lhs rhsCol --- where --- lhs = undefined - --- 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 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 -> mkInOrNotBoolExpBuilder True vals - ANIN vals -> mkInOrNotBoolExpBuilder False vals + AIN vals -> S.BEEqualsAny lhs vals + ANIN vals -> S.BENot $ S.BEEqualsAny lhs 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 @@ -525,26 +299,6 @@ mkColCompExp qual lhsCol = \case toTextArray arr = S.SETyAnn (S.SEArray $ map (txtEncoder . PGValText) arr) S.textArrType - -- mkSimpleBoolExpBuilder beF pgColVal = - -- beF lhs <$> rhsBldr pgColVal - - mkInOrNotBoolExpBuilder isIn rhsExps = do - let boolExp = S.BEEqualsAny 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 -> AnnBoolExpFld a -> [SchemaDependency] getColExpDeps tn = \case AVCol colInfo _ -> diff --git a/server/src-lib/Hasura/RQL/Types/BoolExp.hs b/server/src-lib/Hasura/RQL/Types/BoolExp.hs index b091c1504f927..452fb844990a7 100644 --- a/server/src-lib/Hasura/RQL/Types/BoolExp.hs +++ b/server/src-lib/Hasura/RQL/Types/BoolExp.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -17,7 +17,6 @@ module Hasura.RQL.Types.BoolExp , AnnBoolExpFld(..) , AnnBoolExp - -- , traverseAnnBoolExp , annBoolExpTrue , andAnnBoolExps @@ -30,15 +29,11 @@ import Hasura.Prelude import Hasura.RQL.Types.Common import qualified Hasura.SQL.DML as S import Hasura.SQL.Types --- import Hasura.SQL.Value import Data.Aeson --- import Data.Aeson.TH --- import Data.Aeson.Casing import Data.Aeson.Internal import qualified Data.Aeson.Types as J import qualified Data.HashMap.Strict as M --- import qualified Data.Text.Extended as T import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) @@ -59,24 +54,6 @@ gBoolExpToJSON f = \case BoolNot bExp -> object ["$not" .= gBoolExpToJSON f bExp ] BoolFld a -> object $ pure $ f a --- instance ToJSON (GBoolExp ColExp) where --- toJSON (BoolAnd bExps) = --- object $ flip map bExps $ \case --- BoolOr cbExps -> "$or" .= cbExps --- BoolAnd cbExps -> "$and" .= cbExps --- BoolFld (ColExp k v) -> getFieldNameTxt k .= v --- BoolNot notExp -> "$not" .= notExp --- toJSON (BoolOr bExps) = --- object $ flip map bExps $ \case --- BoolOr cbExps -> "$or" .= cbExps --- BoolAnd cbExps -> "$and" .= cbExps --- BoolFld (ColExp k v) -> getFieldNameTxt k .= v --- BoolNot notExp -> "$not" .= notExp --- toJSON (BoolFld (ColExp k v)) = --- object [ getFieldNameTxt k .= v ] --- toJSON (BoolNot notExp) = --- object [ "$not" .= notExp ] - parseGBoolExp :: ((Text, Value) -> J.Parser a) -> Value -> J.Parser (GBoolExp a) parseGBoolExp f = \case @@ -95,19 +72,6 @@ parseGBoolExp f = \case parseGBoolExpL v = parseJSON v >>= mapM (parseGBoolExp f) --- instance FromJSON (GBoolExp ColExp) where --- parseJSON (Object o) = do --- boolExps <- forM (M.toList o) $ \(k, v) -> if --- | k == "$or" -> BoolOr <$> parseJSON v Key k --- | k == "_or" -> BoolOr <$> parseJSON v Key k --- | k == "$and" -> BoolAnd <$> parseJSON v Key k --- | k == "_and" -> BoolAnd <$> parseJSON v Key k --- | k == "$not" -> BoolNot <$> parseJSON v Key k --- | k == "_not" -> BoolNot <$> parseJSON v Key k --- | otherwise -> BoolFld . ColExp (FieldName k) <$> parseJSON v --- return $ BoolAnd boolExps --- parseJSON _ = fail "expecting an Object for boolean exp" - foldBoolExp :: (Monad m) => (a -> m S.BoolExp) -> GBoolExp a @@ -200,31 +164,6 @@ opExpToJPair f = \case CGTE a -> ("_cgte", toJSON a) CLTE a -> ("_clte", toJSON a) --- data OpExpG a --- = OEVal !(AnnValOpExpG a) --- | OECol !ColOp !PGCol --- deriving (Show, Eq) - --- type OpExp = OpExpG (PGColType, PGColValue) - --- data AnnBoolExpFldG a b --- = AVCol !PGColInfo !a --- | AVRel !RelInfo !b --- deriving (Show, Eq) - --- instance Bifunctor AnnBoolExpFldG where --- bimap f g = \case --- AVCol ci a -> AVCol ci $ f a --- AVRel ri b -> AVRel ri $ g b - --- newtype AnnBoolExpFld a --- = AnnBoolExpFld { unAnnBoolExpFld :: AnnBoolExpFldG [OpExpG a] (AnnBoolExp a) } --- deriving (Show, Eq) - --- instance Functor AnnBoolExpFld where --- fmap f (AnnBoolExpFld annBoolExpFld) = --- AnnBoolExpFld $ bimap (map (fmap f)) (fmap f) annBoolExpFld - data AnnBoolExpFld a = AVCol !PGColInfo ![OpExpG a] | AVRel !RelInfo !(AnnBoolExp a) @@ -240,14 +179,6 @@ andAnnBoolExps :: AnnBoolExp a -> AnnBoolExp a -> AnnBoolExp a andAnnBoolExps l r = BoolAnd [l, r] --- traverseAnnBoolExp --- :: (Applicative f) --- => (AnnBoolExpFld a -> f (AnnBoolExpFld b)) --- -> AnnBoolExp a --- -> f (AnnBoolExp b) --- traverseAnnBoolExp f boolExp = --- traverse f boolExp - type AnnBoolExpFldSQL = AnnBoolExpFld S.SQLExp type AnnBoolExpSQL = AnnBoolExp S.SQLExp @@ -266,79 +197,3 @@ instance ToJSON AnnBoolExpSQL where opExpSToJSON :: OpExpG S.SQLExp -> Value opExpSToJSON = object . pure . opExpToJPair (toJSON . toSQLTxt) - --- $(deriveToJSON --- defaultOptions{constructorTagModifier = snakeCase . drop 2} --- ''AnnBoolExpFldG) - --- type AnnValO a = AnnBoolExpFldG [OpExpG a] --- type AnnVal = AnnValO (PGColType, PGColValue) - --- 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 - --- | RISNULL -- is null - --- 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" - --- show RISNULL = "$is_null" - --- instance DQuote RQLOp where --- dquoteTxt op = T.pack $ show op From 2f82c6565a82b4ba22279a85cfddb81770ad80e9 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Wed, 14 Nov 2018 18:37:56 +0530 Subject: [PATCH 03/12] handle dependencies of rels and perms --- server/src-lib/Hasura/RQL/DDL/Relationship.hs | 6 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 12 +- .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 242 ++++++------------ 3 files changed, 94 insertions(+), 166 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship.hs b/server/src-lib/Hasura/RQL/DDL/Relationship.hs index 6019520f440e4..65d45e86873d9 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship.hs @@ -193,7 +193,7 @@ objRelP2Setup qt (RelDef rn ru _) = do return (RelInfo rn ObjRel colMapping refqt False, deps) _ -> throw400 ConstraintError "more than one foreign key constraint exists on the given column" - addFldToCache (fromRel rn) (FIRelationship relInfo) deps qt + addRelToCache rn relInfo deps qt where QualifiedTable sn tn = qt fetchFKeyDetail cn = @@ -288,7 +288,7 @@ arrRelP2Setup qt (RelDef rn ru _) = do return (RelInfo rn ArrRel (map swap mapping) refqt False, deps) _ -> throw400 ConstraintError "more than one foreign key constraint exists on the given column" - addFldToCache (fromRel rn) (FIRelationship relInfo) deps qt + addRelToCache rn relInfo deps qt where QualifiedTable sn tn = qt fetchFKeyDetail refsn reftn refcn = Q.listQ [Q.sql| @@ -354,7 +354,7 @@ purgeRelDep d = throw500 $ "unexpected dependency of relationship : " dropRelP2 :: (P2C m) => DropRel -> [SchemaObjId] -> m RespBody dropRelP2 (DropRel qt rn _) depObjs = do mapM_ purgeRelDep depObjs - delFldFromCache (fromRel rn) qt + delRelFromCache rn qt liftTx $ delRelFromCatalog qt rn return successMsg diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 16471f6a55e6c..67b689879d65f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -169,7 +169,7 @@ purgeDep schemaObjId = case schemaObjId of (SOTableObj qt (TORel rn)) -> do liftTx $ delRelFromCatalog qt rn - delFldFromCache (fromRel rn) qt + delRelFromCache rn qt (SOQTemplate qtn) -> do liftTx $ delQTemplateFromCatalog qtn @@ -191,7 +191,7 @@ processTableChanges ti tableDiff = do -- for all the dropped columns forM_ droppedCols $ \droppedCol -> -- Drop the column from the cache - delFldFromCache (fromPGCol droppedCol) tn + delColFromCache droppedCol tn -- In the newly added columns check that there is no conflict with relationships forM_ addedCols $ \colInfo@(PGColInfo colName _ _) -> @@ -200,7 +200,7 @@ processTableChanges ti tableDiff = do throw400 AlreadyExists $ "cannot add column " <> colName <<> " in table " <> tn <<> " as a relationship with the name already exists" - _ -> addFldToCache (fromPGCol colName) (FIColumn colInfo) [] tn + _ -> addColToCache colName colInfo tn sc <- askSchemaCache -- for rest of the columns @@ -212,15 +212,15 @@ processTableChanges ti tableDiff = do let colId = SOTableObj tn $ TOCol oColName depObjs = getDependentObjsWith (== "on_type") sc colId if null depObjs - then updateFldInCache oColName $ FIColumn nci + then updateFldInCache oColName nci else throw400 DependencyError $ "cannot change type of column " <> oColName <<> " in table " <> tn <<> " because of the following dependencies : " <> reportSchemaObjs depObjs | otherwise -> return () where updateFldInCache cn ci = do - delFldFromCache (fromPGCol cn) tn - addFldToCache (fromPGCol cn) ci [] tn + delColFromCache cn tn + addColToCache cn ci tn tn = tiName ti TableDiff mNewName droppedCols addedCols alteredCols _ = tableDiff diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 43956266f77b2..94904eccf4b38 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -45,8 +45,12 @@ module Hasura.RQL.Types.SchemaCache , isPGColInfo , getColInfos , RelInfo(..) - , addFldToCache - , delFldFromCache + -- , addFldToCache + , addColToCache + , addRelToCache + + , delColFromCache + , delRelFromCache , RolePermInfo(..) , permIns @@ -88,12 +92,6 @@ module Hasura.RQL.Types.SchemaCache , mkColDep , getDependentObjs , getDependentObjsWith - -- , getDependentObjsOfTable - -- , getDependentObjsOfQTemplateCache - -- , getDependentPermsOfTable - -- , getDependentRelsOfTable - -- , getDependentTriggersOfTable - -- , isDependentOn ) where import qualified Database.PG.Query as Q @@ -169,10 +167,12 @@ data SchemaDependency = SchemaDependency { sdObjId :: !SchemaObjId , sdReason :: !T.Text - } deriving (Show, Eq) + } deriving (Show, Eq, Generic) $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaDependency) +instance Hashable SchemaDependency + mkParentDep :: QualifiedTable -> SchemaDependency mkParentDep tn = SchemaDependency (SOTable tn) "table" @@ -180,29 +180,14 @@ mkColDep :: T.Text -> QualifiedTable -> PGCol -> SchemaDependency mkColDep reason tn col = flip SchemaDependency reason . SOTableObj tn $ TOCol col --- class CachedSchemaObj a where --- dependsOn :: a -> [SchemaDependency] - --- isDependentOn :: (CachedSchemaObj a) => (T.Text -> Bool) -> SchemaObjId -> a -> Bool --- isDependentOn reasonFn objId = any compareFn . dependsOn --- where --- compareFn (SchemaDependency depObjId rsn) = induces objId depObjId && reasonFn rsn --- induces (SOTable tn1) (SOTable tn2) = tn1 == tn2 --- induces (SOTable tn1) (SOTableObj tn2 _) = tn1 == tn2 --- induces objId1 objId2 = objId1 == objId2 - data QueryTemplateInfo = QueryTemplateInfo { qtiName :: !TQueryName , qtiQuery :: !QueryT - -- , qtiDeps :: ![SchemaDependency] } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''QueryTemplateInfo) --- instance CachedSchemaObj QueryTemplateInfo where --- dependsOn = qtiDeps - type QTemplateCache = M.HashMap TQueryName QueryTemplateInfo onlyIntCols :: [PGColInfo] -> [PGColInfo] @@ -223,15 +208,6 @@ getColInfos cols allColInfos = flip filter allColInfos $ \ci -> type WithDeps a = (a, [SchemaDependency]) --- data WithDeps a --- = WithDeps --- { _wdObject :: !a --- , _wdDeps :: ![SchemaDependency] --- } deriving (Show, Eq) - --- instance CachedSchemaObj (WithDeps a) where --- dependsOn = _wdDeps - data FieldInfo = FIColumn !PGColInfo | FIRelationship !RelInfo @@ -274,24 +250,6 @@ instance ToJSON S.SQLExp where type InsSetCols = M.HashMap PGCol S.SQLExp --- newtype QualM a --- = QualM { unQualM :: Reader (Maybe S.Qual) a } --- deriving (Functor, Applicative, Monad, MonadReader (Maybe S.Qual)) - --- type BoolExpR = QualM S.BoolExp - --- runQualM :: Maybe S.Qual -> QualM a -> a --- runQualM qualM = --- flip runReader qualM . unQualM - --- instance (Show a) => Show (QualM a) where --- show = --- show . flip runReader Nothing . unQualM - --- instance ToJSON BoolExpR where --- toJSON = --- toJSON . toSQLTxt . flip runReader Nothing . unQualM - data InsPermInfo = InsPermInfo { ipiView :: !QualifiedTable @@ -320,36 +278,25 @@ data SelPermInfo $(deriveToJSON (aesonDrop 3 snakeCase) ''SelPermInfo) --- instance CachedSchemaObj SelPermInfo where --- dependsOn = spiDeps - data UpdPermInfo = UpdPermInfo { upiCols :: !(HS.HashSet PGCol) , upiTable :: !QualifiedTable , upiFilter :: !AnnBoolExpSQL - -- , upiDeps :: ![SchemaDependency] , upiRequiredHeaders :: ![T.Text] } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''UpdPermInfo) --- instance CachedSchemaObj UpdPermInfo where --- dependsOn = upiDeps - data DelPermInfo = DelPermInfo { dpiTable :: !QualifiedTable , dpiFilter :: !AnnBoolExpSQL - -- , dpiDeps :: ![SchemaDependency] , dpiRequiredHeaders :: ![T.Text] } deriving (Show) $(deriveToJSON (aesonDrop 3 snakeCase) ''DelPermInfo) --- instance CachedSchemaObj DelPermInfo where --- dependsOn = dpiDeps - mkRolePermInfo :: RolePermInfo mkRolePermInfo = RolePermInfo Nothing Nothing Nothing Nothing @@ -375,9 +322,6 @@ data OpTriggerInfo } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''OpTriggerInfo) --- instance CachedSchemaObj OpTriggerInfo where --- dependsOn = otiDeps - data EventTriggerInfo = EventTriggerInfo { etiId :: !TriggerId @@ -394,12 +338,6 @@ $(deriveToJSON (aesonDrop 3 snakeCase) ''EventTriggerInfo) type EventTriggerInfoMap = M.HashMap TriggerName EventTriggerInfo --- getTriggers :: EventTriggerInfoMap -> [OpTriggerInfo] --- getTriggers etim = toOpTriggerInfo $ M.elems etim --- where --- toOpTriggerInfo etis = catMaybes $ foldl (\acc eti -> acc ++ [etiInsert eti, etiUpdate eti, etiDelete eti]) [] etis - - data ConstraintType = CTCHECK | CTFOREIGNKEY @@ -488,7 +426,22 @@ mkTableInfo tn isSystemDefined rawCons cols pcols mVI = type TableCache = M.HashMap QualifiedTable TableInfo -- info of all tables -type DepMap = M.HashMap SchemaObjId [SchemaDependency] +type DepMap = M.HashMap SchemaObjId (HS.HashSet SchemaDependency) + +addToDepMap :: SchemaObjId -> [SchemaDependency] -> DepMap -> DepMap +addToDepMap schObj deps = + M.insert schObj (HS.fromList deps) + + -- M.unionWith HS.union objDepMap + -- where + -- objDepMap = M.fromList + -- [ (dep, HS.singleton $ SchemaDependency schObj reason) + -- | (SchemaDependency dep reason) <- deps + -- ] + +removeFromDepMap :: SchemaObjId -> DepMap -> DepMap +removeFromDepMap = + M.delete data SchemaCache = SchemaCache @@ -499,6 +452,11 @@ data SchemaCache $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaCache) +modDepMapInCache :: (CacheRWM m) => (DepMap -> DepMap) -> m () +modDepMapInCache f = do + sc <- askSchemaCache + writeSchemaCache $ sc { scDepMap = f (scDepMap sc)} + class (Monad m) => CacheRM m where -- Get the schema cache @@ -528,8 +486,10 @@ addQTemplateToCache qti deps = do Nothing -> do let newTemplateCache = M.insert qtn qti templateCache writeSchemaCache $ sc {scQTemplates = newTemplateCache} + modDepMapInCache (addToDepMap objId deps) where qtn = qtiName qti + objId = SOQTemplate qtn delQTemplateFromCache :: (QErrM m, CacheRWM m) => TQueryName -> m () @@ -541,9 +501,9 @@ delQTemplateFromCache qtn = do Just _ -> do let newTemplateCache = M.delete qtn templateCache writeSchemaCache $ sc {scQTemplates = newTemplateCache} - --- instance CacheRM where --- askSchemaCache = get + modDepMapInCache (removeFromDepMap objId) + where + objId = SOQTemplate qtn emptySchemaCache :: SchemaCache emptySchemaCache = SchemaCache (M.fromList []) (M.fromList []) mempty @@ -597,11 +557,28 @@ modTableInCache f tn = do newTi <- f ti modTableCache $ M.insert tn newTi $ scTables sc +addColToCache + :: (QErrM m, CacheRWM m) + => PGCol -> PGColInfo + -> QualifiedTable -> m () +addColToCache cn ci = + addFldToCache (fromPGCol cn) (FIColumn ci) + +addRelToCache + :: (QErrM m, CacheRWM m) + => RelName -> RelInfo -> [SchemaDependency] + -> QualifiedTable -> m () +addRelToCache rn ri deps tn = do + addFldToCache (fromRel rn) (FIRelationship ri) tn + modDepMapInCache (addToDepMap schObjId deps) + where + schObjId = SOTableObj tn $ TORel $ riName ri + addFldToCache :: (QErrM m, CacheRWM m) - => FieldName -> FieldInfo -> [SchemaDependency] + => FieldName -> FieldInfo -> QualifiedTable -> m () -addFldToCache fn fi deps = +addFldToCache fn fi = modTableInCache modFieldInfoMap where modFieldInfoMap ti = do @@ -623,6 +600,19 @@ delFldFromCache fn = ti { tiFieldInfoMap = M.delete fn fim } Nothing -> throw500 "field does not exist" +delColFromCache :: (QErrM m, CacheRWM m) + => PGCol -> QualifiedTable -> m () +delColFromCache cn = + delFldFromCache (fromPGCol cn) + +delRelFromCache :: (QErrM m, CacheRWM m) + => RelName -> QualifiedTable -> m () +delRelFromCache rn tn = do + delFldFromCache (fromRel rn) tn + modDepMapInCache (removeFromDepMap schObjId) + where + schObjId = SOTableObj tn $ TORel rn + data PermAccessor a where PAInsert :: PermAccessor InsPermInfo PASelect :: PermAccessor SelPermInfo @@ -657,7 +647,7 @@ addEventTriggerToCache -> T.Text -> [EventHeaderInfo] -> m () -addEventTriggerToCache qt trid trn tdef rconf webhook headers = +addEventTriggerToCache qt trid trn tdef rconf webhook headers = do modTableInCache modEventTriggerInfo qt where modEventTriggerInfo ti = do @@ -673,18 +663,21 @@ addEventTriggerToCache qt trid trn tdef rconf webhook headers = etim = tiEventTriggerInfoMap ti -- fail $ show (toJSON eti) return $ ti { tiEventTriggerInfoMap = M.insert trn eti etim} + schObjId = SOTableObj qt $ TOTrigger trn delEventTriggerFromCache :: (QErrM m, CacheRWM m) => QualifiedTable -> TriggerName -> m () -delEventTriggerFromCache qt trn = +delEventTriggerFromCache qt trn = do modTableInCache modEventTriggerInfo qt + modDepMapInCache (removeFromDepMap schObjId) where modEventTriggerInfo ti = do let etim = tiEventTriggerInfoMap ti return $ ti { tiEventTriggerInfoMap = M.delete trn etim } + schObjId = SOTableObj qt $ TOTrigger trn addPermToCache :: (QErrM m, CacheRWM m) @@ -694,8 +687,9 @@ addPermToCache -> a -> [SchemaDependency] -> m () -addPermToCache tn rn pa i deps = +addPermToCache tn rn pa i deps = do modTableInCache modRolePermInfo tn + modDepMapInCache (addToDepMap schObjId deps) where paL = permAccToLens pa modRolePermInfo ti = do @@ -704,6 +698,7 @@ addPermToCache tn rn pa i deps = newRPI = rpi & paL ?~ i assertPermNotExists pa rpi return $ ti { tiRolePermInfoMap = M.insert rn newRPI rpim } + schObjId = SOTableObj tn $ TOPerm rn $ permAccToType pa assertPermNotExists :: (QErrM m) @@ -725,8 +720,9 @@ delPermFromCache -> RoleName -> QualifiedTable -> m () -delPermFromCache pa rn = - modTableInCache modRolePermInfo +delPermFromCache pa rn tn = do + modTableInCache modRolePermInfo tn + modDepMapInCache (removeFromDepMap schObjId) where paL = permAccToLens pa modRolePermInfo ti = do @@ -735,6 +731,7 @@ delPermFromCache pa rn = assertPermExists pa rpi let newRPI = rpi & paL .~ Nothing return $ ti { tiRolePermInfoMap = M.insert rn newRPI rpim } + schObjId = SOTableObj tn $ TOPerm rn $ permAccToType pa data TemplateParamInfo = TemplateParamInfo @@ -742,88 +739,19 @@ data TemplateParamInfo , tpiDefault :: !(Maybe Value) } deriving (Show, Eq) --- getDependentObjs :: SchemaCache -> SchemaObjId -> [SchemaObjId] --- getDependentObjs = getDependentObjsWith (const True) - --- getDependentObjsWith :: (T.Text -> Bool) -> SchemaCache -> SchemaObjId -> [SchemaObjId] --- getDependentObjsWith f sc objId = --- HS.toList $ getDependentObjsRWith f HS.empty sc objId - getDependentObjs :: SchemaCache -> SchemaObjId -> [SchemaObjId] getDependentObjs = getDependentObjsWith (const True) getDependentObjsWith :: (T.Text -> Bool) -> SchemaCache -> SchemaObjId -> [SchemaObjId] getDependentObjsWith f sc objId = - [ sdObjId sd | sd <- filter (f . sdReason) allDeps] + -- [ sdObjId sd | sd <- filter (f . sdReason) allDeps] + map fst $ filter (isDependency . snd) $ M.toList $ scDepMap sc where - allDeps = fromMaybe [] $ M.lookup objId $ scDepMap sc - --- getDependentObjsRWith :: (T.Text -> Bool) --- -> HS.HashSet SchemaObjId --- -> SchemaCache -> SchemaObjId --- -> HS.HashSet SchemaObjId --- getDependentObjsRWith f visited sc objId = --- foldr go visited thisLevelDeps --- where --- thisLevelDeps = concatMap (getDependentObjsOfTableWith f objId) (scTables sc) --- <> getDependentObjsOfQTemplateCache objId (scQTemplates sc) --- go lObjId vis = --- if HS.member lObjId vis --- then vis --- else getDependentObjsRWith f (HS.insert lObjId vis) sc lObjId - --- getDependentObjsOfQTemplateCache :: SchemaObjId -> QTemplateCache -> [SchemaObjId] --- getDependentObjsOfQTemplateCache objId qtc = --- map (SOQTemplate . qtiName) $ filter (isDependentOn (const True) objId) $ --- M.elems qtc - --- getDependentObjsOfTable :: SchemaObjId -> TableInfo -> [SchemaObjId] --- getDependentObjsOfTable objId ti = --- rels ++ perms ++ triggers --- where --- rels = getDependentRelsOfTable (const True) objId ti --- perms = getDependentPermsOfTable (const True) objId ti --- triggers = getDependentTriggersOfTable (const True) objId ti - - --- getDependentObjsOfTableWith :: (T.Text -> Bool) -> SchemaObjId -> TableInfo -> [SchemaObjId] --- getDependentObjsOfTableWith f objId ti = --- rels ++ perms ++ triggers --- where --- rels = getDependentRelsOfTable f objId ti --- perms = getDependentPermsOfTable f objId ti --- triggers = getDependentTriggersOfTable f objId ti - --- getDependentRelsOfTable :: (T.Text -> Bool) -> SchemaObjId --- -> TableInfo -> [SchemaObjId] --- getDependentRelsOfTable rsnFn objId (TableInfo tn _ fim _ _ _ _ _) = --- map (SOTableObj tn . TORel . riName) $ --- filter (isDependentOn rsnFn objId) $ getRels fim - --- getDependentPermsOfTable :: (T.Text -> Bool) -> SchemaObjId --- -> TableInfo -> [SchemaObjId] --- getDependentPermsOfTable rsnFn objId (TableInfo tn _ _ rpim _ _ _ _) = --- concat $ flip M.mapWithKey rpim $ --- \rn rpi -> map (SOTableObj tn . TOPerm rn) $ getDependentPerms' rsnFn objId rpi - --- getDependentPerms' :: (T.Text -> Bool) -> SchemaObjId -> RolePermInfo -> [PermType] --- getDependentPerms' rsnFn objId (RolePermInfo mipi mspi mupi mdpi) = --- mapMaybe join --- [ forM mipi $ toPermRow PTInsert --- , forM mspi $ toPermRow PTSelect --- , forM mupi $ toPermRow PTUpdate --- , forM mdpi $ toPermRow PTDelete --- ] --- where --- toPermRow :: forall a. (CachedSchemaObj a) => PermType -> a -> Maybe PermType --- toPermRow pt = --- bool Nothing (Just pt) . isDependentOn rsnFn objId - --- getDependentTriggersOfTable :: (T.Text -> Bool) -> SchemaObjId --- -> TableInfo -> [SchemaObjId] --- getDependentTriggersOfTable rsnFn objId (TableInfo tn _ _ _ _ _ _ et) = --- map (SOTableObj tn . TOTrigger . otiTriggerName ) $ filter (isDependentOn rsnFn objId) $ getTriggers et + isDependency deps = not $ HS.null $ flip HS.filter deps $ + \(SchemaDependency depId reason) -> depId == objId && f reason + + -- allDeps = toList $ fromMaybe HS.empty $ M.lookup objId $ scDepMap sc getOpInfo :: TriggerName -> TableInfo -> Maybe SubscribeOpSpec -> Maybe OpTriggerInfo getOpInfo trn ti mos= fromSubscrOpSpec <$> mos From 6269403fea77163801410c61264e1d4fc077db20 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Wed, 14 Nov 2018 19:13:26 +0530 Subject: [PATCH 04/12] handle deps of triggers --- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 6 +- server/src-lib/Hasura/RQL/DDL/Subscribe.hs | 24 ++++++- .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 63 +++---------------- 3 files changed, 32 insertions(+), 61 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 6afea0d4f4dec..14b9a2a1dec05 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -468,11 +468,9 @@ runSqlP2 (RunSQL t cascade) = do let tn = tiName ti cols = getCols $ tiFieldInfoMap ti forM_ (M.toList $ tiEventTriggerInfoMap ti) $ \(trn, eti) -> do - let insert = otiCols <$> etiInsert eti - update = otiCols <$> etiUpdate eti - delete = otiCols <$> etiDelete eti + let opsDef = etiOpsDef eti trid = etiId eti - liftTx $ mkTriggerQ trid trn tn cols (TriggerOpsDef insert update delete) + liftTx $ mkTriggerQ trid trn tn cols opsDef return $ encode (res :: RunSQLRes) diff --git a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs index 97e0a54fec9fa..3cb78593fec7b 100644 --- a/server/src-lib/Hasura/RQL/DDL/Subscribe.hs +++ b/server/src-lib/Hasura/RQL/DDL/Subscribe.hs @@ -238,7 +238,29 @@ subTableP2Setup qt trid (EventTriggerConf name def webhook webhookFromEnv rconf let headerConfs = fromMaybe [] mheaders webhookInfo <- getWebhookInfoFromConf webhookConf headerInfos <- getHeaderInfosFromConf headerConfs - addEventTriggerToCache qt trid name def rconf webhookInfo headerInfos + let eTrigInfo = EventTriggerInfo trid name def rconf webhookInfo headerInfos + tabDep = SchemaDependency (SOTable qt) "parent" + addEventTriggerToCache qt eTrigInfo (tabDep:getTrigDefDeps qt def) + +getTrigDefDeps :: QualifiedTable -> TriggerOpsDef -> [SchemaDependency] +getTrigDefDeps qt (TriggerOpsDef mIns mUpd mDel) = + mconcat $ catMaybes [ subsOpSpecDeps <$> mIns + , subsOpSpecDeps <$> mUpd + , subsOpSpecDeps <$> mDel + ] + where + subsOpSpecDeps :: SubscribeOpSpec -> [SchemaDependency] + subsOpSpecDeps os = + let cols = getColsFromSub $ sosColumns os + colDeps = flip map cols $ \col -> + SchemaDependency (SOTableObj qt (TOCol col)) "column" + payload = maybe [] getColsFromSub (sosPayload os) + payloadDeps = flip map payload $ \col -> + SchemaDependency (SOTableObj qt (TOCol col)) "payload" + in colDeps <> payloadDeps + getColsFromSub sc = case sc of + SubCStar -> [] + SubCArray pgcols -> pgcols subTableP2 :: (P2C m) => QualifiedTable -> Bool -> EventTriggerConf -> m () subTableP2 qt replace etc = do diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index c7bf622c9485e..51385efdd67c2 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -78,10 +78,8 @@ module Hasura.RQL.Types.SchemaCache , addEventTriggerToCache , delEventTriggerFromCache - , getOpInfo , EventTriggerInfo(..) , EventTriggerInfoMap - , OpTriggerInfo(..) , TableObjId(..) , SchemaObjId(..) @@ -313,22 +311,11 @@ makeLenses ''RolePermInfo type RolePermInfoMap = M.HashMap RoleName RolePermInfo -data OpTriggerInfo - = OpTriggerInfo - { otiTable :: !QualifiedTable - , otiTriggerName :: !TriggerName - , otiCols :: !SubscribeOpSpec - , otiDeps :: ![SchemaDependency] - } deriving (Show, Eq) -$(deriveToJSON (aesonDrop 3 snakeCase) ''OpTriggerInfo) - data EventTriggerInfo = EventTriggerInfo { etiId :: !TriggerId , etiName :: !TriggerName - , etiInsert :: !(Maybe OpTriggerInfo) - , etiUpdate :: !(Maybe OpTriggerInfo) - , etiDelete :: !(Maybe OpTriggerInfo) + , etiOpsDef :: !TriggerOpsDef , etiRetryConf :: !RetryConf , etiWebhookInfo :: !WebhookConfInfo , etiHeaders :: ![EventHeaderInfo] @@ -640,28 +627,16 @@ withPermType PTDelete f = f PADelete addEventTriggerToCache :: (QErrM m, CacheRWM m) => QualifiedTable - -> TriggerId - -> TriggerName - -> TriggerOpsDef - -> RetryConf - -> WebhookConfInfo - -> [EventHeaderInfo] + -> EventTriggerInfo + -> [SchemaDependency] -> m () -addEventTriggerToCache qt trid trn tdef rconf webhookInfo headers = +addEventTriggerToCache qt eti deps = do modTableInCache modEventTriggerInfo qt + modDepMapInCache (addToDepMap schObjId deps) where + trn = etiName eti modEventTriggerInfo ti = do - let eti = EventTriggerInfo - trid - trn - (getOpInfo trn ti $ tdInsert tdef) - (getOpInfo trn ti $ tdUpdate tdef) - (getOpInfo trn ti $ tdDelete tdef) - rconf - webhookInfo - headers - etim = tiEventTriggerInfoMap ti - -- fail $ show (toJSON eti) + let etim = tiEventTriggerInfoMap ti return $ ti { tiEventTriggerInfoMap = M.insert trn eti etim} schObjId = SOTableObj qt $ TOTrigger trn @@ -752,27 +727,3 @@ getDependentObjsWith f sc objId = \(SchemaDependency depId reason) -> depId == objId && f reason -- allDeps = toList $ fromMaybe HS.empty $ M.lookup objId $ scDepMap sc - -getOpInfo :: TriggerName -> TableInfo -> Maybe SubscribeOpSpec -> Maybe OpTriggerInfo -getOpInfo trn ti mos= fromSubscrOpSpec <$> mos - where - fromSubscrOpSpec :: SubscribeOpSpec -> OpTriggerInfo - fromSubscrOpSpec os = - let qt = tiName ti - tableDep = SchemaDependency (SOTable qt) ("event trigger " <> trn <> " is dependent on table") - cols = getColsFromSub $ sosColumns os - colDeps = map (\col -> - SchemaDependency (SOTableObj qt (TOCol col)) - ("event trigger " <> trn <> " is dependent on column " <> getPGColTxt col)) - (toList cols) - payload = maybe HS.empty getColsFromSub (sosPayload os) - payloadDeps = map (\col -> - SchemaDependency (SOTableObj qt (TOCol col)) - ("event trigger " <> trn <> " is dependent on column " <> getPGColTxt col)) - (toList payload) - schemaDeps = tableDep : colDeps ++ payloadDeps - in OpTriggerInfo qt trn os schemaDeps - where - getColsFromSub sc = case sc of - SubCStar -> HS.fromList [] - SubCArray pgcols -> HS.fromList pgcols From 5bbdd54fa83b61fd8c20233b14bf81ee0b6ca3e6 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Thu, 15 Nov 2018 12:53:08 +0530 Subject: [PATCH 05/12] clear entries in dep map when dropping the entire table --- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 17 +---------------- server/src-lib/Hasura/RQL/Types/SchemaCache.hs | 4 ++++ 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 14b9a2a1dec05..76e174b85bb02 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -245,22 +245,7 @@ delTableAndDirectDeps qtn@(QualifiedTable sn tn) = do processSchemaChanges :: (P2C m) => SchemaDiff -> m () processSchemaChanges schemaDiff = do -- Purge the dropped tables - forM_ droppedTables $ \qtn@(QualifiedTable sn tn) -> do - liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ [Q.sql| - DELETE FROM "hdb_catalog"."hdb_relationship" - WHERE table_schema = $1 AND table_name = $2 - |] (sn, tn) False - Q.unitQ [Q.sql| - DELETE FROM "hdb_catalog"."hdb_permission" - WHERE table_schema = $1 AND table_name = $2 - |] (sn, tn) False - Q.unitQ [Q.sql| - DELETE FROM "hdb_catalog"."event_triggers" - WHERE schema_name = $1 AND table_name = $2 - |] (sn, tn) False - delTableFromCatalog qtn - delTableFromCache qtn + mapM_ delTableAndDirectDeps droppedTables -- Get schema cache sc <- askSchemaCache forM_ alteredTables $ \(oldQtn, tableDiff) -> do diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 51385efdd67c2..165961245e163 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -515,6 +515,10 @@ delTableFromCache tn = do sc <- askSchemaCache void $ getTableInfoFromCache tn sc modTableCache $ M.delete tn $ scTables sc + modDepMapInCache (M.filterWithKey notThisTableObj) + where + notThisTableObj (SOTableObj depTn _) _ = depTn /= tn + notThisTableObj _ _ = True getTableInfoFromCache :: (QErrM m) => QualifiedTable From 7f735aff089f4bee32811cad18ff87314283c5f6 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Thu, 15 Nov 2018 18:22:14 +0530 Subject: [PATCH 06/12] handle special json encoding of 'and' pressions --- server/src-lib/Hasura/RQL/Types/BoolExp.hs | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/server/src-lib/Hasura/RQL/Types/BoolExp.hs b/server/src-lib/Hasura/RQL/Types/BoolExp.hs index 452fb844990a7..a22841326fa92 100644 --- a/server/src-lib/Hasura/RQL/Types/BoolExp.hs +++ b/server/src-lib/Hasura/RQL/Types/BoolExp.hs @@ -48,11 +48,23 @@ gBoolExpTrue :: GBoolExp a gBoolExpTrue = BoolAnd [] gBoolExpToJSON :: (a -> (Text, Value)) -> GBoolExp a -> Value -gBoolExpToJSON f = \case - BoolAnd bExps -> object ["$and" .= map (gBoolExpToJSON f) bExps ] - BoolOr bExps -> object ["$or" .= map (gBoolExpToJSON f) bExps ] - BoolNot bExp -> object ["$not" .= gBoolExpToJSON f bExp ] - BoolFld a -> object $ pure $ f a +gBoolExpToJSON f be = case be of + -- special encoding for _and + BoolAnd bExps -> + let m = M.fromList $ map getKV bExps + -- if the keys aren't repeated, then object encoding can be used + in if length m == length bExps + then toJSON m + else object $ pure kv + _ -> object $ pure kv + where + kv = getKV be + getKV = \case + BoolAnd bExps -> "_and" .= map (gBoolExpToJSON f) bExps + BoolOr bExps -> "_or" .= map (gBoolExpToJSON f) bExps + BoolNot bExp -> "_not" .= gBoolExpToJSON f bExp + BoolFld a -> f a + parseGBoolExp :: ((Text, Value) -> J.Parser a) -> Value -> J.Parser (GBoolExp a) From 26c5f319fc03b88dbef19709b78468af21ce843c Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Thu, 15 Nov 2018 19:41:16 +0530 Subject: [PATCH 07/12] remove redundant code --- .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index 2208c3c068b6c..31850aa0b1b4e 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -8,7 +8,6 @@ module Hasura.GraphQL.Resolve.BoolExp ( parseBoolExp , pgColValToBoolExpG , pgColValToBoolExp - -- , convertBoolExpG , convertBoolExp , prepare ) where @@ -20,8 +19,6 @@ import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Language.GraphQL.Draft.Syntax as G --- import qualified Hasura.RQL.GBoolExp as RA --- import qualified Hasura.RQL.GBoolExp as RG import qualified Hasura.SQL.DML as S import Hasura.GraphQL.Resolve.Context @@ -126,16 +123,6 @@ parseBoolExp f annGVal = do | otherwise -> BoolFld <$> parseColExp f nt k v parseOpExps return $ BoolAnd $ fromMaybe [] boolExpsM --- convertBoolExpG --- :: (MonadError QErr m, MonadReader r m, Has FieldMap r) --- => ((PGColType, PGColValue) -> m S.SQLExp) --- -> QualifiedTable --- -> AnnGValue --- -> m AnnBoolExpSQL --- convertBoolExpG f tn whereArg = do --- whereExp <- parseBoolExp f whereArg --- traverse f whereExp - convertBoolExp :: AnnGValue -> Convert AnnBoolExpSQL @@ -150,10 +137,10 @@ pgColValToBoolExpG -> PGColValMap -> m AnnBoolExpSQL pgColValToBoolExpG f colValMap = do - colExps <- forM colVals $ \(name, valR) -> do - (ty, val) <- asPGColVal valR + colExps <- forM colVals $ \(name, val) -> do + (ty, _) <- asPGColVal val let namedTy = mkScalarTy ty - BoolFld <$> parseColExp f namedTy name valR parseAsEqOp + BoolFld <$> parseColExp f namedTy name val parseAsEqOp return $ BoolAnd colExps where colVals = Map.toList colValMap From 7542169c40521789469b0200a472e48d293d6da8 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 16 Nov 2018 13:55:20 +0530 Subject: [PATCH 08/12] revert to older type for TableFrom --- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 6 ++--- server/src-lib/Hasura/RQL/DML/Returning.hs | 2 +- server/src-lib/Hasura/RQL/DML/Select.hs | 25 ++++++++----------- .../src-lib/Hasura/RQL/DML/Select/Internal.hs | 15 +++++------ 4 files changed, 23 insertions(+), 25 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 829832af050c5..847078a390b07 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -98,7 +98,7 @@ fromField f tn permFilter permLimitM fld = fieldAsPath fld $ do tableArgs <- parseTableArgs f args annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld - let tabFrom = RS.TableFrom $ Left tn + let tabFrom = RS.TableFrom tn Nothing tabPerm = RS.TablePerm permFilter permLimitM return $ RS.AnnSelG annFlds tabFrom tabPerm tableArgs where @@ -179,7 +179,7 @@ fromFieldByPKey fromFieldByPKey f tn permFilter fld = fieldAsPath fld $ do boolExp <- pgColValToBoolExpG f $ _fArguments fld annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld - let tabFrom = RS.TableFrom $ Left tn + let tabFrom = RS.TableFrom tn Nothing tabPerm = RS.TablePerm permFilter Nothing return $ RS.AnnSelG annFlds tabFrom tabPerm $ RS.noTableArgs { RS._taWhere = Just boolExp} @@ -257,7 +257,7 @@ fromAggField fromAggField fn tn permFilter permLimitM fld = fieldAsPath fld $ do tableArgs <- parseTableArgs fn args aggSelFlds <- fromAggSel (_fType fld) $ _fSelSet fld - let tabFrom = RS.TableFrom $ Left tn + let tabFrom = RS.TableFrom tn Nothing tabPerm = RS.TablePerm permFilter permLimitM return $ RS.AnnSelG aggSelFlds tabFrom tabPerm tableArgs where diff --git a/server/src-lib/Hasura/RQL/DML/Returning.hs b/server/src-lib/Hasura/RQL/DML/Returning.hs index a5a3009a97dab..f678096d4188f 100644 --- a/server/src-lib/Hasura/RQL/DML/Returning.hs +++ b/server/src-lib/Hasura/RQL/DML/Returning.hs @@ -60,7 +60,7 @@ mkMutFldExp qt singleObj = \case MExp t -> S.SELit t MRet selFlds -> -- let tabFrom = TableFrom qt $ Just frmItem - let tabFrom = TableFrom $ Right $ qualTableToAliasIden qt + let tabFrom = TableFrom qt $ Just $ qualTableToAliasIden qt tabPerm = TablePerm annBoolExpTrue Nothing in S.SESelect $ mkSQLSelect singleObj $ AnnSelG selFlds tabFrom tabPerm noTableArgs diff --git a/server/src-lib/Hasura/RQL/DML/Select.hs b/server/src-lib/Hasura/RQL/DML/Select.hs index d853ab31fe375..6841a84345a18 100644 --- a/server/src-lib/Hasura/RQL/DML/Select.hs +++ b/server/src-lib/Hasura/RQL/DML/Select.hs @@ -182,7 +182,7 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do withPathK "limit" $ mapM_ onlyPositiveInt mQueryLimit withPathK "offset" $ mapM_ onlyPositiveInt mQueryOffset - let tabFrom = TableFrom $ Left (spiTable selPermInfo) + let tabFrom = TableFrom (spiTable selPermInfo) Nothing tabPerm = TablePerm (spiFilter selPermInfo) mPermLimit return $ AnnSelG annFlds tabFrom tabPerm $ TableArgs wClause annOrdByM mQueryLimit (S.intToSQLExp <$> mQueryOffset) @@ -249,23 +249,20 @@ getSelectDeps :: AnnSel -> [SchemaDependency] getSelectDeps (AnnSelG flds tabFrm _ tableArgs) = - case tabFrm of - TableFrom (Left tn) -> - mkParentDep tn - : fromMaybe [] (whereDeps tn) - <> colDeps tn - <> relDeps tn - <> nestedDeps - TableFrom (Right _) -> [] + mkParentDep tn + : fromMaybe [] whereDeps + <> colDeps + <> relDeps + <> nestedDeps where - -- TableFrom tn _ = tabFrm + TableFrom tn _ = tabFrm annWc = _taWhere tableArgs (sCols, rCols) = partAnnFlds $ map snd flds - colDeps tn = map (mkColDep "untyped" tn . fst) sCols - relDeps tn = map (mkRelDep tn . arName) rCols + colDeps = map (mkColDep "untyped" tn . fst) sCols + relDeps = map (mkRelDep . arName) rCols nestedDeps = concatMap (getSelectDeps . arAnnSel) rCols - whereDeps tn = getBoolExpDeps tn <$> annWc - mkRelDep tn rn = + whereDeps = getBoolExpDeps tn <$> annWc + mkRelDep rn = SchemaDependency (SOTableObj tn (TORel rn)) "untyped" convSelectQuery diff --git a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs index 38aa44d9787dc..3fb2020378c22 100644 --- a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs @@ -123,18 +123,19 @@ data TableAggFld data TableFrom = TableFrom - { _tfTable :: !(Either QualifiedTable Iden) + { _tfTable :: !QualifiedTable + , _tfIden :: !(Maybe Iden) } deriving (Show, Eq) tableFromToFromItem :: TableFrom -> S.FromItem -tableFromToFromItem (TableFrom tf) = case tf of - Left t -> S.FISimple t Nothing - Right i -> S.FIIden i +tableFromToFromItem = \case + TableFrom tn Nothing -> S.FISimple tn Nothing + TableFrom _ (Just i) -> S.FIIden i tableFromToQual :: TableFrom -> S.Qual -tableFromToQual (TableFrom tf) = case tf of - Left t -> S.QualTable t - Right i -> S.QualIden i +tableFromToQual = \case + TableFrom tn Nothing -> S.QualTable tn + TableFrom _ (Just i) -> S.QualIden i data TablePerm = TablePerm From 01319a982bb4f63345020a235a0e9771d05b3089 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 16 Nov 2018 14:49:33 +0530 Subject: [PATCH 09/12] minor refactor --- .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 19 ++--------- .../src-lib/Hasura/GraphQL/Resolve/Insert.hs | 1 - .../Hasura/GraphQL/Resolve/Mutation.hs | 4 +-- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 2 +- .../src-lib/Hasura/RQL/DML/Select/Internal.hs | 33 ------------------- server/src-lib/Hasura/RQL/Types.hs | 2 +- .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 25 +++++++------- 7 files changed, 18 insertions(+), 68 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index 31850aa0b1b4e..d90a0c858da71 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -6,10 +6,7 @@ module Hasura.GraphQL.Resolve.BoolExp ( parseBoolExp - , pgColValToBoolExpG , pgColValToBoolExp - , convertBoolExp - , prepare ) where import Data.Has @@ -123,20 +120,14 @@ parseBoolExp f annGVal = do | otherwise -> BoolFld <$> parseColExp f nt k v parseOpExps return $ BoolAnd $ fromMaybe [] boolExpsM -convertBoolExp - :: AnnGValue - -> Convert AnnBoolExpSQL -convertBoolExp = - parseBoolExp prepare - type PGColValMap = Map.HashMap G.Name AnnGValue -pgColValToBoolExpG +pgColValToBoolExp :: (MonadError QErr m, MonadReader r m, Has FieldMap r) => ((PGColType, PGColValue) -> m S.SQLExp) -> PGColValMap -> m AnnBoolExpSQL -pgColValToBoolExpG f colValMap = do +pgColValToBoolExp f colValMap = do colExps <- forM colVals $ \(name, val) -> do (ty, _) <- asPGColVal val let namedTy = mkScalarTy ty @@ -144,9 +135,3 @@ pgColValToBoolExpG f colValMap = do return $ BoolAnd colExps where colVals = Map.toList colValMap - -pgColValToBoolExp - :: PGColValMap - -> Convert AnnBoolExpSQL -pgColValToBoolExp = - pgColValToBoolExpG prepare diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs index 7306322a69e04..d47b9b3ceb608 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs @@ -32,7 +32,6 @@ import qualified Hasura.RQL.GBoolExp as RB import qualified Hasura.SQL.DML as S -import Hasura.GraphQL.Resolve.BoolExp import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Resolve.Mutation diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index caa818bbb3c25..e4280c8cbbf28 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -98,7 +98,7 @@ convertUpdate tn filterExp fld = do -- a set expression is same as a row object setExpM <- withArgM args "_set" convertRowObj -- where bool expression to filter column - whereExp <- withArg args "where" convertBoolExp + whereExp <- withArg args "where" (parseBoolExp prepare) -- increment operator on integer columns incExpM <- withArgM args "_inc" $ convObjWithOp $ rhsExpOp S.incOp S.intType @@ -138,7 +138,7 @@ convertDelete -> Field -- the mutation field -> Convert RespTx convertDelete tn filterExp fld = do - whereExp <- withArg (_fArguments fld) "where" convertBoolExp + whereExp <- withArg (_fArguments fld) "where" (parseBoolExp prepare) mutFlds <- convertMutResp (_fType fld) $ _fSelSet fld args <- get let p1 = RD.DeleteQueryP1 tn (filterExp, whereExp) mutFlds diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 847078a390b07..ddd6433b1cb2f 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -177,7 +177,7 @@ fromFieldByPKey => ((PGColType, PGColValue) -> m S.SQLExp) -> QualifiedTable -> AnnBoolExpSQL -> Field -> m RS.AnnSel fromFieldByPKey f tn permFilter fld = fieldAsPath fld $ do - boolExp <- pgColValToBoolExpG f $ _fArguments fld + boolExp <- pgColValToBoolExp f $ _fArguments fld annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld let tabFrom = RS.TableFrom tn Nothing tabPerm = RS.TablePerm permFilter Nothing diff --git a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs index 3fb2020378c22..3c25ed6ea06ce 100644 --- a/server/src-lib/Hasura/RQL/DML/Select/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Select/Internal.hs @@ -365,39 +365,6 @@ processAnnOrderByCol pfx = \case , Just (rn, relNode) ) --- processAnnOrderByCol --- :: Iden --- -> AnnObCol --- -- the extractors which will select the needed columns --- -> ( (S.Alias, S.SQLExp) --- -- optionally we may have to add an obj rel node --- , Maybe (RelName, RelNode) --- ) --- processAnnOrderByCol pfx = \case --- AOCPG colInfo -> --- let --- qualCol = S.mkQIdenExp (mkBaseTableAls pfx) (toIden $ pgiName colInfo) --- obColAls = mkBaseTableColAls pfx $ pgiName colInfo --- in ( (S.Alias obColAls, qualCol) --- , Nothing --- ) --- -- "pfx.or.relname"."pfx.ob.or.relname.rest" AS "pfx.ob.or.relname.rest" --- AOCRel (RelInfo rn _ colMapping relTab _) relFltr rest -> --- let relPfx = mkObjRelTableAls pfx rn --- ((nesAls, nesCol), nesNodeM) = processAnnOrderByCol relPfx rest --- qualCol = S.mkQIdenExp relPfx nesAls --- relBaseNode = ANSimple $ --- BaseNode relPfx (S.FISimple relTab Nothing) --- (toSQLBoolExp (S.QualTable relTab) relFltr) --- Nothing Nothing Nothing --- (HM.singleton nesAls nesCol) --- (maybe HM.empty (uncurry HM.singleton) nesNodeM) --- HM.empty --- relNode = RelNode rn (fromRel rn) colMapping relBaseNode --- in ( (nesAls, qualCol) --- , Just (rn, relNode) --- ) - mkEmptyBaseNode :: Iden -> TableFrom -> BaseNode mkEmptyBaseNode pfx tableFrom = BaseNode pfx fromItem (S.BELit True) Nothing Nothing Nothing diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index 4be2d438b131d..8c5ac35be6175 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -118,7 +118,7 @@ data QCtx = QCtx { qcUserInfo :: !UserInfo , qcSchemaCache :: !SchemaCache - } deriving (Show) + } deriving (Show, Eq) class HasQCtx a where getQCtx :: a -> QCtx diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 165961245e163..309fe72d01e96 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -254,15 +254,11 @@ data InsPermInfo , ipiCheck :: !AnnBoolExpSQL , ipiAllowUpsert :: !Bool , ipiSet :: !InsSetCols - -- , ipiDeps :: ![SchemaDependency] , ipiRequiredHeaders :: ![T.Text] - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''InsPermInfo) --- instance CachedSchemaObj InsPermInfo where --- dependsOn = ipiDeps - data SelPermInfo = SelPermInfo { spiCols :: !(HS.HashSet PGCol) @@ -270,9 +266,8 @@ data SelPermInfo , spiFilter :: !AnnBoolExpSQL , spiLimit :: !(Maybe Int) , spiAllowAgg :: !Bool - -- , spiDeps :: ![SchemaDependency] , spiRequiredHeaders :: ![T.Text] - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''SelPermInfo) @@ -282,7 +277,7 @@ data UpdPermInfo , upiTable :: !QualifiedTable , upiFilter :: !AnnBoolExpSQL , upiRequiredHeaders :: ![T.Text] - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''UpdPermInfo) @@ -291,7 +286,7 @@ data DelPermInfo { dpiTable :: !QualifiedTable , dpiFilter :: !AnnBoolExpSQL , dpiRequiredHeaders :: ![T.Text] - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 3 snakeCase) ''DelPermInfo) @@ -304,7 +299,7 @@ data RolePermInfo , _permSel :: !(Maybe SelPermInfo) , _permUpd :: !(Maybe UpdPermInfo) , _permDel :: !(Maybe DelPermInfo) - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 5 snakeCase) ''RolePermInfo) makeLenses ''RolePermInfo @@ -397,7 +392,7 @@ data TableInfo , tiPrimaryKeyCols :: ![PGCol] , tiViewInfo :: !(Maybe ViewInfo) , tiEventTriggerInfoMap :: !EventTriggerInfoMap - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 2 snakeCase) ''TableInfo) @@ -435,7 +430,7 @@ data SchemaCache { scTables :: !TableCache , scQTemplates :: !QTemplateCache , scDepMap :: !DepMap - } deriving (Show) + } deriving (Show, Eq) $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaCache) @@ -728,6 +723,10 @@ getDependentObjsWith f sc objId = map fst $ filter (isDependency . snd) $ M.toList $ scDepMap sc where isDependency deps = not $ HS.null $ flip HS.filter deps $ - \(SchemaDependency depId reason) -> depId == objId && f reason + \(SchemaDependency depId reason) -> objId `induces` depId && f reason + -- induces a b : is b dependent on a + induces (SOTable tn1) (SOTable tn2) = tn1 == tn2 + induces (SOTable tn1) (SOTableObj tn2 _) = tn1 == tn2 + induces objId1 objId2 = objId1 == objId2 -- allDeps = toList $ fromMaybe HS.empty $ M.lookup objId $ scDepMap sc From 664e9e933c78b5fb80d92939b8e04e5c3650796f Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 16 Nov 2018 16:01:46 +0530 Subject: [PATCH 10/12] remove more dead code --- server/src-lib/Hasura/RQL/DML/Internal.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/server/src-lib/Hasura/RQL/DML/Internal.hs b/server/src-lib/Hasura/RQL/DML/Internal.hs index aceaafbe69537..27e7b41fd6574 100644 --- a/server/src-lib/Hasura/RQL/DML/Internal.hs +++ b/server/src-lib/Hasura/RQL/DML/Internal.hs @@ -24,9 +24,6 @@ import qualified Data.HashSet as HS import qualified Data.Sequence as DS import qualified Data.Text as T --- class (P1C m) => Preparable m where --- prepValBuilder :: PGColType -> Value -> m S.SQLExp - type DMLP1 = StateT (DS.Seq Q.PrepArg) P1 instance CacheRM DMLP1 where @@ -35,12 +32,6 @@ instance CacheRM DMLP1 where instance UserInfoM DMLP1 where askUserInfo = lift askUserInfo --- instance P1C DMLP1 where --- askUserInfo = lift askUserInfo - --- instance Preparable DMLP1 where --- prepValBuilder = binRHSBuilder - peelDMLP1 :: QCtx -> DMLP1 a -> Either QErr (a, [Q.PrepArg]) peelDMLP1 qEnv m = do (a, prepSeq) <- runP1 qEnv $ runStateT m DS.empty @@ -202,17 +193,6 @@ checkSelPerm checkSelPerm spi = traverse (checkOnColExp spi) --- convBoolExp --- :: (P1C m) --- => FieldInfoMap --- -> QualifiedTable --- -> SelPermInfo --- -> BoolExp --- -> (PGColType -> Value -> m S.SQLExp) --- -> m S.BoolExp --- convBoolExp cim tn spi be prepValBuilder = --- cBoolExp <$> convBoolExp' cim tn spi be prepValBuilder - convBoolExp' :: (P1C m) => FieldInfoMap From a80bc41f7e5560cb37904ee455abc6709e9b63aa Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 16 Nov 2018 16:15:10 +0530 Subject: [PATCH 11/12] fix few warnings --- server/src-lib/Hasura/Server/Auth/JWT.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/server/src-lib/Hasura/Server/Auth/JWT.hs b/server/src-lib/Hasura/Server/Auth/JWT.hs index a7f466fbfbe27..ba4f10e378b00 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -31,8 +31,7 @@ import Hasura.Prelude import Hasura.RQL.Types import Hasura.Server.Auth.JWT.Internal (parseHmacKey, parseRsaKey) import Hasura.Server.Auth.JWT.Logging -import Hasura.Server.Utils (accessKeyHeader, bsToTxt, - userRoleHeader) +import Hasura.Server.Utils (bsToTxt, userRoleHeader) import qualified Control.Concurrent as C import qualified Data.Aeson as A @@ -66,10 +65,11 @@ data JWTCtx { jcxKey :: !(IORef JWKSet) , jcxClaimNs :: !(Maybe T.Text) , jcxAudience :: !(Maybe T.Text) - } deriving (Show, Eq) + } deriving (Eq) -instance Show (IORef JWKSet) where - show _ = "" +instance Show JWTCtx where + show (JWTCtx _ nsM audM) = + show ["", show nsM, show audM] data HasuraClaims = HasuraClaims From b973f39d3f45892adc9be3efcc4350ca7b7a586a Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Fri, 16 Nov 2018 17:31:14 +0530 Subject: [PATCH 12/12] add tests --- .../basic/self_referential_relationships.yaml | 35 ++++++++++ .../graphql_query/boolexp/basic/setup.yaml | 66 ++++++++++++++++++- .../graphql_query/boolexp/basic/teardown.yaml | 7 +- server/tests-py/test_graphql_queries.py | 3 + 4 files changed, 107 insertions(+), 4 deletions(-) create mode 100644 server/tests-py/queries/graphql_query/boolexp/basic/self_referential_relationships.yaml diff --git a/server/tests-py/queries/graphql_query/boolexp/basic/self_referential_relationships.yaml b/server/tests-py/queries/graphql_query/boolexp/basic/self_referential_relationships.yaml new file mode 100644 index 0000000000000..9d68a92293dea --- /dev/null +++ b/server/tests-py/queries/graphql_query/boolexp/basic/self_referential_relationships.yaml @@ -0,0 +1,35 @@ +description: Self referential relationships +url: /v1alpha1/graphql +status: 200 +response: + data: + m1: + - id: 1 + - id: 4 + - id: 6 + level1: + - id: 2 + - id: 3 + - id: 5 + - id: 6 +query: + query: | + query { + m1: message ( + where : { + _or: [ + {content: {_ilike: "%hello%"}} + {children: {content: {_ilike: "%hello%"}}} + ] + } + ) { + id + } + level1: message ( + where : { + parent: {parent_id: {_is_null: true}} + } + ) { + id + } + } diff --git a/server/tests-py/queries/graphql_query/boolexp/basic/setup.yaml b/server/tests-py/queries/graphql_query/boolexp/basic/setup.yaml index d8d452cf8fa9c..6ab57be4a3dfd 100644 --- a/server/tests-py/queries/graphql_query/boolexp/basic/setup.yaml +++ b/server/tests-py/queries/graphql_query/boolexp/basic/setup.yaml @@ -6,7 +6,7 @@ args: args: sql: | create table author( - id serial primary key, + id serial primary key, name text unique, is_registered boolean not null default false ); @@ -86,6 +86,66 @@ args: column: author_id +#Message table +- type: run_sql + args: + sql: | + CREATE TABLE message ( + id int PRIMARY KEY, + content TEXT NOT NULL, + parent_id INT NULL + ); + alter table message + add constraint parent_fk foreign key (parent_id) + references message(id) + +- type: track_table + args: + schema: public + name: message + +# parent obj rel +- type: create_object_relationship + args: + table: message + name: parent + using: + foreign_key_constraint_on: parent_id + +# children array rel +- type: create_array_relationship + args: + table: message + name: children + using: + foreign_key_constraint_on: + table: message + column: parent_id + +#Insert messages +- type: insert + args: + table: message + objects: + - id: 1 + content: "hello world" + parent_id: null + - id: 2 + content: "content 2" + parent_id: 1 + - id: 3 + content: "content 3" + parent_id: 1 + - id: 4 + content: "ahoy" + parent_id: null + - id: 5 + content: "content 5" + parent_id: 4 + - id: 6 + content: "hello there" + parent_id: 4 + #Insert Authors - type: insert args: @@ -134,12 +194,12 @@ args: table: city objects: - name: Durham - country: USA + country: USA - name: New York country: USA - name: Framlingham country: UK - - name: New Orleans + - name: New Orleans country: USA - type: insert diff --git a/server/tests-py/queries/graphql_query/boolexp/basic/teardown.yaml b/server/tests-py/queries/graphql_query/boolexp/basic/teardown.yaml index 44eed5b73d22a..9d3a2e2b6b441 100644 --- a/server/tests-py/queries/graphql_query/boolexp/basic/teardown.yaml +++ b/server/tests-py/queries/graphql_query/boolexp/basic/teardown.yaml @@ -7,7 +7,7 @@ args: table: schema: public name: author - + - type: run_sql args: sql: | @@ -27,3 +27,8 @@ args: args: sql: | drop table orders + +- type: run_sql + args: + sql: | + drop table message diff --git a/server/tests-py/test_graphql_queries.py b/server/tests-py/test_graphql_queries.py index 0f1ad537fc406..edf323d6fce86 100644 --- a/server/tests-py/test_graphql_queries.py +++ b/server/tests-py/test_graphql_queries.py @@ -166,6 +166,9 @@ def test_article_author_not_published_nor_registered(self, hge_ctx): def test_article_author_unexpected_operator_in_where_err(self, hge_ctx): check_query_f(hge_ctx, self.dir() + '/select_author_article_unexpected_operator_in_where_err.yaml') + def test_self_referential_relationships(self, hge_ctx): + check_query_f(hge_ctx, self.dir() + '/self_referential_relationships.yaml') + @classmethod def dir(cls): return 'queries/graphql_query/boolexp/basic'