From bbe93f8efe006fb496d753bb8d27d25bf808c16a Mon Sep 17 00:00:00 2001 From: Vamshi Surabhi Date: Mon, 25 Mar 2019 13:40:11 +0530 Subject: [PATCH] refactor graphql query execution logic --- server/graphql-engine.cabal | 3 +- server/src-lib/Hasura/GraphQL/Execute.hs | 130 +++++++++++++++ server/src-lib/Hasura/GraphQL/Explain.hs | 43 ++--- server/src-lib/Hasura/GraphQL/Resolve.hs | 149 ++++++++++-------- .../src-lib/Hasura/GraphQL/Resolve/Context.hs | 20 ++- .../Hasura/GraphQL/Resolve/Mutation.hs | 63 +++++--- .../src-lib/Hasura/GraphQL/Resolve/Select.hs | 22 +-- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 144 +++-------------- .../Hasura/GraphQL/Transport/WebSocket.hs | 79 ++++------ server/src-lib/Hasura/GraphQL/Validate.hs | 36 +++-- 10 files changed, 375 insertions(+), 314 deletions(-) create mode 100644 server/src-lib/Hasura/GraphQL/Execute.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 105934c3c0c83..2b2b84e03cb5c 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -208,8 +208,9 @@ library , Hasura.GraphQL.Validate.Context , Hasura.GraphQL.Validate.Field , Hasura.GraphQL.Validate.InputValue - , Hasura.GraphQL.Resolve , Hasura.GraphQL.Explain + , Hasura.GraphQL.Execute + , Hasura.GraphQL.Resolve , Hasura.GraphQL.Resolve.LiveQuery , Hasura.GraphQL.Resolve.BoolExp , Hasura.GraphQL.Resolve.Context diff --git a/server/src-lib/Hasura/GraphQL/Execute.hs b/server/src-lib/Hasura/GraphQL/Execute.hs new file mode 100644 index 0000000000000..99784a7a6f11c --- /dev/null +++ b/server/src-lib/Hasura/GraphQL/Execute.hs @@ -0,0 +1,130 @@ +module Hasura.GraphQL.Execute + ( GQExecPlan(..) + , getExecPlan + , execRemoteGQ + ) where + +import Control.Exception (try) +import Control.Lens + +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.String.Conversions as CS +import qualified Data.Text as T +import qualified Language.GraphQL.Draft.Syntax as G +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as N +import qualified Network.Wreq as Wreq + +import Hasura.EncJSON +import Hasura.GraphQL.Schema +import Hasura.GraphQL.Transport.HTTP.Protocol +import Hasura.HTTP +import Hasura.Prelude +import Hasura.RQL.DDL.Headers +import Hasura.RQL.Types + +import qualified Hasura.GraphQL.Validate as VQ +import qualified Hasura.GraphQL.Validate.Types as VT + +data GQExecPlan + = GExPHasura !GCtx !VQ.RootSelSet + | GExPRemote !RemoteSchemaInfo !G.TypedOperationDefinition + +getExecPlan + :: (MonadError QErr m) + => UserInfo + -> SchemaCache + -> GraphQLRequest + -> m GQExecPlan +getExecPlan userInfo sc req = do + + (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxRoleMap + queryParts <- flip runReaderT gCtx $ VQ.getQueryParts req + + let opDef = VQ.qpOpDef queryParts + topLevelNodes = getTopLevelNodes opDef + -- gather TypeLoc of topLevelNodes + typeLocs = gatherTypeLocs gCtx topLevelNodes + + -- see if they are all the same + typeLoc <- assertSameLocationNodes typeLocs + + case typeLoc of + VT.HasuraType -> + GExPHasura gCtx <$> runReaderT (VQ.validateGQ queryParts) gCtx + VT.RemoteType _ rsi -> + return $ GExPRemote rsi opDef + where + gCtxRoleMap = scGCtxMap sc + +execRemoteGQ + :: (MonadIO m, MonadError QErr m) + => HTTP.Manager + -> UserInfo + -> [N.Header] + -> BL.ByteString + -- ^ the raw request string + -> RemoteSchemaInfo + -> G.TypedOperationDefinition + -> m EncJSON +execRemoteGQ manager userInfo reqHdrs q rsi opDef = do + let opTy = G._todType opDef + when (opTy == G.OperationTypeSubscription) $ + throw400 NotSupported "subscription to remote server is not supported" + hdrs <- getHeadersFromConf hdrConf + let confHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) hdrs + clientHdrs = bool [] filteredHeaders fwdClientHdrs + options = wreqOptions manager (userInfoToHdrs ++ clientHdrs ++ confHdrs) + + res <- liftIO $ try $ Wreq.postWith options (show url) q + resp <- either httpThrow return res + return $ encJFromLBS $ resp ^. Wreq.responseBody + + where + RemoteSchemaInfo url hdrConf fwdClientHdrs = rsi + httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a + httpThrow err = throw500 $ T.pack . show $ err + + userInfoToHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $ + userInfoToList userInfo + filteredHeaders = flip filter reqHdrs $ \(n, _) -> + n `notElem` [ "Content-Length", "Content-MD5", "User-Agent", "Host" + , "Origin", "Referer" , "Accept", "Accept-Encoding" + , "Accept-Language", "Accept-Datetime" + , "Cache-Control", "Connection", "DNT" + ] + +assertSameLocationNodes + :: (MonadError QErr m) => [VT.TypeLoc] -> m VT.TypeLoc +assertSameLocationNodes typeLocs = + case Set.toList (Set.fromList typeLocs) of + -- this shouldn't happen + [] -> return VT.HasuraType + [loc] -> return loc + _ -> throw400 NotSupported msg + where + msg = "cannot mix top level fields from two different graphql servers" + +-- TODO: we should fix this function asap +-- as this will fail when there is a fragment at the top level +getTopLevelNodes :: G.TypedOperationDefinition -> [G.Name] +getTopLevelNodes opDef = + mapMaybe f $ G._todSelectionSet opDef + where + f = \case + G.SelectionField fld -> Just $ G._fName fld + G.SelectionFragmentSpread _ -> Nothing + G.SelectionInlineFragment _ -> Nothing + +gatherTypeLocs :: GCtx -> [G.Name] -> [VT.TypeLoc] +gatherTypeLocs gCtx nodes = + catMaybes $ flip map nodes $ \node -> + VT._fiLoc <$> Map.lookup node schemaNodes + where + schemaNodes = + let qr = VT._otiFields $ _gQueryRoot gCtx + mr = VT._otiFields <$> _gMutRoot gCtx + in maybe qr (Map.union qr) mr diff --git a/server/src-lib/Hasura/GraphQL/Explain.hs b/server/src-lib/Hasura/GraphQL/Explain.hs index 7ef3fe35a4d7c..a5954a0c1ac0e 100644 --- a/server/src-lib/Hasura/GraphQL/Explain.hs +++ b/server/src-lib/Hasura/GraphQL/Explain.hs @@ -13,21 +13,19 @@ import qualified Database.PG.Query as Q import qualified Language.GraphQL.Draft.Syntax as G import qualified Text.Builder as TB -import Hasura.GraphQL.Context import Hasura.EncJSON +import Hasura.GraphQL.Context import Hasura.GraphQL.Resolve.Context -import Hasura.GraphQL.Schema import Hasura.GraphQL.Validate.Field import Hasura.Prelude import Hasura.RQL.DML.Internal import Hasura.RQL.Types import Hasura.SQL.Types +import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Resolve.Select as RS -import qualified Hasura.GraphQL.Transport.HTTP as TH import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH import qualified Hasura.GraphQL.Validate as GV -import qualified Hasura.GraphQL.Validate.Types as VT import qualified Hasura.RQL.DML.Select as RS data GQLExplain @@ -128,30 +126,23 @@ explainGQLQuery -> GQLExplain -> m EncJSON explainGQLQuery pool iso sc sqlGenCtx (GQLExplain query userVarsRaw)= do - (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxMap - queryParts <- runReaderT (GV.getQueryParts query) gCtx - let topLevelNodes = TH.getTopLevelNodes (GV.qpOpDef queryParts) - - unless (allHasuraNodes gCtx topLevelNodes) $ - throw400 InvalidParams "only hasura queries can be explained" - - (opTy, selSet) <- runReaderT (GV.validateGQ queryParts) gCtx - unless (opTy == G.OperationTypeQuery) $ - throw400 InvalidParams "only queries can be explained" - let tx = mapM (explainField userInfo gCtx sqlGenCtx) (toList selSet) - plans <- liftIO (runExceptT $ runTx tx) >>= liftEither - return $ encJFromJValue plans - + execPlan <- E.getExecPlan userInfo sc query + (gCtx, rootSelSet) <- case execPlan of + E.GExPHasura gCtx rootSelSet -> + return (gCtx, rootSelSet) + E.GExPRemote _ _ -> + throw400 InvalidParams "only hasura queries can be explained" + case rootSelSet of + GV.RQuery selSet -> do + let tx = mapM (explainField userInfo gCtx sqlGenCtx) (toList selSet) + plans <- liftIO (runExceptT $ runTx tx) >>= liftEither + return $ encJFromJValue plans + GV.RMutation _ -> + throw400 InvalidParams "only queries can be explained" + GV.RSubscription _ -> + throw400 InvalidParams "only queries can be explained" where - gCtxMap = scGCtxMap sc usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw userInfo = mkUserInfo (fromMaybe adminRole $ roleFromVars usrVars) usrVars runTx tx = runLazyTx pool iso $ withUserInfo userInfo tx - - allHasuraNodes gCtx nodes = - let typeLocs = TH.gatherTypeLocs gCtx nodes - isHasuraNode = \case - VT.HasuraType -> True - VT.RemoteType _ _ -> False - in all isHasuraNode typeLocs diff --git a/server/src-lib/Hasura/GraphQL/Resolve.hs b/server/src-lib/Hasura/GraphQL/Resolve.hs index 51218f0f2975b..8944a57e8fd9f 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve.hs @@ -1,5 +1,7 @@ module Hasura.GraphQL.Resolve - ( resolveSelSet + ( resolveQuerySelSet + , resolveMutSelSet + , resolveSubsFld ) where import Hasura.Prelude @@ -8,8 +10,8 @@ import qualified Data.HashMap.Strict as Map import qualified Database.PG.Query as Q import qualified Language.GraphQL.Draft.Syntax as G -import Hasura.GraphQL.Context import Hasura.EncJSON +import Hasura.GraphQL.Context import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Introspect import Hasura.GraphQL.Validate.Field @@ -20,83 +22,106 @@ import qualified Hasura.GraphQL.Resolve.Insert as RI import qualified Hasura.GraphQL.Resolve.Mutation as RM import qualified Hasura.GraphQL.Resolve.Select as RS --- {-# SCC buildTx #-} -buildTx :: UserInfo -> GCtx -> SQLGenCtx -> Field -> Q.TxE QErr EncJSON -buildTx userInfo gCtx sqlCtx fld = do +validateHdrs + :: (Foldable t, QErrM m) => UserInfo -> t Text -> m () +validateHdrs userInfo hdrs = do + let receivedVars = userVars userInfo + forM_ hdrs $ \hdr -> + unless (isJust $ getVarVal hdr receivedVars) $ + throw400 NotFound $ hdr <<> " header is expected but not found" + +resolvePGFld + :: UserInfo + -> GCtx + -> SQLGenCtx + -> Field + -> Q.TxE QErr EncJSON +resolvePGFld userInfo gCtx sqlCtx fld = do opCxt <- getOpCtx $ _fName fld - join $ fmap fst $ runConvert ( fldMap - , orderByCtx - , insCtxMap - , sqlCtx - ) $ case opCxt of - - OCSelect ctx -> - validateHdrs (_socHeaders ctx) >> RS.convertSelect ctx fld - - OCSelectPkey ctx -> - validateHdrs (_spocHeaders ctx) >> RS.convertSelectByPKey ctx fld - - OCSelectAgg ctx -> - validateHdrs (_socHeaders ctx) >> RS.convertAggSelect ctx fld - - OCFuncQuery ctx -> - validateHdrs (_fqocHeaders ctx) >> RS.convertFuncQuery ctx False fld - - OCFuncAggQuery ctx -> - validateHdrs (_fqocHeaders ctx) >> RS.convertFuncQuery ctx True fld - - OCInsert ctx -> - validateHdrs (_iocHeaders ctx) >> RI.convertInsert roleName (_iocTable ctx) fld - - OCUpdate ctx -> - validateHdrs (_uocHeaders ctx) >> RM.convertUpdate ctx fld - - OCDelete ctx -> - validateHdrs (_docHeaders ctx) >> RM.convertDelete ctx fld + join $ runConvert (fldMap, orderByCtx, insCtxMap, sqlCtx) $ case opCxt of + OCSelect ctx -> do + validateHdrs userInfo (_socHeaders ctx) + RS.convertSelect ctx fld + OCSelectPkey ctx -> do + validateHdrs userInfo (_spocHeaders ctx) + RS.convertSelectByPKey ctx fld + OCSelectAgg ctx -> do + validateHdrs userInfo (_socHeaders ctx) + RS.convertAggSelect ctx fld + OCFuncQuery ctx -> do + validateHdrs userInfo (_fqocHeaders ctx) + RS.convertFuncQuery ctx False fld + OCFuncAggQuery ctx -> do + validateHdrs userInfo (_fqocHeaders ctx) + RS.convertFuncQuery ctx True fld + OCInsert ctx -> do + validateHdrs userInfo (_iocHeaders ctx) + RI.convertInsert roleName (_iocTable ctx) fld + OCUpdate ctx -> do + validateHdrs userInfo (_uocHeaders ctx) + RM.convertUpdate ctx fld + OCDelete ctx -> do + validateHdrs userInfo (_docHeaders ctx) + RM.convertDelete ctx fld where - roleName = userRole userInfo opCtxMap = _gOpCtxMap gCtx fldMap = _gFields gCtx orderByCtx = _gOrdByCtx gCtx insCtxMap = _gInsCtxMap gCtx + roleName = userRole userInfo getOpCtx f = onNothing (Map.lookup f opCtxMap) $ throw500 $ "lookup failed: opctx: " <> showName f - validateHdrs hdrs = do - let receivedVars = userVars userInfo - forM_ hdrs $ \hdr -> - unless (isJust $ getVarVal hdr receivedVars) $ - throw400 NotFound $ hdr <<> " header is expected but not found" +mkRootTypeName :: G.OperationType -> Text +mkRootTypeName = \case + G.OperationTypeQuery -> "query_root" + G.OperationTypeMutation -> "mutation_root" + G.OperationTypeSubscription -> "subscription_root" --- {-# SCC resolveFld #-} -resolveFld +resolveQuerySelSet :: (MonadTx m) - => UserInfo -> GCtx -> SQLGenCtx - -> G.OperationType - -> Field + => UserInfo + -> GCtx + -> SQLGenCtx + -> SelSet -> m EncJSON -resolveFld userInfo gCtx sqlGenCtx opTy fld = - case _fName fld of - "__type" -> encJFromJValue <$> runReaderT (typeR fld) gCtx - "__schema" -> encJFromJValue <$> runReaderT (schemaR fld) gCtx - "__typename" -> return $ encJFromJValue $ mkRootTypeName opTy - _ -> liftTx $ buildTx userInfo gCtx sqlGenCtx fld - where - mkRootTypeName :: G.OperationType -> Text - mkRootTypeName = \case - G.OperationTypeQuery -> "query_root" - G.OperationTypeMutation -> "mutation_root" - G.OperationTypeSubscription -> "subscription_root" +resolveQuerySelSet userInfo gCtx sqlGenCtx fields = + fmap encJFromAssocList $ forM (toList fields) $ \fld -> do + fldResp <- case _fName fld of + "__type" -> encJFromJValue <$> runReaderT (typeR fld) gCtx + "__schema" -> encJFromJValue <$> runReaderT (schemaR fld) gCtx + "__typename" -> return $ encJFromJValue $ + mkRootTypeName G.OperationTypeQuery + _ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld + return (G.unName $ G.unAlias $ _fAlias fld, fldResp) -resolveSelSet +resolveMutSelSet :: (MonadTx m) - => UserInfo -> GCtx -> SQLGenCtx - -> G.OperationType + => UserInfo + -> GCtx + -> SQLGenCtx -> SelSet -> m EncJSON -resolveSelSet userInfo gCtx sqlGenCtx opTy fields = +resolveMutSelSet userInfo gCtx sqlGenCtx fields = fmap encJFromAssocList $ forM (toList fields) $ \fld -> do - fldResp <- resolveFld userInfo gCtx sqlGenCtx opTy fld + fldResp <- case _fName fld of + "__typename" -> return $ encJFromJValue $ + mkRootTypeName G.OperationTypeMutation + _ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld return (G.unName $ G.unAlias $ _fAlias fld, fldResp) + +resolveSubsFld + :: (MonadTx m) + => UserInfo + -> GCtx + -> SQLGenCtx + -> Field + -> m EncJSON +resolveSubsFld userInfo gCtx sqlGenCtx fld = do + resp <- case _fName fld of + "__typename" -> return $ encJFromJValue $ + mkRootTypeName G.OperationTypeSubscription + _ -> liftTx $ resolvePGFld userInfo gCtx sqlGenCtx fld + return $ encJFromAssocList [(G.unName $ G.unAlias $ _fAlias fld, resp)] diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs index 60d2b10460954..9d90523b27cb7 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Context.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Context.hs @@ -24,6 +24,7 @@ module Hasura.GraphQL.Resolve.Context , PrepArgs , Convert , runConvert + , withPrepArgs , prepare , prepareColVal , txtConverter @@ -138,12 +139,12 @@ withArgM args arg f = prependArgsInPath $ nameAsPath arg $ type PrepArgs = Seq.Seq Q.PrepArg type Convert = - StateT PrepArgs (ReaderT ( FieldMap - , OrdByCtx - , InsCtxMap - , SQLGenCtx - ) (Except QErr) - ) + (ReaderT ( FieldMap + , OrdByCtx + , InsCtxMap + , SQLGenCtx + ) (Except QErr) + ) prepare :: (MonadState PrepArgs m) => PrepFn m @@ -163,11 +164,14 @@ txtConverter :: Monad m => PrepFn m txtConverter (AnnPGVal _ _ a b) = return $ toTxtValue a b +withPrepArgs :: StateT PrepArgs Convert a -> Convert (a, PrepArgs) +withPrepArgs m = runStateT m Seq.empty + runConvert :: (MonadError QErr m) => (FieldMap, OrdByCtx, InsCtxMap, SQLGenCtx) -> Convert a - -> m (a, PrepArgs) + -> m a runConvert ctx m = either throwError return $ - runExcept $ runReaderT (runStateT m Seq.empty) ctx + runExcept $ runReaderT m ctx diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs index 45f2baf2e439b..84c0a634e3be7 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Mutation.hs @@ -6,7 +6,7 @@ module Hasura.GraphQL.Resolve.Mutation ) where import Control.Arrow (second) -import Data.Has (getter) +import Data.Has import Hasura.Prelude import qualified Data.Aeson as J @@ -33,7 +33,10 @@ import Hasura.SQL.Types import Hasura.SQL.Value convertMutResp - :: G.NamedType -> SelSet -> Convert RR.MutFlds + :: ( MonadError QErr m, MonadReader r m, Has FieldMap r + , Has OrdByCtx r, Has SQLGenCtx r + ) + => G.NamedType -> SelSet -> m RR.MutFlds convertMutResp ty selSet = withSelSet selSet $ \fld -> case _fName fld of "__typename" -> return $ RR.MExp $ G.unName $ G.unNamedType ty @@ -91,11 +94,16 @@ convDeleteAtPathObj val = [S.SEIden $ toIden pgCol, annEncVal] return (pgCol, sqlExp) -convertUpdate - :: UpdOpCtx -- the update context +convertUpdateP1 + :: ( MonadError QErr m + , MonadReader r m, Has FieldMap r + , Has OrdByCtx r, Has SQLGenCtx r + , MonadState PrepArgs m + ) + => UpdOpCtx -- the update context -> Field -- the mutation field - -> Convert RespTx -convertUpdate opCtx fld = do + -> m RU.UpdateQueryP1 +convertUpdateP1 opCtx fld = do -- a set expression is same as a row object setExpM <- withArgM args "_set" convertRowObj -- where bool expression to filter column @@ -117,43 +125,54 @@ convertUpdate opCtx fld = do convObjWithOp $ rhsExpOp S.jsonbDeleteOp S.intType -- delete at path in jsonb value deleteAtPathExpM <- withArgM args "_delete_at_path" convDeleteAtPathObj - mutFlds <- convertMutResp (_fType fld) $ _fSelSet fld - prepArgs <- get let updExpsM = [ setExpM, incExpM, appendExpM, prependExpM , deleteKeyExpM, deleteElemExpM, deleteAtPathExpM ] setItems = preSetItems ++ concat (catMaybes updExpsM) + -- atleast one of update operators is expected -- or preSetItems shouldn't be empty + -- this is not equivalent to (null setItems) unless (any isJust updExpsM || not (null preSetItems)) $ throwVE $ - "atleast any one of _set, _inc, _append, _prepend, _delete_key, _delete_elem and " - <> " _delete_at_path operator is expected" - strfyNum <- stringifyNum <$> asks getter - let p1 = RU.UpdateQueryP1 tn setItems (filterExp, whereExp) mutFlds allCols - whenNonEmptyItems = return $ RU.updateQueryToTx strfyNum (p1, prepArgs) - whenEmptyItems = return $ return $ buildEmptyMutResp mutFlds - -- if there are not set items then do not perform - -- update and return empty mutation response - bool whenNonEmptyItems whenEmptyItems $ null setItems + "atleast any one of _set, _inc, _append, _prepend, " + <> "_delete_key, _delete_elem and " + <> "_delete_at_path operator is expected" + + return $ RU.UpdateQueryP1 tn setItems (filterExp, whereExp) mutFlds allCols where UpdOpCtx tn _ filterExp preSetCols allCols = opCtx args = _fArguments fld preSetItems = Map.toList preSetCols +convertUpdate + :: UpdOpCtx -- the update context + -> Field -- the mutation field + -> Convert RespTx +convertUpdate opCtx fld = do + (p1, prepArgs) <- withPrepArgs $ convertUpdateP1 opCtx fld + strfyNum <- stringifyNum <$> asks getter + let whenNonEmptyItems = return $ RU.updateQueryToTx strfyNum (p1, prepArgs) + whenEmptyItems = return $ return $ + buildEmptyMutResp $ RU.uqp1MutFlds p1 + -- if there are not set items then do not perform + -- update and return empty mutation response + bool whenNonEmptyItems whenEmptyItems $ null $ RU.uqp1SetExps p1 + convertDelete :: DelOpCtx -- the delete context -> Field -- the mutation field -> Convert RespTx convertDelete opCtx fld = do - whereExp <- withArg (_fArguments fld) "where" (parseBoolExp prepare) - mutFlds <- convertMutResp (_fType fld) $ _fSelSet fld - args <- get - let p1 = RD.DeleteQueryP1 tn (filterExp, whereExp) mutFlds allCols + (p1, prepArgs) <- p1m strfyNum <- stringifyNum <$> asks getter - return $ RD.deleteQueryToTx strfyNum (p1, args) + return $ RD.deleteQueryToTx strfyNum (p1, prepArgs) where DelOpCtx tn _ filterExp allCols = opCtx + p1m = withPrepArgs $ do + whereExp <- withArg (_fArguments fld) "where" (parseBoolExp prepare) + mutFlds <- convertMutResp (_fType fld) $ _fSelSet fld + return $ RD.DeleteQueryP1 tn (filterExp, whereExp) mutFlds allCols -- | build mutation response for empty objects buildEmptyMutResp :: RR.MutFlds -> EncJSON diff --git a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs index 1ec16d3c75535..634b336b2fdd4 100644 --- a/server/src-lib/Hasura/GraphQL/Resolve/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Resolve/Select.hs @@ -261,9 +261,9 @@ fromFieldByPKey f tn colArgMap permFilter fld = fieldAsPath fld $ do convertSelect :: SelOpCtx -> Field -> Convert RespTx convertSelect opCtx fld = do - selData <- withPathK "selectionSet" $ - fromField prepare qt permFilter permLimit fld - prepArgs <- get + (selData, prepArgs) <- + withPathK "selectionSet" $ withPrepArgs $ + fromField prepare qt permFilter permLimit fld return $ RS.selectP2 False (selData, prepArgs) where SelOpCtx qt _ permFilter permLimit = opCtx @@ -271,9 +271,9 @@ convertSelect opCtx fld = do convertSelectByPKey :: SelPkOpCtx -> Field -> Convert RespTx convertSelectByPKey opCtx fld = do - selData <- withPathK "selectionSet" $ - fromFieldByPKey prepare qt colArgMap permFilter fld - prepArgs <- get + (selData, prepArgs) <- + withPathK "selectionSet" $ withPrepArgs $ + fromFieldByPKey prepare qt colArgMap permFilter fld return $ RS.selectP2 True (selData, prepArgs) where SelPkOpCtx qt _ permFilter colArgMap = opCtx @@ -349,9 +349,9 @@ fromAggField f tn permFilter permLimit fld = fieldAsPath fld $ do convertAggSelect :: SelOpCtx -> Field -> Convert RespTx convertAggSelect opCtx fld = do - selData <- withPathK "selectionSet" $ - fromAggField prepare qt permFilter permLimit fld - prepArgs <- get + (selData, prepArgs) <- + withPathK "selectionSet" $ withPrepArgs $ + fromAggField prepare qt permFilter permLimit fld return $ RS.selectAggP2 (selData, prepArgs) where SelOpCtx qt _ permFilter permLimit = opCtx @@ -391,10 +391,10 @@ parseFunctionArgs fn argSeq val = convertFuncQuery :: FuncQOpCtx -> Bool -> Field -> Convert RespTx convertFuncQuery funcOpCtx isAgg fld = do - (tableArgs, sel, frmItem) <- withPathK "selectionSet" $ + ((tableArgs, sel, frmItem), prepArgs) <- + withPathK "selectionSet" $ withPrepArgs $ fromFuncQueryField prepare qf argSeq isAgg fld let tabPerm = RS.TablePerm permFilter permLimit - prepArgs <- get strfyNum <- stringifyNum <$> asks getter return $ RS.funcQueryTx frmItem qf qt tabPerm tableArgs strfyNum (sel, prepArgs) where diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 1b25dc5d37245..50acf5072db66 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -1,38 +1,21 @@ module Hasura.GraphQL.Transport.HTTP ( runGQ - , getTopLevelNodes - , gatherTypeLocs - , assertSameLocationNodes - , runRemoteGQ ) where -import Control.Exception (try) -import Control.Lens - import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set -import qualified Data.String.Conversions as CS -import qualified Data.Text as T import qualified Database.PG.Query as Q -import qualified Language.GraphQL.Draft.Syntax as G import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as N -import qualified Network.Wreq as Wreq +import Hasura.EncJSON import Hasura.GraphQL.Schema import Hasura.GraphQL.Transport.HTTP.Protocol -import Hasura.HTTP -import Hasura.RQL.DDL.Headers -import Hasura.RQL.Types import Hasura.Prelude -import Hasura.EncJSON +import Hasura.RQL.Types +import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Resolve as R -import qualified Hasura.GraphQL.Validate as VQ -import qualified Hasura.GraphQL.Validate.Types as VT - +import qualified Hasura.GraphQL.Validate as V runGQ :: (MonadIO m, MonadError QErr m) @@ -46,113 +29,32 @@ runGQ -> BL.ByteString -- this can be removed when we have a pretty-printer -> m EncJSON runGQ pool isoL userInfo sqlGenCtx sc manager reqHdrs req rawReq = do - - (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxRoleMap - queryParts <- flip runReaderT gCtx $ VQ.getQueryParts req - - let opDef = VQ.qpOpDef queryParts - topLevelNodes = getTopLevelNodes opDef - -- gather TypeLoc of topLevelNodes - typeLocs = gatherTypeLocs gCtx topLevelNodes - - -- see if they are all the same - assertSameLocationNodes typeLocs - - case typeLocs of - [] -> runHasuraGQ pool isoL userInfo sqlGenCtx sc queryParts - - (typeLoc:_) -> case typeLoc of - VT.HasuraType -> - runHasuraGQ pool isoL userInfo sqlGenCtx sc queryParts - VT.RemoteType _ rsi -> - runRemoteGQ manager userInfo reqHdrs rawReq rsi opDef - where - gCtxRoleMap = scGCtxMap sc - - -assertSameLocationNodes :: (MonadError QErr m) => [VT.TypeLoc] -> m () -assertSameLocationNodes typeLocs = - unless (allEq typeLocs) $ throw400 NotSupported msg - where - allEq xs = case xs of - [] -> True - _ -> Set.size (Set.fromList xs) == 1 - msg = "cannot mix nodes from two different graphql servers" - --- TODO: we should retire the function asap -getTopLevelNodes :: G.TypedOperationDefinition -> [G.Name] -getTopLevelNodes opDef = - mapMaybe f $ G._todSelectionSet opDef - where - -- TODO: this will fail when there is a fragment at the top level - f = \case - G.SelectionField fld -> Just $ G._fName fld - G.SelectionFragmentSpread _ -> Nothing - G.SelectionInlineFragment _ -> Nothing - -gatherTypeLocs :: GCtx -> [G.Name] -> [VT.TypeLoc] -gatherTypeLocs gCtx nodes = - catMaybes $ flip map nodes $ \node -> - VT._fiLoc <$> Map.lookup node schemaNodes - where - schemaNodes = - let qr = VT._otiFields $ _gQueryRoot gCtx - mr = VT._otiFields <$> _gMutRoot gCtx - in maybe qr (Map.union qr) mr + execPlan <- E.getExecPlan userInfo sc req + case execPlan of + E.GExPHasura gCtx rootSelSet -> + runHasuraGQ pool isoL userInfo sqlGenCtx gCtx rootSelSet + E.GExPRemote rsi opDef -> + E.execRemoteGQ manager userInfo reqHdrs rawReq rsi opDef runHasuraGQ :: (MonadIO m, MonadError QErr m) - => Q.PGPool -> Q.TxIsolation + => Q.PGPool + -> Q.TxIsolation -> UserInfo -> SQLGenCtx - -> SchemaCache - -> VQ.QueryParts + -> GCtx + -> V.RootSelSet -> m EncJSON -runHasuraGQ pool isoL userInfo sqlGenCtx sc queryParts = do - (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) gCtxMap - (opTy, fields) <- runReaderT (VQ.validateGQ queryParts) gCtx - when (opTy == G.OperationTypeSubscription) $ throw400 UnexpectedPayload - "subscriptions are not supported over HTTP, use websockets instead" - let tx = R.resolveSelSet userInfo gCtx sqlGenCtx opTy fields +runHasuraGQ pool isoL userInfo sqlGenCtx gCtx rootSelSet = do + tx <- case rootSelSet of + V.RQuery selSet -> + return $ R.resolveQuerySelSet userInfo gCtx sqlGenCtx selSet + V.RMutation selSet -> + return $ R.resolveMutSelSet userInfo gCtx sqlGenCtx selSet + V.RSubscription _ -> + throw400 UnexpectedPayload + "subscriptions are not supported over HTTP, use websockets instead" resp <- liftIO (runExceptT $ runTx tx) >>= liftEither return $ encodeGQResp $ GQSuccess $ encJToLBS resp where - gCtxMap = scGCtxMap sc runTx tx = runLazyTx pool isoL $ withUserInfo userInfo tx - -runRemoteGQ - :: (MonadIO m, MonadError QErr m) - => HTTP.Manager - -> UserInfo - -> [N.Header] - -> BL.ByteString - -- ^ the raw request string - -> RemoteSchemaInfo - -> G.TypedOperationDefinition - -> m EncJSON -runRemoteGQ manager userInfo reqHdrs q rsi opDef = do - let opTy = G._todType opDef - when (opTy == G.OperationTypeSubscription) $ - throw400 NotSupported "subscription to remote server is not supported" - hdrs <- getHeadersFromConf hdrConf - let confHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) hdrs - clientHdrs = bool [] filteredHeaders fwdClientHdrs - options = wreqOptions manager (userInfoToHdrs ++ clientHdrs ++ confHdrs) - - res <- liftIO $ try $ Wreq.postWith options (show url) q - resp <- either httpThrow return res - return $ encJFromLBS $ resp ^. Wreq.responseBody - - where - RemoteSchemaInfo url hdrConf fwdClientHdrs = rsi - httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a - httpThrow err = throw500 $ T.pack . show $ err - - userInfoToHdrs = map (\(k, v) -> (CI.mk $ CS.cs k, CS.cs v)) $ - userInfoToList userInfo - filteredHeaders = flip filter reqHdrs $ \(n, _) -> - n `notElem` [ "Content-Length", "Content-MD5", "User-Agent", "Host" - , "Origin", "Referer" , "Accept", "Accept-Encoding" - , "Accept-Language", "Accept-Datetime" - , "Cache-Control", "Connection", "DNT" - ] diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 08ea68a392db8..074bd6d475f57 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -26,22 +26,18 @@ import Control.Concurrent (threadDelay) import Data.ByteString (ByteString) import qualified Data.IORef as IORef +import Hasura.EncJSON import Hasura.GraphQL.Context (GCtx) -import Hasura.GraphQL.Resolve (resolveSelSet) +import qualified Hasura.GraphQL.Execute as E +import qualified Hasura.GraphQL.Resolve as R import Hasura.GraphQL.Resolve.Context (LazyRespTx) import qualified Hasura.GraphQL.Resolve.LiveQuery as LQ -import Hasura.GraphQL.Schema (getGCtx) -import qualified Hasura.GraphQL.Transport.HTTP as TH import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.WebSocket.Protocol import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS -import Hasura.GraphQL.Validate (QueryParts (..), - getQueryParts, - validateGQ) -import qualified Hasura.GraphQL.Validate.Types as VT +import qualified Hasura.GraphQL.Validate as V import qualified Hasura.Logging as L import Hasura.Prelude -import Hasura.EncJSON import Hasura.RQL.Types import Hasura.Server.Auth (AuthMode, getUserInfo) @@ -224,49 +220,40 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do let connErr = "start received before the connection is initialised" withComplete $ sendConnErr connErr - -- validate and build tx sc <- liftIO $ IORef.readIORef gCtxMapRef - (gCtx, _) <- flip runStateT sc $ getGCtx (userRole userInfo) (scGCtxMap sc) - - eQueryParts <- runExceptT $ runReaderT (getQueryParts q) gCtx - queryParts <- either (withComplete . preExecErr) return eQueryParts - - let opDef = qpOpDef queryParts - topLevelNodes = TH.getTopLevelNodes opDef - typeLocs = TH.gatherTypeLocs gCtx topLevelNodes - - res <- runExceptT $ TH.assertSameLocationNodes typeLocs - either (withComplete . preExecErr) return res - - case typeLocs of - [] -> runHasuraQ userInfo gCtx queryParts - (typeLoc:_) -> case typeLoc of - VT.HasuraType -> runHasuraQ userInfo gCtx queryParts - VT.RemoteType _ rsi -> runRemoteQ userInfo reqHdrs opDef rsi - + execPlanE <- runExceptT $ E.getExecPlan userInfo sc q + execPlan <- either (withComplete . preExecErr) return execPlanE + case execPlan of + E.GExPHasura gCtx rootSelSet -> + runHasuraGQ userInfo gCtx rootSelSet + E.GExPRemote rsi opDef -> + runRemoteGQ userInfo reqHdrs opDef rsi where - runHasuraQ :: UserInfo -> GCtx -> QueryParts -> ExceptT () IO () - runHasuraQ userInfo gCtx queryParts = do - (opTy, fields) <- either (withComplete . preExecErr) return $ - runReaderT (validateGQ queryParts) gCtx - let qTx = withUserInfo userInfo $ resolveSelSet userInfo gCtx sqlGenCtx opTy fields - case opTy of - G.OperationTypeSubscription -> do + runHasuraGQ :: UserInfo -> GCtx -> V.RootSelSet -> ExceptT () IO () + runHasuraGQ userInfo gCtx rootSelSet = + case rootSelSet of + V.RQuery selSet -> + execQueryOrMut $ R.resolveQuerySelSet userInfo gCtx sqlGenCtx selSet + V.RMutation selSet -> + execQueryOrMut $ R.resolveMutSelSet userInfo gCtx sqlGenCtx selSet + V.RSubscription fld -> do + let tx = R.resolveSubsFld userInfo gCtx sqlGenCtx fld let lq = LQ.LiveQuery userInfo q liftIO $ STM.atomically $ STMMap.insert lq opId opMap liftIO $ LQ.addLiveQuery runTx lqMap lq - qTx (wsId, opId) liveQOnChange - logOpEv ODStarted - _ -> do + tx (wsId, opId) liveQOnChange logOpEv ODStarted - resp <- liftIO $ runTx qTx - either postExecErr sendSuccResp resp - sendCompleted - - runRemoteQ :: UserInfo -> [H.Header] - -> G.TypedOperationDefinition -> RemoteSchemaInfo - -> ExceptT () IO () - runRemoteQ userInfo reqHdrs opDef rsi = do + + execQueryOrMut tx = do + logOpEv ODStarted + resp <- liftIO $ runTx tx + either postExecErr sendSuccResp resp + sendCompleted + + runRemoteGQ :: UserInfo -> [H.Header] + -> G.TypedOperationDefinition -> RemoteSchemaInfo + -> ExceptT () IO () + runRemoteGQ userInfo reqHdrs opDef rsi = do when (G._todType opDef == G.OperationTypeSubscription) $ withComplete $ preExecErr $ err400 NotSupported "subscription to remote server is not supported" @@ -279,7 +266,7 @@ onStart serverEnv wsConn (StartMsg opId q) msgRaw = catchAndIgnore $ do const $ withComplete $ preExecErr $ err500 Unexpected "invalid websocket payload" let payload = J.encode $ _wpPayload sockPayload - resp <- runExceptT $ TH.runRemoteGQ httpMgr userInfo reqHdrs + resp <- runExceptT $ E.execRemoteGQ httpMgr userInfo reqHdrs payload rsi opDef either postExecErr sendSuccResp resp sendCompleted diff --git a/server/src-lib/Hasura/GraphQL/Validate.hs b/server/src-lib/Hasura/GraphQL/Validate.hs index 8977db0d43eca..7cb0c1c7ed3a2 100644 --- a/server/src-lib/Hasura/GraphQL/Validate.hs +++ b/server/src-lib/Hasura/GraphQL/Validate.hs @@ -1,5 +1,6 @@ module Hasura.GraphQL.Validate ( validateGQ + , RootSelSet(..) , getTypedOp , GraphQLRequest , QueryParts (..) @@ -10,6 +11,7 @@ import Data.Has import Hasura.Prelude import qualified Data.HashMap.Strict as Map +import qualified Data.Sequence as Seq import qualified Language.GraphQL.Draft.Syntax as G import Hasura.GraphQL.Schema @@ -20,7 +22,6 @@ import Hasura.GraphQL.Validate.InputValue import Hasura.GraphQL.Validate.Types import Hasura.RQL.Types - data QueryParts = QueryParts { qpOpDef :: !G.TypedOperationDefinition @@ -110,25 +111,21 @@ validateFrag (G.FragmentDefinition n onTy dirs selSet) = do "fragments can only be defined on object types" return $ FragDef n objTyInfo selSet +data RootSelSet + = RQuery !SelSet + | RMutation !SelSet + | RSubscription !Field + deriving (Show, Eq) + -- {-# SCC validateGQ #-} validateGQ :: (MonadError QErr m, MonadReader GCtx m) -- => GraphQLRequest => QueryParts - -> m (G.OperationType, SelSet) + -> m RootSelSet validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do - -- get the operation that needs to be evaluated - --opDef <- getTypedOp opNameM selSets opDefs - ctx <- ask - -- -- get the operation root - -- opRoot <- case G._todType opDef of - -- G.OperationTypeQuery -> return $ _gQueryRoot ctx - -- G.OperationTypeMutation -> - -- onNothing (_gMutRoot ctx) $ throwVE "no mutations exist" - -- G.OperationTypeSubscription -> - -- onNothing (_gSubRoot ctx) $ throwVE "no subscriptions exist" -- annotate the variables of this operation annVarVals <- getAnnVarVals (G._todVariableDefinitions opDef) $ @@ -146,11 +143,16 @@ validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do selSet <- flip runReaderT valCtx $ denormSelSet [] opRoot $ G._todSelectionSet opDef - when (G._todType opDef == G.OperationTypeSubscription && length selSet > 1) $ - throwVE "subscription must select only one top level field" - - return (G._todType opDef, selSet) - + case G._todType opDef of + G.OperationTypeQuery -> return $ RQuery selSet + G.OperationTypeMutation -> return $ RMutation selSet + G.OperationTypeSubscription -> + case Seq.viewl selSet of + Seq.EmptyL -> throw500 "empty selset for subscription" + fld Seq.:< rst -> do + unless (null rst) $ + throwVE "subscription must select only one top level field" + return $ RSubscription fld getQueryParts :: ( MonadError QErr m, MonadReader GCtx m)