From 42ec0fff3a140df053d4ef6015ce5953266dd278 Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Tue, 19 Mar 2019 16:57:19 +0530 Subject: [PATCH] add type, variable information to input value's ast --- .../src-lib/Hasura/GraphQL/Resolve/BoolExp.hs | 16 ++- .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 34 ++++-- .../Hasura/GraphQL/Resolve/InputValue.hs | 83 +++++++------- .../src-lib/Hasura/GraphQL/Resolve/Insert.hs | 46 ++++---- .../Hasura/GraphQL/Resolve/Introspect.hs | 35 +++--- .../Hasura/GraphQL/Resolve/Mutation.hs | 10 +- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 12 +-- .../src-lib/Hasura/GraphQL/Validate/Field.hs | 6 +- .../Hasura/GraphQL/Validate/InputValue.hs | 101 ++++++++++-------- .../src-lib/Hasura/GraphQL/Validate/Types.hs | 32 +++--- .../boolexp/postgis/query_using_polygon.yaml | 2 +- 11 files changed, 210 insertions(+), 167 deletions(-) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs index b46f1f069282d..cc9213a82a6bc 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/BoolExp.hs @@ -14,15 +14,13 @@ import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Validate.Types import Hasura.RQL.Types - -import Hasura.SQL.Types import Hasura.SQL.Value -type OpExp = OpExpG (PGColType, PGColValue) +type OpExp = OpExpG AnnPGVal parseOpExps :: (MonadError QErr m) - => AnnGValue -> m [OpExp] + => AnnInpVal -> m [OpExp] parseOpExps annVal = do opExpsM <- flip withObjectM annVal $ \nt objM -> forM objM $ \obj -> forM (OMap.toList obj) $ \(k, v) -> case k of @@ -73,7 +71,7 @@ parseOpExps annVal = do <> showName k return $ catMaybes $ fromMaybe [] opExpsM where - resolveIsNull v = case v of + resolveIsNull v = case _aivValue v of AGScalar _ Nothing -> return Nothing AGScalar _ (Just (PGValBoolean b)) -> return $ Just $ bool ANISNOTNULL ANISNULL b @@ -91,14 +89,14 @@ parseOpExps annVal = do parseAsEqOp :: (MonadError QErr m) - => AnnGValue -> m [OpExp] + => AnnInpVal -> m [OpExp] parseAsEqOp annVal = do annValOpExp <- AEQ True <$> asPGColVal annVal return [annValOpExp] parseColExp :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => PrepFn m -> G.NamedType -> G.Name -> AnnGValue + => PrepFn m -> G.NamedType -> G.Name -> AnnInpVal -> m AnnBoolExpFldSQL parseColExp f nt n val = do fldInfo <- getFldInfo nt n @@ -112,7 +110,7 @@ parseColExp f nt n val = do parseBoolExp :: (MonadError QErr m, MonadReader r m, Has FieldMap r) - => PrepFn m -> AnnGValue -> m AnnBoolExpSQL + => PrepFn m -> AnnInpVal -> m AnnBoolExpSQL parseBoolExp f annGVal = do boolExpsM <- flip withObjectM annGVal @@ -125,7 +123,7 @@ parseBoolExp f annGVal = do | otherwise -> BoolFld <$> parseColExp f nt k v return $ BoolAnd $ fromMaybe [] boolExpsM -type PGColValMap = Map.HashMap G.Name AnnGValue +type PGColValMap = Map.HashMap G.Name AnnInpVal pgColValToBoolExp :: (MonadError QErr m) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index 93b4c45321c2d..60d2b10460954 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -12,6 +12,7 @@ module Hasura.GraphQL.Resolve.Context , InsCtxMap , RespTx , LazyRespTx + , AnnPGVal(..) , PrepFn , InsertTxConflictCtx(..) , getFldInfo @@ -24,6 +25,7 @@ module Hasura.GraphQL.Resolve.Context , Convert , runConvert , prepare + , prepareColVal , txtConverter , module Hasura.GraphQL.Utils ) where @@ -61,7 +63,16 @@ $(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''InsResp) type RespTx = Q.TxE QErr EncJSON type LazyRespTx = LazyTx QErr EncJSON -type PrepFn m = (PGColType, PGColValue) -> m S.SQLExp + +type PrepFn m = AnnPGVal -> m S.SQLExp + +data AnnPGVal + = AnnPGVal + { _apvVariable :: !(Maybe G.Variable) + , _apvIsNullable :: !Bool + , _apvType :: !PGColType + , _apvValue :: !PGColValue + } deriving (Show, Eq) getFldInfo :: (MonadError QErr m, MonadReader r m, Has FieldMap r) @@ -88,7 +99,7 @@ getArg :: (MonadError QErr m) => ArgsMap -> G.Name - -> m AnnGValue + -> m AnnInpVal getArg args arg = onNothing (Map.lookup arg args) $ throw500 $ "missing argument: " <> showName arg @@ -107,7 +118,7 @@ withArg :: (MonadError QErr m) => ArgsMap -> G.Name - -> (AnnGValue -> m a) + -> (AnnInpVal -> m a) -> m a withArg args arg f = prependArgsInPath $ nameAsPath arg $ getArg args arg >>= f @@ -116,12 +127,13 @@ withArgM :: (MonadError QErr m) => ArgsMap -> G.Name - -> (AnnGValue -> m a) + -> (AnnInpVal -> m a) -> m (Maybe a) withArgM args arg f = prependArgsInPath $ nameAsPath arg $ mapM f $ handleNull =<< Map.lookup arg args where - handleNull v = bool (Just v) Nothing $ hasNullVal v + handleNull v = bool (Just v) Nothing $ + hasNullVal $ _aivValue v type PrepArgs = Seq.Seq Q.PrepArg @@ -135,13 +147,21 @@ type Convert = prepare :: (MonadState PrepArgs m) => PrepFn m -prepare (colTy, colVal) = do +prepare (AnnPGVal _ _ colTy colVal) = + prepareColVal colTy colVal + +prepareColVal + :: (MonadState PrepArgs m) + => PGColType -> PGColValue -> m S.SQLExp +prepareColVal colTy colVal = do preparedArgs <- get put (preparedArgs Seq.|> binEncoder colVal) return $ toPrepParam (Seq.length preparedArgs + 1) colTy + txtConverter :: Monad m => PrepFn m -txtConverter = return . uncurry toTxtValue +txtConverter (AnnPGVal _ _ a b) = + return $ toTxtValue a b runConvert :: (MonadError QErr m) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs b/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs index 3e661301c8405..57ba9d242729f 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/InputValue.hs @@ -13,17 +13,17 @@ module Hasura.GraphQL.Resolve.InputValue , withArrayM , parseMany , asPGColText + , AnnPGVal ) where import Hasura.Prelude -import qualified Data.Text as T -import qualified Language.GraphQL.Draft.Syntax as G +import qualified Data.Text as T +import qualified Language.GraphQL.Draft.Syntax as G -import Hasura.GraphQL.Utils +import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Validate.Types import Hasura.RQL.Types -import Hasura.SQL.Types import Hasura.SQL.Value withNotNull @@ -34,98 +34,103 @@ withNotNull nt v = "unexpected null for a value of type " <> showNamedTy nt tyMismatch - :: (MonadError QErr m) => Text -> AnnGValue -> m a + :: (MonadError QErr m) => Text -> AnnInpVal -> m a tyMismatch expectedTy v = throw500 $ "expected " <> expectedTy <> ", found " <> - getAnnInpValKind v <> " for value of type " <> - G.showGT (getAnnInpValTy v) + getAnnInpValKind (_aivValue v) <> " for value of type " <> + G.showGT (_aivType v) asPGColValM :: (MonadError QErr m) - => AnnGValue -> m (Maybe (PGColType, PGColValue)) -asPGColValM = \case - AGScalar colTy valM -> return $ fmap (colTy,) valM - v -> tyMismatch "pgvalue" v + => AnnInpVal -> m (Maybe AnnPGVal) +asPGColValM annInpVal = case val of + AGScalar colTy valM -> + return $ fmap (AnnPGVal varM (G.isNullable ty) colTy) valM + _ -> + tyMismatch "pgvalue" annInpVal + where + AnnInpVal ty varM val = annInpVal asPGColVal :: (MonadError QErr m) - => AnnGValue -> m (PGColType, PGColValue) -asPGColVal = \case - AGScalar colTy (Just val) -> return (colTy, val) - AGScalar colTy Nothing -> + => AnnInpVal -> m AnnPGVal +asPGColVal v = case _aivValue v of + AGScalar colTy (Just val) -> + return $ AnnPGVal (_aivVariable v) (G.isNullable (_aivType v)) colTy val + AGScalar colTy Nothing -> throw500 $ "unexpected null for ty " <> T.pack (show colTy) - v -> tyMismatch "pgvalue" v + _ -> tyMismatch "pgvalue" v asEnumVal :: (MonadError QErr m) - => AnnGValue -> m (G.NamedType, G.EnumValue) -asEnumVal = \case + => AnnInpVal -> m (G.NamedType, G.EnumValue) +asEnumVal v = case _aivValue v of AGEnum ty (Just val) -> return (ty, val) AGEnum ty Nothing -> throw500 $ "unexpected null for ty " <> showNamedTy ty - v -> tyMismatch "enum" v + _ -> tyMismatch "enum" v withObject :: (MonadError QErr m) - => (G.NamedType -> AnnGObject -> m a) -> AnnGValue -> m a -withObject fn v = case v of + => (G.NamedType -> AnnGObject -> m a) -> AnnInpVal -> m a +withObject fn v = case _aivValue v of AGObject nt (Just obj) -> fn nt obj - AGObject nt Nothing -> + AGObject _ Nothing -> throw500 $ "unexpected null for ty" - <> G.showGT (G.TypeNamed (G.Nullability True) nt) - _ -> tyMismatch "object" v + <> G.showGT (_aivType v) + _ -> tyMismatch "object" v asObject :: (MonadError QErr m) - => AnnGValue -> m AnnGObject + => AnnInpVal -> m AnnGObject asObject = withObject (\_ o -> return o) withObjectM :: (MonadError QErr m) - => (G.NamedType -> Maybe AnnGObject -> m a) -> AnnGValue -> m a -withObjectM fn v = case v of + => (G.NamedType -> Maybe AnnGObject -> m a) -> AnnInpVal -> m a +withObjectM fn v = case _aivValue v of AGObject nt objM -> fn nt objM _ -> tyMismatch "object" v asObjectM :: (MonadError QErr m) - => AnnGValue -> m (Maybe AnnGObject) + => AnnInpVal -> m (Maybe AnnGObject) asObjectM = withObjectM (\_ o -> return o) withArrayM :: (MonadError QErr m) - => (G.ListType -> Maybe [AnnGValue] -> m a) -> AnnGValue -> m a -withArrayM fn v = case v of + => (G.ListType -> Maybe [AnnInpVal] -> m a) -> AnnInpVal -> m a +withArrayM fn v = case _aivValue v of AGArray lt listM -> fn lt listM _ -> tyMismatch "array" v withArray :: (MonadError QErr m) - => (G.ListType -> [AnnGValue] -> m a) -> AnnGValue -> m a -withArray fn v = case v of + => (G.ListType -> [AnnInpVal] -> m a) -> AnnInpVal -> m a +withArray fn v = case _aivValue v of AGArray lt (Just l) -> fn lt l - AGArray lt Nothing -> throw500 $ "unexpected null for ty" - <> G.showGT (G.TypeList (G.Nullability True) lt) + AGArray _ Nothing -> throw500 $ "unexpected null for ty" + <> G.showGT (_aivType v) _ -> tyMismatch "array" v asArray :: (MonadError QErr m) - => AnnGValue -> m [AnnGValue] + => AnnInpVal -> m [AnnInpVal] asArray = withArray (\_ vals -> return vals) parseMany :: (MonadError QErr m) - => (AnnGValue -> m a) -> AnnGValue -> m (Maybe [a]) -parseMany fn v = case v of + => (AnnInpVal -> m a) -> AnnInpVal -> m (Maybe [a]) +parseMany fn v = case _aivValue v of AGArray _ arrM -> mapM (mapM fn) arrM _ -> tyMismatch "array" v asPGColText :: (MonadError QErr m) - => AnnGValue -> m Text + => AnnInpVal -> m Text asPGColText val = do - (_, pgColVal) <- asPGColVal val + pgColVal <- _apvValue <$> asPGColVal val case pgColVal of PGValText t -> return t _ -> throw500 "expecting text for asPGColText" diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs index 1873a8fd31196..7b1de428c825f 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Insert.hs @@ -98,11 +98,11 @@ mkAnnInsObj relInfoMap annObj = traverseInsObj :: (MonadError QErr m, Has InsCtxMap r, MonadReader r m) => RelationInfoMap - -> (G.Name, AnnGValue) + -> (G.Name, AnnInpVal) -> AnnInsObj -> m AnnInsObj traverseInsObj rim (gName, annVal) defVal@(AnnInsObj cols objRels arrRels) = - case annVal of + case _aivValue annVal of AGScalar colty mColVal -> do let col = PGCol $ G.unName gName colVal = fromMaybe (PGNull colty) mColVal @@ -149,15 +149,15 @@ traverseInsObj rim (gName, annVal) defVal@(AnnInsObj cols objRels arrRels) = parseOnConflict :: (MonadError QErr m) => QualifiedTable -> Maybe UpdPermForIns - -> AnnGValue -> m RI.ConflictClauseP1 -parseOnConflict tn updPermM val = withPathK "on_conflict" $ + -> AnnInpVal -> m RI.ConflictClauseP1 +parseOnConflict tn updFiltrM val = withPathK "on_conflict" $ flip withObject val $ \_ obj -> do constraint <- RI.Constraint <$> parseConstraint obj updCols <- getUpdCols obj case updCols of [] -> return $ RI.CP1DoNothing $ Just constraint _ -> do - UpdPermForIns _ updFiltr preSet <- onNothing updPermM $ throw500 + UpdPermForIns _ updFiltr preSet <- onNothing updFiltrM $ throw500 "cannot update columns since update permission is not defined" return $ RI.CP1Update constraint updCols preSet $ toSQLBoolExp (S.mkQual tn) updFiltr @@ -174,22 +174,28 @@ parseOnConflict tn updPermM val = withPathK "on_conflict" $ (_, enumVal) <- asEnumVal v return $ ConstraintName $ G.unName $ G.unEnumValue enumVal -toSQLExps :: (MonadError QErr m, MonadState PrepArgs m) - => [(PGCol, AnnGValue)] -> m [(PGCol, S.SQLExp)] +toSQLExps + :: (MonadError QErr m, MonadState PrepArgs m) + => [(PGCol, PGColType, PGColValue)] + -> m [(PGCol, S.SQLExp)] toSQLExps cols = - forM cols $ \(c, v) -> do - prepExpM <- asPGColValM v >>= mapM prepare - let prepExp = fromMaybe (S.SEUnsafe "NULL") prepExpM + forM cols $ \(c, ty, v) -> do + prepExp <- prepareColVal ty v return (c, prepExp) mkSQLRow :: Map.HashMap PGCol S.SQLExp -> [(PGCol, S.SQLExp)] -> [S.SQLExp] mkSQLRow defVals withPGCol = Map.elems $ Map.union (Map.fromList withPGCol) defVals -mkInsertQ :: MonadError QErr m => QualifiedTable - -> Maybe RI.ConflictClauseP1 -> [(PGCol, AnnGValue)] - -> [PGCol] -> Map.HashMap PGCol S.SQLExp -> RoleName - -> m (CTEExp, Maybe RI.ConflictCtx) +mkInsertQ + :: MonadError QErr m + => QualifiedTable + -> Maybe RI.ConflictClauseP1 + -> [(PGCol, PGColType, PGColValue)] + -> [PGCol] + -> Map.HashMap PGCol S.SQLExp + -> RoleName + -> m (CTEExp, Maybe RI.ConflictCtx) mkInsertQ vn onConflictM insCols tableCols defVals role = do (givenCols, args) <- flip runStateT Seq.Empty $ toSQLExps insCols let sqlConflict = RI.toSQLConflict <$> onConflictM @@ -213,7 +219,8 @@ mkBoolExp tn colInfoVals = mapM (fmap BoolFld . uncurry f) colInfoVals where f ci@(PGColInfo _ colTy _) colVal = - AVCol ci . pure . AEQ True <$> prepare (colTy, colVal) + AVCol ci . pure . AEQ True <$> + prepare (AnnPGVal Nothing True colTy colVal) asSingleObject :: MonadError QErr m @@ -380,7 +387,7 @@ insertObj strfyNum role tn singleObjIns addCols = do objRelDeterminedCols = concatMap snd objInsRes objRelInsCols = mkPGColWithTypeAndVal allCols objRelDeterminedCols addInsCols = mkPGColWithTypeAndVal allCols addCols - finalInsCols = map pgColToAnnGVal (cols <> objRelInsCols <> addInsCols) + finalInsCols = cols <> objRelInsCols <> addInsCols -- prepare final returning columns let arrDepCols = concatMap (map fst . riMapping . _riRelInfo) arrRels @@ -450,7 +457,7 @@ insertMultipleObjects strfyNum role tn multiObjIns addCols mutFlds errP = tableCols = map pgiName tableColInfos (sqlRows, prepArgs) <- flip runStateT Seq.Empty $ do - rowsWithCol <- mapM (toSQLExps . map pgColToAnnGVal) withAddCols + rowsWithCol <- mapM toSQLExps withAddCols return $ map (mkSQLRow defVals) rowsWithCol let insQP1 = RI.InsertQueryP1 tn vn tableCols sqlRows onConflictM mutFlds uniqCols @@ -539,8 +546,3 @@ mkPGColWithTypeAndVal pgColInfos pgColWithVal = mergeListsWith pgColInfos pgColWithVal (\ci (c, _) -> pgiName ci == c) (\ci (c, v) -> (c, pgiType ci, v)) - -pgColToAnnGVal - :: (PGCol, PGColType, PGColValue) - -> (PGCol, AnnGValue) -pgColToAnnGVal (col, colTy, colVal) = (col, pgColValToAnnGVal colTy colVal) diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs index b42a930bb0609..a095b641b2a21 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Introspect.hs @@ -85,8 +85,8 @@ objectTypeR (ObjTyInfo descM n iFaces flds) fld = "description" -> retJ $ fmap G.unDescription descM "interfaces" -> fmap J.toJSON $ mapM (`ifaceR` subFld) $ Set.toList iFaces "fields" -> fmap J.toJSON $ mapM (`fieldR` subFld) $ - sortBy (comparing _fiName) $ - filter notBuiltinFld $ Map.elems flds + sortOn _fiName $ + filter notBuiltinFld $ Map.elems flds _ -> return J.Null notBuiltinFld :: ObjFldInfo -> Bool @@ -98,10 +98,13 @@ notBuiltinFld f = getImplTypes :: (MonadReader t m, Has TypeMap t) => AsObjType -> m [ObjTyInfo] getImplTypes aot = do tyInfo :: TypeMap <- asks getter - return $ sortBy (comparing _otiName) $ Map.elems $ getPossibleObjTypes' tyInfo $ aot + return $ sortOn _otiName $ + Map.elems $ getPossibleObjTypes' tyInfo aot -- 4.5.2.3 -unionR :: (MonadReader t m, MonadError QErr m, Has TypeMap t) => UnionTyInfo -> Field -> m J.Object +unionR + :: (MonadReader t m, MonadError QErr m, Has TypeMap t) + => UnionTyInfo -> Field -> m J.Object unionR u@(UnionTyInfo descM n _) fld = withSubFields (_fSelSet fld) $ \subFld -> case _fName subFld of @@ -109,7 +112,8 @@ unionR u@(UnionTyInfo descM n _) fld = "kind" -> retJ TKUNION "name" -> retJ $ namedTyToTxt n "description" -> retJ $ fmap G.unDescription descM - "possibleTypes" -> fmap J.toJSON $ mapM (`objectTypeR` subFld) =<< getImplTypes (AOTUnion u) + "possibleTypes" -> fmap J.toJSON $ + mapM (`objectTypeR` subFld) =<< getImplTypes (AOTUnion u) _ -> return J.Null -- 4.5.2.4 @@ -123,7 +127,7 @@ ifaceR n fld = do tyInfo <- getTyInfo n case tyInfo of TIIFace ifaceTyInfo -> ifaceR' ifaceTyInfo fld - _ -> throw500 $ "Unknown interface " <> G.unName (G.unNamedType n) + _ -> throw500 $ "Unknown interface " <> showNamedTy n ifaceR' :: ( MonadReader r m, Has TypeMap r @@ -139,9 +143,10 @@ ifaceR' i@(IFaceTyInfo descM n flds) fld = "name" -> retJ $ namedTyToTxt n "description" -> retJ $ fmap G.unDescription descM "fields" -> fmap J.toJSON $ mapM (`fieldR` subFld) $ - sortBy (comparing _fiName) $ + sortOn _fiName $ filter notBuiltinFld $ Map.elems flds - "possibleTypes" -> fmap J.toJSON $ mapM (`objectTypeR` subFld) =<< getImplTypes (AOTIFace i) + "possibleTypes" -> fmap J.toJSON $ mapM (`objectTypeR` subFld) + =<< getImplTypes (AOTIFace i) _ -> return J.Null -- 4.5.2.5 @@ -158,7 +163,7 @@ enumTypeR (EnumTyInfo descM n vals _) fld = "name" -> retJ $ namedTyToTxt n "description" -> retJ $ fmap G.unDescription descM "enumValues" -> fmap J.toJSON $ mapM (enumValueR subFld) $ - sortBy (comparing _eviVal) $ Map.elems vals + sortOn _eviVal $ Map.elems vals _ -> return J.Null -- 4.5.2.6 @@ -176,7 +181,7 @@ inputObjR (InpObjTyInfo descM nt flds _) fld = "name" -> retJ $ namedTyToTxt nt "description" -> retJ $ fmap G.unDescription descM "inputFields" -> fmap J.toJSON $ mapM (inputValueR subFld) $ - sortBy (comparing _iviName) $ Map.elems flds + sortOn _iviName $ Map.elems flds _ -> return J.Null -- 4.5.2.7 @@ -244,7 +249,7 @@ fieldR (ObjFldInfo descM n params ty _) fld = "name" -> retJ $ G.unName n "description" -> retJ $ fmap G.unDescription descM "args" -> fmap J.toJSON $ mapM (inputValueR subFld) $ - sortBy (comparing _iviName) $ Map.elems params + sortOn _iviName $ Map.elems params "type" -> J.toJSON <$> gtypeR ty subFld "isDeprecated" -> retJ False _ -> return J.Null @@ -291,7 +296,7 @@ directiveR fld (DirectiveInfo descM n args locs) = "description" -> retJ $ fmap G.unDescription descM "locations" -> retJ $ map showDirLoc locs "args" -> fmap J.toJSON $ mapM (inputValueR subFld) $ - sortBy (comparing _iviName) $ Map.elems args + sortOn _iviName $ Map.elems args _ -> return J.Null showDirLoc :: G.DirectiveLocation -> Text @@ -320,12 +325,12 @@ schemaR fld = case _fName subFld of "__typename" -> retJT "__Schema" "types" -> fmap J.toJSON $ mapM (namedTypeR' subFld) $ - sortBy (comparing getNamedTy) $ Map.elems tyMap + sortOn getNamedTy $ Map.elems tyMap "queryType" -> J.toJSON <$> namedTypeR (G.NamedType "query_root") subFld "mutationType" -> typeR' "mutation_root" subFld "subscriptionType" -> typeR' "subscription_root" subFld "directives" -> J.toJSON <$> mapM (directiveR subFld) - (sortBy (comparing _diName) defaultDirectives) + (sortOn _diName defaultDirectives) _ -> return J.Null typeR @@ -334,7 +339,7 @@ typeR => Field -> m J.Value typeR fld = do name <- withArg args "name" $ \arg -> do - (_, pgColVal) <- asPGColVal arg + pgColVal <- _apvValue <$> asPGColVal arg case pgColVal of PGValText t -> return t _ -> throw500 "expecting string for name arg of __type" diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index 281629eca79c9..95100ef3ebcec 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -44,7 +44,7 @@ convertMutResp ty selSet = convertRowObj :: (MonadError QErr m, MonadState PrepArgs m) - => AnnGValue + => AnnInpVal -> m [(PGCol, S.SQLExp)] convertRowObj val = flip withObject val $ \_ obj -> @@ -69,10 +69,10 @@ lhsExpOp op annTy (col, e) = convObjWithOp :: (MonadError QErr m) - => ApplySQLOp -> AnnGValue -> m [(PGCol, S.SQLExp)] + => ApplySQLOp -> AnnInpVal -> m [(PGCol, S.SQLExp)] convObjWithOp opFn val = flip withObject val $ \_ obj -> forM (OMap.toList obj) $ \(k, v) -> do - (_, colVal) <- asPGColVal v + colVal <- _apvValue <$> asPGColVal v let pgCol = PGCol $ G.unName k encVal = txtEncoder colVal sqlExp = opFn (pgCol, encVal) @@ -80,11 +80,11 @@ convObjWithOp opFn val = convDeleteAtPathObj :: (MonadError QErr m) - => AnnGValue -> m [(PGCol, S.SQLExp)] + => AnnInpVal -> m [(PGCol, S.SQLExp)] convDeleteAtPathObj val = flip withObject val $ \_ obj -> forM (OMap.toList obj) $ \(k, v) -> do vals <- flip withArray v $ \_ annVals -> mapM asPGColVal annVals - let valExps = map (txtEncoder . snd) vals + let valExps = map (txtEncoder . _apvValue) vals pgCol = PGCol $ G.unName k annEncVal = S.SETyAnn (S.SEArray valExps) S.textArrType sqlExp = S.SEOpApp S.jsonbDeleteAtPathOp diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index b8130d7b66180..1ec16d3c75535 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -153,7 +153,7 @@ parseOrderBy , MonadReader r m , Has OrdByCtx r ) - => AnnGValue -> m [RS.AnnOrderByItem] + => AnnInpVal -> m [RS.AnnOrderByItem] parseOrderBy = fmap concat . withArray f where f _ = mapM (withObject (getAnnObItems id)) @@ -228,9 +228,9 @@ parseOrderByEnum = \case G.EnumValue v -> throw500 $ "enum value " <> showName v <> " not found in type order_by" -parseLimit :: ( MonadError QErr m ) => AnnGValue -> m Int +parseLimit :: ( MonadError QErr m ) => AnnInpVal -> m Int parseLimit v = do - (_, pgColVal) <- asPGColVal v + pgColVal <- _apvValue <$> asPGColVal v limit <- maybe noIntErr return $ pgColValueToInt pgColVal -- validate int value onlyPositiveInt limit @@ -279,7 +279,7 @@ convertSelectByPKey opCtx fld = do SelPkOpCtx qt _ permFilter colArgMap = opCtx -- agg select related -parseColumns :: MonadError QErr m => AnnGValue -> m [PGCol] +parseColumns :: MonadError QErr m => AnnInpVal -> m [PGCol] parseColumns val = flip withArray val $ \_ vals -> forM vals $ \v -> do @@ -293,7 +293,7 @@ convertCount args = do maybe (return S.CTStar) (mkCType isDistinct) columnsM where parseDistinct v = do - (_, val) <- asPGColVal v + val <- _apvValue <$> asPGColVal v case val of PGValBoolean b -> return b _ -> @@ -379,7 +379,7 @@ fromFuncQueryField f qf argSeq isAgg fld = fieldAsPath fld $ do parseFunctionArgs ::(MonadError QErr m) - => PrepFn m -> FuncArgSeq -> AnnGValue -> m [S.SQLExp] + => PrepFn m -> FuncArgSeq -> AnnInpVal -> m [S.SQLExp] parseFunctionArgs fn argSeq val = flip withObject val $ \nTy obj -> fmap toList $ forM argSeq $ \(FuncArgItem argName) -> do diff --git a/server/src-lib/Hasura/GraphQL/Validate/Field.hs b/server/src-lib/Hasura/GraphQL/Validate/Field.hs index 05b317baecea0..0ce137859e53f 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/Field.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/Field.hs @@ -43,7 +43,7 @@ data TypedOperation , _toSelectionSet :: ![Field] } deriving (Show, Eq) -type ArgsMap = Map.HashMap G.Name AnnGValue +type ArgsMap = Map.HashMap G.Name AnnInpVal type SelSet = Seq.Seq Field @@ -140,7 +140,7 @@ withDirectives dirs act = do getIfArg m = do val <- onNothing (Map.lookup "if" m) $ throw500 "missing if argument in the directive" - case val of + case _aivValue val of AGScalar _ (Just (PGValBoolean v)) -> return v _ -> throw500 "did not find boolean scalar for if argument" @@ -169,7 +169,7 @@ processArgs , MonadError QErr m) => ParamMap -> [G.Argument] - -> m (Map.HashMap G.Name AnnGValue) + -> m ArgsMap processArgs fldParams argsL = do args <- onLeft (mkMapWith G._aName argsL) $ \dups -> diff --git a/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs b/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs index dda739b62ca8e..f33357eab8bda 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/InputValue.hs @@ -25,7 +25,7 @@ import Hasura.GraphQL.Validate.Types import Hasura.RQL.Types import Hasura.SQL.Value -newtype P a = P { unP :: Maybe (Either AnnGValue a)} +newtype P a = P { unP :: Maybe (Either (G.Variable, AnnInpVal) a)} pNull :: (Monad m) => m (P a) pNull = return $ P Nothing @@ -36,20 +36,12 @@ pVal = return . P . Just . Right resolveVar :: ( MonadError QErr m , MonadReader ValidationCtx m) - => G.Variable -> m AnnGValue + => G.Variable -> m AnnInpVal resolveVar var = do varVals <- _vcVarVals <$> ask - -- TODO typecheck onNothing (Map.lookup var varVals) $ throwVE $ "no such variable defined in the operation: " <> showName (G.unVariable var) - where - typeCheck expectedTy actualTy = case (expectedTy, actualTy) of - -- named types - (G.TypeNamed _ eTy, G.TypeNamed _ aTy) -> eTy == aTy - -- list types - (G.TypeList _ eTy, G.TypeList _ aTy) -> typeCheck (G.unListType eTy) (G.unListType aTy) - (_, _) -> False pVar :: ( MonadError QErr m @@ -57,7 +49,7 @@ pVar => G.Variable -> m (P a) pVar var = do annInpVal <- resolveVar var - return . P . Just . Left $ annInpVal + return . P . Just $ Left (var, annInpVal) data InputValueParser a m = InputValueParser @@ -231,8 +223,8 @@ validateNamedTypeVal :: ( MonadReader r m, Has TypeMap r , MonadError QErr m) => InputValueParser a m - -> G.NamedType -> a -> m AnnGValue -validateNamedTypeVal inpValParser nt val = do + -> (G.Nullability, G.NamedType) -> a -> m AnnInpVal +validateNamedTypeVal inpValParser (nullability, nt) val = do tyInfo <- getTyInfo nt case tyInfo of -- this should never happen @@ -243,13 +235,13 @@ validateNamedTypeVal inpValParser nt val = do TIUnion _ -> throwUnexpTypeErr "union" TIInpObj ioti -> - withParsed (getObject inpValParser) val $ + withParsed gType (getObject inpValParser) val $ fmap (AGObject nt) . mapM (validateObject inpValParser ioti) TIEnum eti -> - withParsed (getEnum inpValParser) val $ + withParsed gType (getEnum inpValParser) val $ fmap (AGEnum nt) . mapM (validateEnum eti) TIScalar (ScalarTyInfo _ pgColTy _) -> - withParsed (getScalar inpValParser) val $ + withParsed gType (getScalar inpValParser) val $ fmap (AGScalar pgColTy) . mapM (validateScalar pgColTy) where throwUnexpTypeErr ty = throw500 $ "unexpected " <> ty <> " type info for: " @@ -262,54 +254,73 @@ validateNamedTypeVal inpValParser nt val = do " for enum: " <> showNamedTy nt validateScalar pgColTy = runAesonParser (parsePGValue pgColTy) + gType = G.TypeNamed nullability nt validateList :: (MonadError QErr m, MonadReader r m, Has TypeMap r) => InputValueParser a m - -> G.ListType + -> (G.Nullability, G.ListType) -> a - -> m AnnGValue -validateList inpValParser listTy val = - withParsed (getList inpValParser) val $ \lM -> do + -> m AnnInpVal +validateList inpValParser (nullability, listTy) val = + withParsed ty (getList inpValParser) val $ \lM -> do let baseTy = G.unListType listTy AGArray listTy <$> mapM (indexedMapM (validateInputValue inpValParser baseTy)) lM - --- validateNonNull --- :: (MonadError QErr m, MonadReader r m, Has TypeMap r) --- => InputValueParser a m --- -> G.NonNullType --- -> a --- -> m AnnGValue --- validateNonNull inpValParser nonNullTy val = do --- parsedVal <- case nonNullTy of --- G.NonNullTypeNamed nt -> validateNamedTypeVal inpValParser nt val --- G.NonNullTypeList lt -> validateList inpValParser lt val --- when (hasNullVal parsedVal) $ --- throwVE $ "unexpected null value for type: " <> G.showGT (G.TypeNonNull nonNullTy) --- return parsedVal + where + ty = G.TypeList nullability listTy validateInputValue :: (MonadError QErr m, MonadReader r m, Has TypeMap r) => InputValueParser a m -> G.GType -> a - -> m AnnGValue + -> m AnnInpVal validateInputValue inpValParser ty val = case ty of - G.TypeNamed _ nt -> validateNamedTypeVal inpValParser nt val - G.TypeList _ lt -> validateList inpValParser lt val - --G.TypeNonNull nnt -> validateNonNull inpValParser nnt val + G.TypeNamed nullability nt -> + validateNamedTypeVal inpValParser (nullability, nt) val + G.TypeList nullability lt -> + validateList inpValParser (nullability, lt) val withParsed - :: (Monad m) - => (val -> m (P specificVal)) + :: (Monad m, MonadError QErr m) + => G.GType + -> (val -> m (P specificVal)) -> val -> (Maybe specificVal -> m AnnGValue) - -> m AnnGValue -withParsed valParser val fn = do + -> m AnnInpVal +withParsed expectedTy valParser val fn = do parsedVal <- valParser val case unP parsedVal of - Nothing -> fn Nothing - Just (Right a) -> fn $ Just a - Just (Left annVal) -> return annVal + Nothing -> AnnInpVal expectedTy Nothing <$> fn Nothing + Just (Right v) -> AnnInpVal expectedTy Nothing <$> fn (Just v) + Just (Left (var, v)) -> do + let varTxt = G.unName $ G.unVariable var + unless (isTypeAllowed expectedTy $ _aivType v) $ + throwVE $ "variable " <> varTxt + <> " of type " <> G.showGT (_aivType v) + <> " is used in position expecting " <> G.showGT expectedTy + return $ v { _aivVariable = Just var } + where + -- is the type 'ofType' allowed at a position of type 'atType' + -- Examples: + -- . a! is allowed at a + -- . [a!]! is allowed at [a] + -- . but 'a' is not allowed at 'a!' + isTypeAllowed ofType atType = + case (ofType, atType) of + (G.TypeNamed ofTyN ofNt, G.TypeNamed atTyN atNt) -> + checkNullability ofTyN atTyN && (ofNt == atNt) + (G.TypeList ofTyN ofLt, G.TypeList atTyN atLt) -> + checkNullability ofTyN atTyN && + isTypeAllowed (G.unListType ofLt) (G.unListType atLt) + _ -> False + + -- only when 'atType' is non nullable and 'ofType' is nullable, + -- this check fails + checkNullability (G.Nullability ofNullable) (G.Nullability atNullable) = + case (ofNullable, atNullable) of + (True, _) -> True + (False, False) -> True + (False, True) -> False diff --git a/server/src-lib/Hasura/GraphQL/Validate/Types.hs b/server/src-lib/Hasura/GraphQL/Validate/Types.hs index 82829fedade8b..1b01ff5b36624 100644 --- a/server/src-lib/Hasura/GraphQL/Validate/Types.hs +++ b/server/src-lib/Hasura/GraphQL/Validate/Types.hs @@ -11,6 +11,7 @@ module Hasura.GraphQL.Validate.Types , FragDef(..) , FragDefMap , AnnVarVals + , AnnInpVal(..) , EnumTyInfo(..) , EnumValInfo(..) , InpObjFldMap @@ -29,7 +30,6 @@ module Hasura.GraphQL.Validate.Types , getUnionTyM , mkScalarTy , pgColTyToScalar - , pgColValToAnnGVal , getNamedTy , mkTyInfoMap , fromTyDef @@ -43,7 +43,6 @@ module Hasura.GraphQL.Validate.Types , AnnGObject , hasNullVal , getAnnInpValKind - , getAnnInpValTy , module Hasura.GraphQL.Utils ) where @@ -51,6 +50,8 @@ import Hasura.Prelude import Instances.TH.Lift () import qualified Data.Aeson as J +import qualified Data.Aeson.Casing as J +import qualified Data.Aeson.TH as J import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Data.HashSet as Set @@ -595,26 +596,34 @@ data FragDef type FragDefMap = Map.HashMap G.Name FragDef type AnnVarVals = - Map.HashMap G.Variable AnnGValue + Map.HashMap G.Variable AnnInpVal -type AnnGObject = OMap.InsOrdHashMap G.Name AnnGValue +data AnnInpVal + = AnnInpVal + { _aivType :: !G.GType + , _aivVariable :: !(Maybe G.Variable) + , _aivValue :: !AnnGValue + } deriving (Show, Eq) + +type AnnGObject = OMap.InsOrdHashMap G.Name AnnInpVal data AnnGValue = AGScalar !PGColType !(Maybe PGColValue) | AGEnum !G.NamedType !(Maybe G.EnumValue) | AGObject !G.NamedType !(Maybe AnnGObject) - | AGArray !G.ListType !(Maybe [AnnGValue]) + | AGArray !G.ListType !(Maybe [AnnInpVal]) deriving (Show, Eq) +$(J.deriveToJSON (J.aesonDrop 4 J.camelCase){J.omitNothingFields=True} + ''AnnInpVal + ) + instance J.ToJSON AnnGValue where -- toJSON (AGScalar ty valM) = toJSON = const J.Null -- J. -- J.toJSON [J.toJSON ty, J.toJSON valM] -pgColValToAnnGVal :: PGColType -> PGColValue -> AnnGValue -pgColValToAnnGVal colTy colVal = AGScalar colTy $ Just colVal - hasNullVal :: AnnGValue -> Bool hasNullVal = \case AGScalar _ Nothing -> True @@ -629,10 +638,3 @@ getAnnInpValKind = \case AGEnum _ _ -> "enum" AGObject _ _ -> "object" AGArray _ _ -> "array" - -getAnnInpValTy :: AnnGValue -> G.GType -getAnnInpValTy = \case - AGScalar pct _ -> G.TypeNamed (G.Nullability True) $ G.NamedType $ G.Name $ T.pack $ show pct - AGEnum nt _ -> G.TypeNamed (G.Nullability True) nt - AGObject nt _ -> G.TypeNamed (G.Nullability True) nt - AGArray nt _ -> G.TypeList (G.Nullability True) nt diff --git a/server/tests-py/queries/graphql_query/boolexp/postgis/query_using_polygon.yaml b/server/tests-py/queries/graphql_query/boolexp/postgis/query_using_polygon.yaml index 80617ab920f4e..a6bbcba174451 100644 --- a/server/tests-py/queries/graphql_query/boolexp/postgis/query_using_polygon.yaml +++ b/server/tests-py/queries/graphql_query/boolexp/postgis/query_using_polygon.yaml @@ -134,7 +134,7 @@ query: - - 2 - 0 query: | - query geom_table($polygon: geometry){ + query geom_table($polygon: geometry!){ st_d_within_2: geom_table(where: {geom_col: {_st_d_within: {distance: 2 from: $polygon}}}){ id geom_col