[skip ci] add relay modern support (#4458)

* validation support for unions and interfaces

* refactor SQL generation logic for improved readability

* '/v1/relay' endpoint for relay schema

* implement 'Node' interface and top level 'node' field resolver

* add relay toggle on graphiql

* fix explain api response & index plan id with query type

* add hasura mutations to relay

* add relay pytests

* update CHANGELOG.md

Co-authored-by: rakeshkky <12475069+rakeshkky@users.noreply.github.com>
Co-authored-by: Rishichandra Wawhal <rishi@hasura.io>
Co-authored-by: Rikin Kachhia <54616969+rikinsk@users.noreply.github.com>
This commit is contained in:
Vamshi Surabhi 2020-06-08 17:43:01 +05:30 committed by rakeshkky
parent 62936ccd33
commit ab65b39cd8
67 changed files with 5398 additions and 1337 deletions

View File

@ -2,7 +2,6 @@
## Next release ## Next release
### Bug fixes and improvements ### Bug fixes and improvements
(Add entries here in the order of: server, console, cli, docs, others) (Add entries here in the order of: server, console, cli, docs, others)
@ -97,7 +96,7 @@ Read more about the session argument for computed fields in the [docs](https://h
A new `seeds` command is introduced in CLI, this will allow managing seed migrations as SQL files A new `seeds` command is introduced in CLI, this will allow managing seed migrations as SQL files
#### Creating seed #### Creating seed
``` ```
# create a new seed file and use editor to add SQL content # create a new seed file and use editor to add SQL content
hasura seed create new_table_seed hasura seed create new_table_seed

View File

@ -2,7 +2,6 @@ import React from 'react';
import OverlayTrigger from 'react-bootstrap/lib/OverlayTrigger'; import OverlayTrigger from 'react-bootstrap/lib/OverlayTrigger';
import Tooltip from 'react-bootstrap/lib/Tooltip'; import Tooltip from 'react-bootstrap/lib/Tooltip';
import styles from './Tooltip.scss'; import styles from './Tooltip.scss';
const tooltipGen = (message: string) => { const tooltipGen = (message: string) => {
return <Tooltip id={message}>{message}</Tooltip>; return <Tooltip id={message}>{message}</Tooltip>;
}; };
@ -28,5 +27,4 @@ const ToolTip: React.FC<TooltipProps> = ({
)} )}
</OverlayTrigger> </OverlayTrigger>
); );
export default ToolTip;
export default ToolTip;

View File

@ -233,6 +233,7 @@ library
, ghc-heap-view , ghc-heap-view
, directory , directory
, semigroups >= 0.19.1
exposed-modules: Control.Arrow.Extended exposed-modules: Control.Arrow.Extended
, Control.Arrow.Trans , Control.Arrow.Trans

View File

@ -1,25 +1,25 @@
module Data.HashMap.Strict.InsOrd.Extended module Data.HashMap.Strict.InsOrd.Extended
( OMap.elems ( module OMap
, groupTuples , groupTuples
, groupListWith , groupListWith
) where ) where
import qualified Data.HashMap.Strict.InsOrd as OMap import Data.HashMap.Strict.InsOrd as OMap
import qualified Data.List as L
import qualified Data.Sequence.NonEmpty as NE import qualified Data.Sequence.NonEmpty as NE
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.List (foldl')
import Prelude (Eq, Foldable, Functor, fmap, ($)) import Prelude (Eq, Foldable, Functor, fmap, undefined, ($))
groupTuples groupTuples
:: (Eq k, Hashable k, Foldable t) :: (Eq k, Hashable k, Foldable t)
=> t (k, v) -> OMap.InsOrdHashMap k (NE.NESeq v) => t (k, v) -> OMap.InsOrdHashMap k (NE.NESeq v)
groupTuples = groupTuples =
foldl' groupFlds OMap.empty L.foldl' groupFlds OMap.empty
where where
groupFlds m (k, v) = groupFlds m (k, v) =
OMap.insertWith (\_ c -> c NE.|> v) k (NE.singleton v) m OMap.insertWith (\_ c -> c `undefined` v) k (NE.singleton v) m
groupListWith groupListWith
:: (Eq k, Hashable k, Foldable t, Functor t) :: (Eq k, Hashable k, Foldable t, Functor t)

View File

@ -5,8 +5,6 @@ module Data.Sequence.NonEmpty
( NESeq ( NESeq
, pattern (:<||) , pattern (:<||)
, pattern (:||>) , pattern (:||>)
, (<|)
, (|>)
, singleton , singleton
, head , head
, tail , tail
@ -22,9 +20,6 @@ import Data.Aeson
import Data.Foldable import Data.Foldable
import GHC.Generics (Generic) import GHC.Generics (Generic)
infixr 5 <|
infixl 5 |>
data NESeq a = NESeq data NESeq a = NESeq
{ head :: a { head :: a
, tail :: Seq.Seq a , tail :: Seq.Seq a
@ -59,12 +54,6 @@ instance ToJSON a => ToJSON (NESeq a) where
singleton :: a -> NESeq a singleton :: a -> NESeq a
singleton a = NESeq a Seq.empty singleton a = NESeq a Seq.empty
(|>) :: NESeq a -> a -> NESeq a
NESeq h l |> v = NESeq h (l Seq.|> v)
(<|) :: a -> NESeq a -> NESeq a
v <| NESeq h l = NESeq v (h Seq.<| l)
toSeq :: NESeq a -> Seq.Seq a toSeq :: NESeq a -> Seq.Seq a
toSeq (NESeq v l) = v Seq.<| l toSeq (NESeq v l) = v Seq.<| l

View File

@ -76,9 +76,9 @@ traverseAction f = \case
RFRaw x -> pure $ RFRaw x RFRaw x -> pure $ RFRaw x
data QueryDB v data QueryDB v
= QDBSimple (RQL.AnnSimpleSelG v) = QDBSimple (RQL.AnnSimpleSelG v)
| QDBPrimaryKey (RQL.AnnSimpleSelG v) | QDBPrimaryKey (RQL.AnnSimpleSelG v)
| QDBAggregation (RQL.AnnAggSelG v) | QDBAggregation (RQL.AnnAggregateSelectG v)
data ActionQuery v data ActionQuery v
= AQQuery !(RQL.AnnActionExecution v) = AQQuery !(RQL.AnnActionExecution v)

View File

@ -43,8 +43,7 @@ import Hasura.Prelude
import Hasura.RQL.DDL.Headers import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Utils (RequestId, mkClientHeadersForward, import Hasura.Server.Utils (RequestId, mkClientHeadersForward,
mkSetCookieHeaders, mkSetCookieHeaders, userRoleHeader)
userRoleHeader)
import Hasura.Server.Version (HasVersion) import Hasura.Server.Version (HasVersion)
import Hasura.Session import Hasura.Session
@ -142,8 +141,8 @@ getExecPlanPartial userInfo sc enableAL queryType req = do
getGCtx :: C.GQLContext getGCtx :: C.GQLContext
getGCtx = getGCtx =
case Map.lookup roleName contextMap of case Map.lookup roleName contextMap of
Nothing -> defaultContext Nothing -> defaultContext
Just gql -> gql Just gql -> gql
-- TODO FIXME implement backend-only field access -- TODO FIXME implement backend-only field access
{- {-
Just (RoleContext defaultGCtx maybeBackendGCtx) -> Just (RoleContext defaultGCtx maybeBackendGCtx) ->
@ -206,7 +205,7 @@ getResolvedExecPlan
getResolvedExecPlan pgExecCtx planCache userInfo sqlGenCtx getResolvedExecPlan pgExecCtx planCache userInfo sqlGenCtx
enableAL sc scVer queryType httpManager reqHeaders reqUnparsed = do enableAL sc scVer queryType httpManager reqHeaders reqUnparsed = do
planM <- liftIO $ EP.getPlan scVer (_uiRole userInfo) planM <- liftIO $ EP.getPlan scVer (_uiRole userInfo)
opNameM queryStr planCache opNameM queryStr queryType planCache
let usrVars = _uiSession userInfo let usrVars = _uiSession userInfo
case planM of case planM of
-- plans are only for queries and subscriptions -- plans are only for queries and subscriptions
@ -246,7 +245,7 @@ getResolvedExecPlan pgExecCtx planCache userInfo sqlGenCtx
G.TypedOperationDefinition G.OperationTypeMutation _ varDefs _ selSet -> do G.TypedOperationDefinition G.OperationTypeMutation _ varDefs _ selSet -> do
-- (Here the above fragment inlining is actually executed.) -- (Here the above fragment inlining is actually executed.)
inlinedSelSet <- EI.inlineSelectionSet fragments selSet inlinedSelSet <- EI.inlineSelectionSet fragments selSet
queryTx <- EM.convertMutationSelectionSet gCtx (_uiSession userInfo) httpManager reqHeaders queryTx <- EM.convertMutationSelectionSet gCtx userInfo httpManager reqHeaders
inlinedSelSet varDefs (_grVariables reqUnparsed) inlinedSelSet varDefs (_grVariables reqUnparsed)
-- traverse_ (addPlanToCache . EP.RPQuery) plan -- traverse_ (addPlanToCache . EP.RPQuery) plan
return $ MutationExecutionPlan $ queryTx return $ MutationExecutionPlan $ queryTx

View File

@ -29,12 +29,13 @@ import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.Extended as J import qualified Data.Aeson.Extended as J
import qualified Data.Aeson.TH as J import qualified Data.Aeson.TH as J
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Data.Sequence as Seq
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.UUID.V4 as UUID import qualified Data.UUID.V4 as UUID
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Data.Sequence as Seq
-- remove these when array encoding is merged -- remove these when array encoding is merged
import qualified Database.PG.Query.PTI as PTI import qualified Database.PG.Query.PTI as PTI
@ -43,24 +44,25 @@ import qualified PostgreSQL.Binary.Encoding as PE
import Control.Lens import Control.Lens
import Data.UUID (UUID) import Data.UUID (UUID)
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Parser.Schema as PS import qualified Hasura.GraphQL.Parser.Schema as PS
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.RQL.DML.Select as DS import qualified Hasura.RQL.DML.Select as DS
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
--import qualified Hasura.GraphQL.Execute.Query as GEQ --import qualified Hasura.GraphQL.Execute.Query as GEQ
import Hasura.Db import Hasura.Db
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Parser.Column import Hasura.GraphQL.Context
import Hasura.GraphQL.Execute.Prepare import Hasura.GraphQL.Execute.Prepare
import Hasura.GraphQL.Execute.Query import Hasura.GraphQL.Execute.Query
import Hasura.RQL.Types import Hasura.GraphQL.Parser.Column
import Hasura.GraphQL.Resolve.Action import Hasura.GraphQL.Resolve.Action
import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.Session
import Hasura.SQL.Error import Hasura.SQL.Error
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
import Hasura.GraphQL.Context
import Hasura.Session
-- ------------------------------------------------------------------------------------------------- -- -------------------------------------------------------------------------------------------------
-- Multiplexed queries -- Multiplexed queries
@ -72,7 +74,7 @@ toSQLSelect :: SubscriptionRootFieldResolved -> S.Select
toSQLSelect = \case toSQLSelect = \case
RFDB (QDBPrimaryKey s) -> DS.mkSQLSelect DS.JASSingleObject s RFDB (QDBPrimaryKey s) -> DS.mkSQLSelect DS.JASSingleObject s
RFDB (QDBSimple s) -> DS.mkSQLSelect DS.JASMultipleRows s RFDB (QDBSimple s) -> DS.mkSQLSelect DS.JASMultipleRows s
RFDB (QDBAggregation s) -> DS.mkAggSelect s RFDB (QDBAggregation s) -> DS.mkAggregateSelect s
RFAction s -> DS.mkSQLSelect DS.JASSingleObject s RFAction s -> DS.mkSQLSelect DS.JASSingleObject s
-- QRFActionSelect s -> DS.mkSQLSelect DS.JASSingleObject s -- QRFActionSelect s -> DS.mkSQLSelect DS.JASSingleObject s
-- QRFActionExecuteObject s -> DS.mkSQLSelect DS.JASSingleObject s -- QRFActionExecuteObject s -> DS.mkSQLSelect DS.JASSingleObject s
@ -279,6 +281,7 @@ $(J.deriveToJSON (J.aesonDrop 4 J.snakeCase) ''ReusableLiveQueryPlan)
buildLiveQueryPlan buildLiveQueryPlan
:: ( MonadError QErr m :: ( MonadError QErr m
, MonadIO m , MonadIO m
, HasVersion
) )
=> PGExecCtx => PGExecCtx
-> UserInfo -> UserInfo
@ -310,7 +313,7 @@ buildLiveQueryPlan pgExecCtx userInfo unpreparedAST = do
(preparedAST, (queryVariableValues, querySyntheticVariableValues)) <- flip runStateT (mempty, Seq.empty) $ (preparedAST, (queryVariableValues, querySyntheticVariableValues)) <- flip runStateT (mempty, Seq.empty) $
for unpreparedAST \unpreparedQuery -> do for unpreparedAST \unpreparedQuery -> do
traverseQueryRootField resolveMultiplexedValue unpreparedQuery traverseQueryRootField resolveMultiplexedValue unpreparedQuery
>>= traverseAction (DS.traverseAnnSimpleSel resolveMultiplexedValue . resolveAsyncActionQuery userInfo) >>= traverseAction (DS.traverseAnnSimpleSelect resolveMultiplexedValue . resolveAsyncActionQuery userInfo)

View File

@ -67,37 +67,38 @@ convertMutationRootField
, MonadIO m , MonadIO m
, MonadError QErr m , MonadError QErr m
) )
=> SessionVariables => UserInfo
-> HTTP.Manager -> HTTP.Manager
-> HTTP.RequestHeaders -> HTTP.RequestHeaders
-> Bool -> Bool
-> MutationRootField UnpreparedValue -> MutationRootField UnpreparedValue
-> m (Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField) -> m (Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField)
convertMutationRootField usrVars manager reqHeaders stringifyNum = \case convertMutationRootField userInfo manager reqHeaders stringifyNum = \case
RFDB (MDBInsert s) -> noResponseHeaders $ convertInsert usrVars s stringifyNum RFDB (MDBInsert s) -> noResponseHeaders $ convertInsert userSession s stringifyNum
RFDB (MDBUpdate s) -> noResponseHeaders $ convertUpdate usrVars s stringifyNum RFDB (MDBUpdate s) -> noResponseHeaders $ convertUpdate userSession s stringifyNum
RFDB (MDBDelete s) -> noResponseHeaders $ convertDelete usrVars s stringifyNum RFDB (MDBDelete s) -> noResponseHeaders $ convertDelete userSession s stringifyNum
RFRemote remote -> pure $ Right remote RFRemote remote -> pure $ Right remote
RFAction (AMSync s) -> Left <$> first liftTx <$> resolveActionExecution s actionExecContext RFAction (AMSync s) -> Left <$> first liftTx <$> resolveActionExecution userInfo s actionExecContext
RFAction (AMAsync s) -> noResponseHeaders =<< resolveActionMutationAsync s reqHeaders usrVars RFAction (AMAsync s) -> noResponseHeaders =<< resolveActionMutationAsync s reqHeaders userSession
RFRaw s -> noResponseHeaders $ pure $ encJFromJValue s RFRaw s -> noResponseHeaders $ pure $ encJFromJValue s
where where
noResponseHeaders :: RespTx -> m (Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField) noResponseHeaders :: RespTx -> m (Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField)
noResponseHeaders rTx = pure $ Left (liftTx rTx, []) noResponseHeaders rTx = pure $ Left (liftTx rTx, [])
actionExecContext = ActionExecContext manager reqHeaders usrVars userSession = _uiSession userInfo
actionExecContext = ActionExecContext manager reqHeaders $ _uiSession userInfo
convertMutationSelectionSet convertMutationSelectionSet
:: (HasVersion, MonadIO m, MonadError QErr m) :: (HasVersion, MonadIO m, MonadError QErr m)
=> GQLContext => GQLContext
-> SessionVariables -> UserInfo
-> HTTP.Manager -> HTTP.Manager
-> HTTP.RequestHeaders -> HTTP.RequestHeaders
-> G.SelectionSet G.NoFragments G.Name -> G.SelectionSet G.NoFragments G.Name
-> [G.VariableDefinition] -> [G.VariableDefinition]
-> Maybe GH.VariableValues -> Maybe GH.VariableValues
-> m (ExecutionPlan (LazyRespTx, HTTP.ResponseHeaders) RemoteCall (G.Name, J.Value)) -> m (ExecutionPlan (LazyRespTx, HTTP.ResponseHeaders) RemoteCall (G.Name, J.Value))
convertMutationSelectionSet gqlContext usrVars manager reqHeaders fields varDefs varValsM = do convertMutationSelectionSet gqlContext userInfo manager reqHeaders fields varDefs varValsM = do
-- Parse the GraphQL query into the RQL AST -- Parse the GraphQL query into the RQL AST
(unpreparedQueries, _reusability) (unpreparedQueries, _reusability)
:: (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue), QueryReusability) :: (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue), QueryReusability)
@ -106,7 +107,7 @@ convertMutationSelectionSet gqlContext usrVars manager reqHeaders fields varDefs
-- Transform the RQL AST into a prepared SQL query -- Transform the RQL AST into a prepared SQL query
-- TODO pass the correct stringifyNum somewhere rather than True -- TODO pass the correct stringifyNum somewhere rather than True
txs <- for unpreparedQueries $ convertMutationRootField usrVars manager reqHeaders True txs <- for unpreparedQueries $ convertMutationRootField userInfo manager reqHeaders True
let txList = OMap.toList txs let txList = OMap.toList txs
case (mapMaybe takeTx txList, mapMaybe takeRemote txList) of case (mapMaybe takeTx txList, mapMaybe takeRemote txList) of
(dbPlans, []) -> do (dbPlans, []) -> do
@ -148,9 +149,9 @@ convertMutationSelectionSet gqlContext usrVars manager reqHeaders fields varDefs
:: (G.Name, Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField) :: (G.Name, Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField)
-> Maybe (G.Name, (LazyRespTx, HTTP.ResponseHeaders)) -> Maybe (G.Name, (LazyRespTx, HTTP.ResponseHeaders))
takeTx (name, Left tx) = Just (name, tx) takeTx (name, Left tx) = Just (name, tx)
takeTx _ = Nothing takeTx _ = Nothing
takeRemote takeRemote
:: (G.Name, Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField) :: (G.Name, Either (LazyRespTx, HTTP.ResponseHeaders) RemoteField)
-> Maybe (G.Name, RemoteField) -> Maybe (G.Name, RemoteField)
takeRemote (name, Right remote) = Just (name, remote) takeRemote (name, Right remote) = Just (name, remote)
takeRemote _ = Nothing takeRemote _ = Nothing

View File

@ -19,6 +19,7 @@ import qualified Data.Aeson.TH as J
import qualified Hasura.Cache as Cache import qualified Hasura.Cache as Cache
import qualified Hasura.GraphQL.Execute.LiveQuery as LQ import qualified Hasura.GraphQL.Execute.LiveQuery as LQ
import qualified Hasura.GraphQL.Execute.Query as EQ import qualified Hasura.GraphQL.Execute.Query as EQ
import qualified Hasura.GraphQL.Execute.Types as ET
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Session import Hasura.Session
@ -29,17 +30,19 @@ data PlanId
, _piRole :: !RoleName , _piRole :: !RoleName
, _piOperationName :: !(Maybe GH.OperationName) , _piOperationName :: !(Maybe GH.OperationName)
, _piQuery :: !GH.GQLQueryText , _piQuery :: !GH.GQLQueryText
, _piQueryType :: !ET.GraphQLQueryType
} deriving (Show, Eq, Ord, Generic) } deriving (Show, Eq, Ord, Generic)
instance Hashable PlanId instance Hashable PlanId
instance J.ToJSON PlanId where instance J.ToJSON PlanId where
toJSON (PlanId scVer rn opNameM query) = toJSON (PlanId scVer rn opNameM query queryType) =
J.object J.object
[ "schema_cache_version" J..= scVer [ "schema_cache_version" J..= scVer
, "role" J..= rn , "role" J..= rn
, "operation" J..= opNameM , "operation" J..= opNameM
, "query" J..= query , "query" J..= query
, "query_type" J..= queryType
] ]
newtype PlanCache newtype PlanCache
@ -68,19 +71,19 @@ initPlanCache options =
getPlan getPlan
:: SchemaCacheVer -> RoleName -> Maybe GH.OperationName -> GH.GQLQueryText :: SchemaCacheVer -> RoleName -> Maybe GH.OperationName -> GH.GQLQueryText
-> PlanCache -> IO (Maybe ReusablePlan) -> ET.GraphQLQueryType -> PlanCache -> IO (Maybe ReusablePlan)
getPlan schemaVer rn opNameM q (PlanCache planCache) = getPlan schemaVer rn opNameM q queryType (PlanCache planCache) =
Cache.lookup planId planCache Cache.lookup planId planCache
where where
planId = PlanId schemaVer rn opNameM q planId = PlanId schemaVer rn opNameM q queryType
addPlan addPlan
:: SchemaCacheVer -> RoleName -> Maybe GH.OperationName -> GH.GQLQueryText :: SchemaCacheVer -> RoleName -> Maybe GH.OperationName -> GH.GQLQueryText
-> ReusablePlan -> PlanCache -> IO () -> ReusablePlan -> ET.GraphQLQueryType -> PlanCache -> IO ()
addPlan schemaVer rn opNameM q queryPlan (PlanCache planCache) = addPlan schemaVer rn opNameM q queryPlan queryType (PlanCache planCache) =
Cache.insert planId queryPlan planCache Cache.insert planId queryPlan planCache
where where
planId = PlanId schemaVer rn opNameM q planId = PlanId schemaVer rn opNameM q queryType
clearPlanCache :: PlanCache -> IO () clearPlanCache :: PlanCache -> IO ()
clearPlanCache (PlanCache planCache) = clearPlanCache (PlanCache planCache) =

View File

@ -37,9 +37,9 @@ import Hasura.Prelude
import Hasura.RQL.DML.RemoteJoin import Hasura.RQL.DML.RemoteJoin
import Hasura.RQL.DML.Select (asSingleRowJsonResp) import Hasura.RQL.DML.Select (asSingleRowJsonResp)
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Session
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
import Hasura.Session
import qualified Hasura.RQL.DML.Select as DS import qualified Hasura.RQL.DML.Select as DS
@ -165,7 +165,7 @@ irToRootFieldPlan vars prepped = \case
QDBPrimaryKey s -> mkPGPlan (DS.selectQuerySQL DS.JASSingleObject) s QDBPrimaryKey s -> mkPGPlan (DS.selectQuerySQL DS.JASSingleObject) s
QDBAggregation s -> QDBAggregation s ->
let (annAggSel, aggRemoteJoins) = getRemoteJoinsAggregateSelect s let (annAggSel, aggRemoteJoins) = getRemoteJoinsAggregateSelect s
in PGPlan (DS.selectAggQuerySQL annAggSel) vars prepped aggRemoteJoins in PGPlan (DS.selectAggregateQuerySQL annAggSel) vars prepped aggRemoteJoins
where where
mkPGPlan f simpleSel = mkPGPlan f simpleSel =
let (simpleSel',remoteJoins) = getRemoteJoins simpleSel let (simpleSel',remoteJoins) = getRemoteJoins simpleSel
@ -182,9 +182,9 @@ traverseQueryRootField f =
where where
f' :: QueryDB a -> f (QueryDB b) f' :: QueryDB a -> f (QueryDB b)
f' = \case f' = \case
QDBSimple s -> QDBSimple <$> DS.traverseAnnSimpleSel f s QDBSimple s -> QDBSimple <$> DS.traverseAnnSimpleSelect f s
QDBPrimaryKey s -> QDBPrimaryKey <$> DS.traverseAnnSimpleSel f s QDBPrimaryKey s -> QDBPrimaryKey <$> DS.traverseAnnSimpleSelect f s
QDBAggregation s -> QDBAggregation <$> DS.traverseAnnAggSel f s QDBAggregation s -> QDBAggregation <$> DS.traverseAnnAggregateSelect f s
convertQuerySelSet convertQuerySelSet
:: forall m. (HasVersion, MonadError QErr m, MonadIO m) :: forall m. (HasVersion, MonadError QErr m, MonadIO m)
@ -265,9 +265,9 @@ convertQuerySelSet gqlContext userInfo manager reqHeaders fields varDefs varVals
:: ActionQuery UnpreparedValue -> StateT PlanningSt m ActionQueryPlan :: ActionQuery UnpreparedValue -> StateT PlanningSt m ActionQueryPlan
convertActionQuery = \case convertActionQuery = \case
AQQuery s -> (AQPQuery . fst) <$> AQQuery s -> (AQPQuery . fst) <$>
lift (resolveActionExecution s $ ActionExecContext manager reqHeaders usrVars) lift (resolveActionExecution userInfo s $ ActionExecContext manager reqHeaders usrVars)
AQAsync s -> AQPAsyncQuery <$> AQAsync s -> AQPAsyncQuery <$>
DS.traverseAnnSimpleSel prepareWithPlan (resolveAsyncActionQuery userInfo s) DS.traverseAnnSimpleSelect prepareWithPlan (resolveAsyncActionQuery userInfo s)
-- use the existing plan and new variables to create a pg query -- use the existing plan and new variables to create a pg query
queryOpFromPlan queryOpFromPlan
@ -341,3 +341,15 @@ mkGeneratedSqlMap resolved =
RRSql ps -> Just ps RRSql ps -> Just ps
RRActionQuery _ -> Nothing RRActionQuery _ -> Nothing
in (alias, res) in (alias, res)
-- The GraphQL Query type
data GraphQLQueryType
= QueryHasura
| QueryRelay
deriving (Show, Eq, Ord, Generic)
instance Hashable GraphQLQueryType
instance J.ToJSON GraphQLQueryType where
toJSON = \case
QueryHasura -> "hasura"
QueryRelay -> "relay"

View File

@ -11,13 +11,13 @@ import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Resolve.Action
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Internal
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
import Hasura.Server.Version (HasVersion)
import Hasura.GraphQL.Resolve.Action
import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Execute.LiveQuery as E import qualified Hasura.GraphQL.Execute.LiveQuery as E
@ -26,11 +26,12 @@ import qualified Hasura.SQL.DML as S
data GQLExplain data GQLExplain
= GQLExplain = GQLExplain
{ _gqeQuery :: !GH.GQLReqParsed { _gqeQuery :: !GH.GQLReqParsed
, _gqeUser :: !(Maybe (Map.HashMap Text Text)) , _gqeUser :: !(Maybe (Map.HashMap Text Text))
, _gqeIsRelay :: !(Maybe Bool)
} deriving (Show, Eq) } deriving (Show, Eq)
$(J.deriveJSON (J.aesonDrop 4 J.camelCase){J.omitNothingFields=True} $(J.deriveJSON (J.aesonDrop 4 J.snakeCase){J.omitNothingFields=True}
''GQLExplain ''GQLExplain
) )
@ -117,24 +118,26 @@ explainGQLQuery
-> QueryActionExecuter -> QueryActionExecuter
-> GQLExplain -> GQLExplain
-> m EncJSON -> m EncJSON
explainGQLQuery pgExecCtx sc sqlGenCtx enableAL actionExecuter (GQLExplain query userVarsRaw) = do explainGQLQuery pgExecCtx sc sqlGenCtx enableAL actionExecuter (GQLExplain query userVarsRaw maybeIsRelay) = do
userInfo <- mkUserInfo (URBFromSessionVariablesFallback adminRoleName) UAdminSecretSent sessionVariables
(execPlan, queryReusability) <- runReusabilityT $ (execPlan, queryReusability) <- runReusabilityT $
E.getExecPlanPartial userInfo sc enableAL query E.getExecPlanPartial userInfo sc queryType enableAL query
(gCtx, rootSelSet) <- case execPlan of (gCtx, rootSelSet) <- case execPlan of
E.GExPHasura (gCtx, rootSelSet) -> E.GExPHasura (gCtx, rootSelSet) ->
return (gCtx, rootSelSet) return (gCtx, rootSelSet)
E.GExPRemote _ _ -> E.GExPRemote{} ->
throw400 InvalidParams "only hasura queries can be explained" throw400 InvalidParams "only hasura queries can be explained"
case rootSelSet of case rootSelSet of
GV.RQuery selSet -> GV.RQuery selSet ->
runInTx $ encJFromJValue <$> traverse (explainField userInfo gCtx sqlGenCtx actionExecuter) runInTx $ encJFromJValue . map snd <$>
(toList selSet) GV.traverseObjectSelectionSet selSet (explainField userInfo gCtx sqlGenCtx actionExecuter)
GV.RMutation _ -> GV.RMutation _ ->
throw400 InvalidParams "only queries can be explained" throw400 InvalidParams "only queries can be explained"
GV.RSubscription rootField -> do GV.RSubscription fields -> do
(plan, _) <- E.getSubsOp pgExecCtx gCtx sqlGenCtx userInfo queryReusability actionExecuter rootField (plan, _) <- E.getSubsOp pgExecCtx gCtx sqlGenCtx userInfo
queryReusability actionExecuter fields
runInTx $ encJFromJValue <$> E.explainLiveQueryPlan plan runInTx $ encJFromJValue <$> E.explainLiveQueryPlan plan
where where
usrVars = mkUserVars $ maybe [] Map.toList userVarsRaw queryType = bool E.QueryHasura E.QueryRelay $ fromMaybe False maybeIsRelay
userInfo = mkUserInfo (fromMaybe adminRole $ roleFromVars usrVars) usrVars sessionVariables = mkSessionVariablesText $ maybe [] Map.toList userVarsRaw
runInTx = liftEither <=< liftIO . runExceptT . runLazyTx pgExecCtx Q.ReadOnly runInTx = liftEither <=< liftIO . runExceptT . runLazyTx pgExecCtx Q.ReadOnly

View File

@ -236,7 +236,7 @@ mkGCtxRole' tn descM insPermM selPermM updColsM delPermM pkeyCols constraints vi
in case riType relInfo of in case riType relInfo of
ObjRel -> [relFld] ObjRel -> [relFld]
ArrRel -> bool [relFld] [relFld, aggRelFld] allowAgg ArrRel -> bool [relFld] [relFld, aggRelFld] allowAgg
SFComputedField cf -> pure SAFComputedField cf -> pure
( (ty, mkComputedFieldName $ _cfName cf) ( (ty, mkComputedFieldName $ _cfName cf)
, RFComputedField cf , RFComputedField cf
) )

View File

@ -8,6 +8,8 @@ module Hasura.GraphQL.Schema.Builder
, addFieldsToTyAgg , addFieldsToTyAgg
, addTypeInfoToTyAgg , addTypeInfoToTyAgg
, addScalarToTyAgg , addScalarToTyAgg
, QueryRootFieldMap
, MutationRootFieldMap
, RootFields(..) , RootFields(..)
, addQueryField , addQueryField
, addMutationField , addMutationField
@ -57,11 +59,14 @@ instance Semigroup TyAgg where
instance Monoid TyAgg where instance Monoid TyAgg where
mempty = TyAgg Map.empty Map.empty Set.empty Map.empty mempty = TyAgg Map.empty Map.empty Set.empty Map.empty
type QueryRootFieldMap = Map.HashMap G.Name (QueryCtx, ObjFldInfo)
type MutationRootFieldMap = Map.HashMap G.Name (MutationCtx, ObjFldInfo)
-- | A role-specific mapping from root field names to allowed operations. -- | A role-specific mapping from root field names to allowed operations.
data RootFields data RootFields
= RootFields = RootFields
{ _rootQueryFields :: !(Map.HashMap G.Name (QueryCtx, ObjFldInfo)) { _rootQueryFields :: !QueryRootFieldMap
, _rootMutationFields :: !(Map.HashMap G.Name (MutationCtx, ObjFldInfo)) , _rootMutationFields :: !MutationRootFieldMap
} deriving (Show, Eq) } deriving (Show, Eq)
$(makeLenses ''RootFields) $(makeLenses ''RootFields)

View File

@ -2,14 +2,17 @@ module Hasura.GraphQL.Schema.Function
( procFuncArgs ( procFuncArgs
, mkFuncArgsInp , mkFuncArgsInp
, mkFuncQueryFld , mkFuncQueryFld
, mkFuncQueryConnectionFld
, mkFuncAggQueryFld , mkFuncAggQueryFld
, mkFuncArgsTy , mkFuncArgsTy
, mkFuncArgItemSeq
) where ) where
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as T import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.Resolve.Types
import Hasura.GraphQL.Schema.Common import Hasura.GraphQL.Schema.Common
import Hasura.GraphQL.Schema.Select import Hasura.GraphQL.Schema.Select
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
@ -92,6 +95,20 @@ mkFuncQueryFld funInfo descM =
ty = G.toGT $ G.toNT $ G.toLT $ G.toNT $ mkTableTy retTable ty = G.toGT $ G.toNT $ G.toLT $ G.toNT $ mkTableTy retTable
mkFuncQueryConnectionFld
:: FunctionInfo -> Maybe PGDescription -> ObjFldInfo
mkFuncQueryConnectionFld funInfo descM =
mkHsraObjFldInfo (Just desc) fldName (mkFuncArgs funInfo) ty
where
retTable = fiReturnType funInfo
funcName = fiName funInfo
desc = mkDescriptionWith descM $ "execute function " <> funcName
<<> " which returns " <>> retTable
fldName = qualObjectToName funcName <> "_connection"
ty = G.toGT $ G.toNT $ G.toLT $ G.toNT $ mkTableConnectionTy retTable
{- {-
function_aggregate( function_aggregate(
@ -118,3 +135,15 @@ mkFuncAggQueryFld funInfo descM =
fldName = qualObjectToName funcName <> "_aggregate" fldName = qualObjectToName funcName <> "_aggregate"
ty = G.toGT $ G.toNT $ mkTableAggTy retTable ty = G.toGT $ G.toNT $ mkTableAggTy retTable
mkFuncArgItemSeq :: FunctionInfo -> Seq (InputArgument FunctionArgItem)
mkFuncArgItemSeq functionInfo =
let inputArgs = fiInputArgs functionInfo
in Seq.fromList $ procFuncArgs inputArgs nameFn resultFn
where
nameFn = \case
IAUserProvided fa -> faName fa
IASessionVariables name -> Just name
resultFn arg gName = flip fmap arg $
\fa -> FunctionArgItem (G.Name gName) (faName fa) (faHasDefault fa)

View File

@ -0,0 +1,300 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Hasura.GraphQL.NormalForm
( Selection(..)
, NormalizedSelection
, NormalizedSelectionSet
, NormalizedField
, SelectionSet(..)
, RootSelectionSet(..)
-- , toGraphQLOperation
, ArgsMap
, Field(..)
, Typename(..)
, IsField(..)
, toField
, AliasedFields(..)
, asObjectSelectionSet
, ObjectSelectionSet(..)
, ObjectSelectionSetMap
, traverseObjectSelectionSet
, InterfaceSelectionSet
, asInterfaceSelectionSet
, getMemberSelectionSet
, UnionSelectionSet
, ScopedSelectionSet(..)
, emptyScopedSelectionSet
, getUnionSelectionSet
, getInterfaceSelectionSet
, getObjectSelectionSet
, AnnInpVal(..)
, AnnGValue(..)
, AnnGObject
, AnnGEnumValue(..)
, hasNullVal
, getAnnInpValKind
, toGraphQLField
, toGraphQLSelectionSet
) where
import Hasura.Prelude
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.Extended as OMap
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Hasura.RQL.Types.Column as RQL
import qualified Hasura.RQL.Types.Error as RQL
import Hasura.SQL.Types
import Hasura.SQL.Value
data Selection f s
= SelectionField !G.Alias !f
| SelectionInlineFragmentSpread !s
| SelectionFragmentSpread !G.Name !s
deriving (Show, Eq)
-- | What a processed G.SelectionSet should look like
type family NormalizedSelectionSet a = s | s -> a
-- | What a processed G.Field should look like
type family NormalizedField a
type NormalizedSelection a
= Selection (NormalizedField a) (NormalizedSelectionSet a)
-- | Ordered fields
newtype AliasedFields f
= AliasedFields { unAliasedFields :: OMap.InsOrdHashMap G.Alias f }
deriving (Show, Eq, Functor, Foldable, Traversable, Semigroup)
newtype ObjectSelectionSet
= ObjectSelectionSet { unObjectSelectionSet :: AliasedFields Field }
deriving (Show, Eq, Semigroup)
traverseObjectSelectionSet
:: (Monad m) => ObjectSelectionSet -> (Field -> m a) -> m [(Text, a)]
traverseObjectSelectionSet selectionSet f =
forM (OMap.toList $ unAliasedFields $ unObjectSelectionSet selectionSet) $
\(alias, field) -> (G.unName $ G.unAlias alias,) <$> f field
type ObjectSelectionSetMap
= Map.HashMap G.NamedType ObjectSelectionSet
data Typename = Typename
deriving (Show, Eq, Generic)
data ScopedSelectionSet f
= ScopedSelectionSet
{ _sssBaseSelectionSet :: !(AliasedFields f)
-- ^ Fields that aren't explicitly defined for member types
, _sssMemberSelectionSets :: !ObjectSelectionSetMap
-- ^ SelectionSets of individual member types
} deriving (Show, Eq, Generic)
emptyScopedSelectionSet :: ScopedSelectionSet f
emptyScopedSelectionSet =
ScopedSelectionSet (AliasedFields mempty) mempty
type InterfaceSelectionSet = ScopedSelectionSet Field
type UnionSelectionSet = ScopedSelectionSet Typename
data RootSelectionSet
= RQuery !ObjectSelectionSet
| RMutation !ObjectSelectionSet
| RSubscription !ObjectSelectionSet
deriving (Show, Eq)
-- toGraphQLOperation :: RootSelectionSet -> G.ExecutableDefinition
-- toGraphQLOperation = \case
-- RQuery selectionSet ->
-- mkExecutableDefinition G.OperationTypeQuery $
-- toGraphQLSelectionSet $ SelectionSetObject selectionSet
-- RMutation selectionSet ->
-- mkExecutableDefinition G.OperationTypeQuery $
-- toGraphQLSelectionSet $ SelectionSetObject selectionSet
-- RSubscription opDef _ ->
-- G.ExecutableDefinitionOperation $ G.OperationDefinitionTyped opDef
-- where
-- mkExecutableDefinition operationType selectionSet =
-- G.ExecutableDefinitionOperation $ G.OperationDefinitionTyped $
-- G.TypedOperationDefinition
-- { G._todName = Nothing -- TODO, store the name too?
-- , G._todDirectives = []
-- , G._todType = operationType
-- , G._todVariableDefinitions = []
-- , G._todSelectionSet = selectionSet
-- }
data SelectionSet
= SelectionSetObject !ObjectSelectionSet
| SelectionSetUnion !UnionSelectionSet
| SelectionSetInterface !InterfaceSelectionSet
| SelectionSetNone
-- ^ in cases of enums and scalars
deriving (Show, Eq)
getObjectSelectionSet :: SelectionSet -> Maybe ObjectSelectionSet
getObjectSelectionSet = \case
SelectionSetObject s -> pure s
_ -> Nothing
asObjectSelectionSet
:: (MonadError RQL.QErr m) => SelectionSet -> m ObjectSelectionSet
asObjectSelectionSet selectionSet =
onNothing (getObjectSelectionSet selectionSet) $
RQL.throw500 "expecting ObjectSelectionSet"
getUnionSelectionSet :: SelectionSet -> Maybe UnionSelectionSet
getUnionSelectionSet = \case
SelectionSetUnion s -> pure s
_ -> Nothing
getInterfaceSelectionSet :: SelectionSet -> Maybe InterfaceSelectionSet
getInterfaceSelectionSet = \case
SelectionSetInterface s -> pure s
_ -> Nothing
asInterfaceSelectionSet
:: (MonadError RQL.QErr m) => SelectionSet -> m InterfaceSelectionSet
asInterfaceSelectionSet selectionSet =
onNothing (getInterfaceSelectionSet selectionSet) $
RQL.throw500 "expecting InterfaceSelectionSet"
type ArgsMap = Map.HashMap G.Name AnnInpVal
data Field
= Field
{ _fName :: !G.Name
, _fType :: !G.NamedType
, _fArguments :: !ArgsMap
, _fSelSet :: !SelectionSet
} deriving (Eq, Show)
toGraphQLField :: G.Alias -> Field -> G.Field
toGraphQLField alias Field{..} =
G.Field
{ G._fName = _fName
, G._fArguments = [] -- TODO
, G._fDirectives = []
, G._fAlias = Just alias
, G._fSelectionSet = toGraphQLSelectionSet _fSelSet
}
toGraphQLSelectionSet :: SelectionSet -> G.SelectionSet
toGraphQLSelectionSet = \case
SelectionSetObject selectionSet -> fromSelectionSet selectionSet
SelectionSetInterface selectionSet -> fromScopedSelectionSet selectionSet
SelectionSetUnion selectionSet -> fromScopedSelectionSet selectionSet
SelectionSetNone -> mempty
where
fromAliasedFields :: (IsField f) => AliasedFields f -> G.SelectionSet
fromAliasedFields =
map (G.SelectionField . uncurry toGraphQLField) .
OMap.toList . fmap toField . unAliasedFields
fromSelectionSet =
fromAliasedFields . unObjectSelectionSet
toInlineSelection typeName =
G.SelectionInlineFragment . G.InlineFragment (Just typeName) mempty .
fromSelectionSet
fromScopedSelectionSet (ScopedSelectionSet base specific) =
map (uncurry toInlineSelection) (Map.toList specific) <> fromAliasedFields base
-- $(J.deriveToJSON (J.aesonDrop 2 J.camelCase){J.omitNothingFields=True}
-- ''Field
-- )
-- $(J.deriveToJSON (J.aesonDrop 2 J.camelCase){J.omitNothingFields=True}
-- ''InterfaceSelectionSet
-- )
-- $(J.deriveToJSON (J.aesonDrop 2 J.camelCase){J.omitNothingFields=True}
-- ''SelectionSet
-- )
class IsField f where
getFieldName :: f -> G.Name
getFieldType :: f -> G.NamedType
getFieldArguments :: f -> ArgsMap
getFieldSelectionSet :: f -> SelectionSet
toField :: (IsField f) => f -> Field
toField f =
Field (getFieldName f) (getFieldType f)
(getFieldArguments f) (getFieldSelectionSet f)
instance IsField Field where
getFieldName = _fName
getFieldType = _fType
getFieldArguments = _fArguments
getFieldSelectionSet = _fSelSet
instance IsField Typename where
getFieldName _ = "__typename"
getFieldType _ = G.NamedType "String"
getFieldArguments _ = mempty
getFieldSelectionSet _ = SelectionSetNone
getMemberSelectionSet
:: IsField f
=> G.NamedType -> ScopedSelectionSet f -> ObjectSelectionSet
getMemberSelectionSet namedType (ScopedSelectionSet {..}) =
fromMaybe (ObjectSelectionSet (fmap toField _sssBaseSelectionSet)) $
Map.lookup namedType $ _sssMemberSelectionSets
data AnnInpVal
= AnnInpVal
{ _aivType :: !G.GType
, _aivVariable :: !(Maybe G.Variable)
, _aivValue :: !AnnGValue
} deriving (Show, Eq)
type AnnGObject = OMap.InsOrdHashMap G.Name AnnInpVal
-- | See 'EnumValuesInfo' for information about what these cases mean.
data AnnGEnumValue
= AGESynthetic !(Maybe G.EnumValue)
| AGEReference !RQL.EnumReference !(Maybe RQL.EnumValue)
deriving (Show, Eq)
data AnnGValue
= AGScalar !PGScalarType !(Maybe PGScalarValue)
| AGEnum !G.NamedType !AnnGEnumValue
| AGObject !G.NamedType !(Maybe AnnGObject)
| 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]
hasNullVal :: AnnGValue -> Bool
hasNullVal = \case
AGScalar _ Nothing -> True
AGEnum _ (AGESynthetic Nothing) -> True
AGEnum _ (AGEReference _ Nothing) -> True
AGObject _ Nothing -> True
AGArray _ Nothing -> True
_ -> False
getAnnInpValKind :: AnnGValue -> Text
getAnnInpValKind = \case
AGScalar _ _ -> "scalar"
AGEnum _ _ -> "enum"
AGObject _ _ -> "object"
AGArray _ _ -> "array"

View File

@ -0,0 +1,407 @@
module Hasura.GraphQL.RelaySchema where
import Control.Lens.Extended hiding (op)
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.Context
import Hasura.GraphQL.Resolve.Types
import Hasura.GraphQL.Validate.Types
import Hasura.Prelude
import Hasura.RQL.Types
import Hasura.Server.Utils (duplicates)
import Hasura.Session
import Hasura.SQL.Types
import Hasura.GraphQL.Schema
import Hasura.GraphQL.Schema.BoolExp
import Hasura.GraphQL.Schema.Builder
import Hasura.GraphQL.Schema.Common
import Hasura.GraphQL.Schema.Function
import Hasura.GraphQL.Schema.OrderBy
import Hasura.GraphQL.Schema.Select
mkNodeInterface :: [QualifiedTable] -> IFaceTyInfo
mkNodeInterface relayTableNames =
let description = G.Description "An object with globally unique ID"
in mkIFaceTyInfo (Just description) nodeType (mapFromL _fiName [idField]) $
Set.fromList $ map mkTableTy relayTableNames
where
idField =
let description = G.Description "A globally unique identifier"
in mkHsraObjFldInfo (Just description) "id" mempty nodeIdType
mkRelayGCtxMap
:: forall m. (MonadError QErr m)
=> TableCache -> FunctionCache -> m GCtxMap
mkRelayGCtxMap tableCache functionCache = do
typesMapL <- mapM (mkRelayGCtxMapTable tableCache functionCache) relayTables
typesMap <- combineTypes typesMapL
let gCtxMap = flip Map.map typesMap $
\(ty, flds, insCtx) -> mkGCtx ty flds insCtx
pure $ Map.map (flip RoleContext Nothing) gCtxMap
where
relayTables =
filter (tableFltr . _tiCoreInfo) $ Map.elems tableCache
tableFltr ti =
not (isSystemDefined $ _tciSystemDefined ti)
&& isValidObjectName (_tciName ti)
&& isJust (_tciPrimaryKey ti)
combineTypes
:: [Map.HashMap RoleName (TyAgg, RootFields, InsCtxMap)]
-> m (Map.HashMap RoleName (TyAgg, RootFields, InsCtxMap))
combineTypes maps = do
let listMap = foldr (Map.unionWith (++) . Map.map pure) mempty maps
flip Map.traverseWithKey listMap $ \roleName typeList -> do
let relayTableNames = map (_tciName . _tiCoreInfo) relayTables
tyAgg = addTypeInfoToTyAgg
(TIIFace $ mkNodeInterface relayTableNames) $
mconcat $ map (^. _1) typeList
insCtx = mconcat $ map (^. _3) typeList
rootFields <- combineRootFields roleName $ map (^. _2) typeList
pure (tyAgg, rootFields, insCtx)
combineRootFields :: RoleName -> [RootFields] -> m RootFields
combineRootFields roleName rootFields = do
let duplicateQueryFields = duplicates $
concatMap (Map.keys . _rootQueryFields) rootFields
duplicateMutationFields = duplicates $
concatMap (Map.keys . _rootMutationFields) rootFields
-- TODO: The following exception should result in inconsistency
when (not $ null duplicateQueryFields) $
throw400 Unexpected $ "following query root fields are duplicated: "
<> showNames duplicateQueryFields
when (not $ null duplicateMutationFields) $
throw400 Unexpected $ "following mutation root fields are duplicated: "
<> showNames duplicateMutationFields
pure $ mconcat $ mkNodeQueryRootFields roleName relayTables : rootFields
mkRelayGCtxMapTable
:: (MonadError QErr m)
=> TableCache
-> FunctionCache
-> TableInfo
-> m (Map.HashMap RoleName (TyAgg, RootFields, InsCtxMap))
mkRelayGCtxMapTable tableCache funcCache tabInfo = do
m <- flip Map.traverseWithKey rolePerms $
mkRelayGCtxRole tableCache tn descM fields primaryKey validConstraints tabFuncs viewInfo customConfig
adminSelFlds <- mkAdminSelFlds fields tableCache
adminInsCtx <- mkAdminInsCtx tableCache fields
let adminCtx = mkRelayTyAggRole tn descM (Just (cols, icRelations adminInsCtx))
(Just (True, adminSelFlds)) (Just cols) (Just ())
primaryKey validConstraints viewInfo tabFuncs
adminInsCtxMap = Map.singleton tn adminInsCtx
return $ Map.insert adminRoleName (adminCtx, adminRootFlds, adminInsCtxMap) m
where
TableInfo coreInfo rolePerms _ = tabInfo
TableCoreInfo tn descM _ fields primaryKey _ _ viewInfo _ customConfig = coreInfo
validConstraints = mkValidConstraints $ map _cName (tciUniqueOrPrimaryKeyConstraints coreInfo)
tabFuncs = filter (isValidObjectName . fiName) $
getFuncsOfTable tn funcCache
cols = getValidCols fields
adminRootFlds =
let insertPermDetails = Just ([], True)
selectPermDetails = Just (noFilter, Nothing, [], True)
updatePermDetails = Just (getValidCols fields, mempty, noFilter, Nothing, [])
deletePermDetails = Just (noFilter, [])
queryFields = getRelayQueryRootFieldsRole tn primaryKey fields tabFuncs
selectPermDetails
mutationFields = getMutationRootFieldsRole tn primaryKey
validConstraints fields insertPermDetails
selectPermDetails updatePermDetails
deletePermDetails viewInfo customConfig
in RootFields queryFields mutationFields
mkRelayGCtxRole
:: (MonadError QErr m)
=> TableCache
-> QualifiedTable
-> Maybe PGDescription
-> FieldInfoMap FieldInfo
-> Maybe (PrimaryKey PGColumnInfo)
-> [ConstraintName]
-> [FunctionInfo]
-> Maybe ViewInfo
-> TableConfig
-> RoleName
-> RolePermInfo
-> m (TyAgg, RootFields, InsCtxMap)
mkRelayGCtxRole tableCache tn descM fields primaryKey constraints funcs viM tabConfigM role permInfo = do
selPermM <- mapM (getSelPerm tableCache fields role) selM
tabInsInfoM <- forM (_permIns permInfo) $ \ipi -> do
ctx <- mkInsCtx role tableCache fields ipi $ _permUpd permInfo
let permCols = flip getColInfos allCols $ Set.toList $ ipiCols ipi
return (ctx, (permCols, icRelations ctx))
let insPermM = snd <$> tabInsInfoM
insCtxM = fst <$> tabInsInfoM
updColsM = filterColumnFields . upiCols <$> _permUpd permInfo
tyAgg = mkRelayTyAggRole tn descM insPermM selPermM updColsM
(void $ _permDel permInfo) primaryKey constraints viM funcs
queryRootFlds = getRelayQueryRootFieldsRole tn primaryKey fields funcs
(mkSel <$> _permSel permInfo)
mutationRootFlds = getMutationRootFieldsRole tn primaryKey constraints fields
(mkIns <$> insM) (mkSel <$> selM)
(mkUpd <$> updM) (mkDel <$> delM) viM tabConfigM
insCtxMap = maybe Map.empty (Map.singleton tn) insCtxM
return (tyAgg, RootFields queryRootFlds mutationRootFlds, insCtxMap)
where
RolePermInfo insM selM updM delM = permInfo
allCols = getCols fields
filterColumnFields allowedSet =
filter ((`Set.member` allowedSet) . pgiColumn) $ getValidCols fields
mkIns i = (ipiRequiredHeaders i, isJust updM)
mkSel s = ( spiFilter s, spiLimit s
, spiRequiredHeaders s, spiAllowAgg s
)
mkUpd u = ( flip getColInfos allCols $ Set.toList $ upiCols u
, upiSet u
, upiFilter u
, upiCheck u
, upiRequiredHeaders u
)
mkDel d = (dpiFilter d, dpiRequiredHeaders d)
mkRelayTyAggRole
:: QualifiedTable
-> Maybe PGDescription
-- ^ Postgres description
-> Maybe ([PGColumnInfo], RelationInfoMap)
-- ^ insert permission
-> Maybe (Bool, [SelField])
-- ^ select permission
-> Maybe [PGColumnInfo]
-- ^ update cols
-> Maybe ()
-- ^ delete cols
-> Maybe (PrimaryKey PGColumnInfo)
-> [ConstraintName]
-- ^ constraints
-> Maybe ViewInfo
-> [FunctionInfo]
-- ^ all functions
-> TyAgg
mkRelayTyAggRole tn descM insPermM selPermM updColsM delPermM pkeyCols constraints viM funcs =
let (mutationTypes, mutationFields) =
mkMutationTypesAndFieldsRole tn insPermM selFldsM updColsM delPermM pkeyCols constraints viM
in TyAgg (mkTyInfoMap allTypes <> mutationTypes)
(fieldMap <> mutationFields)
scalars ordByCtx
where
ordByCtx = fromMaybe Map.empty ordByCtxM
funcInpArgTys = bool [] (map TIInpObj funcArgInpObjs) $ isJust selFldsM
allTypes = queryTypes <> aggQueryTypes <> funcInpArgTys <> computedFieldFuncArgsInps
queryTypes = map TIObj selectObjects <>
catMaybes
[ TIInpObj <$> boolExpInpObjM
, TIInpObj <$> ordByInpObjM
, TIEnum <$> selColInpTyM
]
aggQueryTypes = map TIObj aggObjs <> map TIInpObj aggOrdByInps
fieldMap = Map.unions $ catMaybes [boolExpInpObjFldsM, selObjFldsM]
scalars = selByPkScalarSet <> funcArgScalarSet <> computedFieldFuncArgScalars
selFldsM = snd <$> selPermM
selColNamesM = map pgiName . getPGColumnFields <$> selFldsM
selColInpTyM = mkSelColumnTy tn <$> selColNamesM
-- boolexp input type
boolExpInpObjM = case selFldsM of
Just selFlds -> Just $ mkBoolExpInp tn selFlds
-- no select permission
Nothing ->
-- but update/delete is defined
if isJust updColsM || isJust delPermM
then Just $ mkBoolExpInp tn []
else Nothing
-- funcargs input type
funcArgInpObjs = flip mapMaybe funcs $ \func ->
mkFuncArgsInp (fiName func) (getInputArgs func)
-- funcArgCtx = Map.unions funcArgCtxs
funcArgScalarSet = funcs ^.. folded.to getInputArgs.folded.to (_qptName.faType)
-- helper
mkFldMap ty = Map.fromList . concatMap (mkFld ty)
mkFld ty = \case
SFPGColumn ci -> [((ty, pgiName ci), RFPGColumn ci)]
SFRelationship (RelationshipFieldInfo relInfo allowAgg cols permFilter permLimit maybePkCols _) ->
let relationshipName = riName relInfo
relFld = ( (ty, mkRelName relationshipName)
, RFRelationship $ RelationshipField relInfo RFKSimple cols permFilter permLimit
)
aggRelFld = ( (ty, mkAggRelName relationshipName)
, RFRelationship $ RelationshipField relInfo RFKAggregate cols permFilter permLimit
)
maybeConnFld = maybePkCols <&> \pkCols ->
( (ty, mkConnectionRelName relationshipName)
, RFRelationship $ RelationshipField relInfo
(RFKConnection pkCols) cols permFilter permLimit
)
in case riType relInfo of
ObjRel -> [relFld]
ArrRel -> bool [relFld] ([relFld, aggRelFld] <> maybe [] pure maybeConnFld) allowAgg
SFComputedField cf -> pure
( (ty, mkComputedFieldName $ _cfName cf)
, RFComputedField cf
)
SFRemoteRelationship remoteField -> pure
( (ty, G.Name (remoteRelationshipNameToText (_rfiName remoteField)))
, RFRemoteRelationship remoteField
)
-- the fields used in bool exp
boolExpInpObjFldsM = mkFldMap (mkBoolExpTy tn) <$> selFldsM
-- table obj
selectObjects = case selPermM of
Just (_, selFlds) ->
[ (mkRelayTableObj tn descM selFlds)
{_otiImplIFaces = Set.singleton nodeType}
, mkTableEdgeObj tn
, mkTableConnectionObj tn
]
Nothing -> []
-- aggregate objs and order by inputs
(aggObjs, aggOrdByInps) = case selPermM of
Just (True, selFlds) ->
let cols = getPGColumnFields selFlds
numCols = onlyNumCols cols
compCols = onlyComparableCols cols
objs = [ mkTableAggObj tn
, mkTableAggregateFieldsObj tn (numCols, numAggregateOps) (compCols, compAggregateOps)
] <> mkColAggregateFieldsObjs selFlds
ordByInps = mkTabAggOrdByInpObj tn (numCols, numAggregateOps) (compCols, compAggregateOps)
: mkTabAggregateOpOrdByInpObjs tn (numCols, numAggregateOps) (compCols, compAggregateOps)
in (objs, ordByInps)
_ -> ([], [])
getNumericCols = onlyNumCols . getPGColumnFields
getComparableCols = onlyComparableCols . getPGColumnFields
onlyFloat = const $ mkScalarTy PGFloat
mkTypeMaker "sum" = mkColumnType
mkTypeMaker _ = onlyFloat
mkColAggregateFieldsObjs flds =
let numCols = getNumericCols flds
compCols = getComparableCols flds
mkNumObjFld n = mkTableColAggregateFieldsObj tn n (mkTypeMaker n) numCols
mkCompObjFld n = mkTableColAggregateFieldsObj tn n mkColumnType compCols
numFldsObjs = bool (map mkNumObjFld numAggregateOps) [] $ null numCols
compFldsObjs = bool (map mkCompObjFld compAggregateOps) [] $ null compCols
in numFldsObjs <> compFldsObjs
-- the fields used in table object
nodeFieldM = RFNodeId tn . _pkColumns <$> pkeyCols
selObjFldsM = mkFldMap (mkTableTy tn) <$> selFldsM >>=
\fm -> nodeFieldM <&> \nodeField ->
Map.insert (mkTableTy tn, "id") nodeField fm
-- the scalar set for table_by_pk arguments
selByPkScalarSet = pkeyCols ^.. folded.to _pkColumns.folded.to pgiType._PGColumnScalar
ordByInpCtxM = mkOrdByInpObj tn <$> selFldsM
(ordByInpObjM, ordByCtxM) = case ordByInpCtxM of
Just (a, b) -> (Just a, Just b)
Nothing -> (Nothing, Nothing)
-- computed fields' function args input objects and scalar types
mkComputedFieldRequiredTypes computedFieldInfo =
let ComputedFieldFunction qf inputArgs _ _ _ = _cfFunction computedFieldInfo
scalarArgs = map (_qptName . faType) $ toList inputArgs
in (, scalarArgs) <$> mkFuncArgsInp qf inputArgs
computedFieldReqTypes = catMaybes $
maybe [] (map mkComputedFieldRequiredTypes . getComputedFields) selFldsM
computedFieldFuncArgsInps = map (TIInpObj . fst) computedFieldReqTypes
computedFieldFuncArgScalars = Set.fromList $ concatMap snd computedFieldReqTypes
mkSelectOpCtx
:: QualifiedTable
-> [PGColumnInfo]
-> (AnnBoolExpPartialSQL, Maybe Int, [T.Text]) -- select filter
-> SelOpCtx
mkSelectOpCtx tn allCols (fltr, pLimit, hdrs) =
SelOpCtx tn hdrs colGNameMap fltr pLimit
where
colGNameMap = mkPGColGNameMap allCols
getRelayQueryRootFieldsRole
:: QualifiedTable
-> Maybe (PrimaryKey PGColumnInfo)
-> FieldInfoMap FieldInfo
-> [FunctionInfo]
-> Maybe (AnnBoolExpPartialSQL, Maybe Int, [T.Text], Bool) -- select filter
-> QueryRootFieldMap
getRelayQueryRootFieldsRole tn primaryKey fields funcs selM =
makeFieldMap $
funcConnectionQueries
<> catMaybes
[ getSelConnectionDet <$> selM <*> maybePrimaryKeyColumns
]
where
maybePrimaryKeyColumns = fmap _pkColumns primaryKey
colGNameMap = mkPGColGNameMap $ getCols fields
funcConnectionQueries = fromMaybe [] $ getFuncQueryConnectionFlds
<$> selM <*> maybePrimaryKeyColumns
getSelConnectionDet (selFltr, pLimit, hdrs, _) primaryKeyColumns =
selFldHelper (QCSelectConnection primaryKeyColumns)
(mkSelFldConnection Nothing) selFltr pLimit hdrs
selFldHelper f g pFltr pLimit hdrs =
( f $ mkSelectOpCtx tn (getCols fields) (pFltr, pLimit, hdrs)
, g tn
)
getFuncQueryConnectionFlds (selFltr, pLimit, hdrs, _) primaryKeyColumns =
funcFldHelper (QCFuncConnection primaryKeyColumns) mkFuncQueryConnectionFld selFltr pLimit hdrs
funcFldHelper f g pFltr pLimit hdrs =
flip map funcs $ \fi ->
( f $ FuncQOpCtx (fiName fi) (mkFuncArgItemSeq fi) hdrs colGNameMap pFltr pLimit
, g fi $ fiDescription fi
)
mkNodeQueryRootFields :: RoleName -> [TableInfo] -> RootFields
mkNodeQueryRootFields roleName relayTables =
RootFields (mapFromL (_fiName . snd) [nodeQueryDet]) mempty
where
nodeQueryDet =
( QCNodeSelect nodeSelMap
, nodeQueryField
)
nodeQueryField =
let nodeParams = fromInpValL $ pure $
InpValInfo (Just $ G.Description "A globally unique id")
"id" Nothing nodeIdType
in mkHsraObjFldInfo Nothing "node" nodeParams $ G.toGT nodeType
nodeSelMap =
Map.fromList $ flip mapMaybe relayTables $ \table ->
let tableName = _tciName $ _tiCoreInfo table
allColumns = getCols $ _tciFieldInfoMap $ _tiCoreInfo table
selectPermM = _permSel <$> Map.lookup roleName
(_tiRolePermInfoMap table)
permDetailsM = join selectPermM <&> \perm ->
( spiFilter perm
, spiLimit perm
, spiRequiredHeaders perm
)
adminPermDetails = (noFilter, Nothing, [])
in (mkTableTy tableName,) . mkSelectOpCtx tableName allColumns
<$> bool permDetailsM (Just adminPermDetails) (isAdmin roleName)

View File

@ -12,6 +12,7 @@ module Hasura.GraphQL.Resolve
, QueryRootFldUnresolved , QueryRootFldUnresolved
, QueryRootFldResolved , QueryRootFldResolved
, toPGQuery , toPGQuery
, toSQLFromItem
, RIntro.schemaR , RIntro.schemaR
, RIntro.typeR , RIntro.typeR
@ -36,14 +37,17 @@ import qualified Hasura.GraphQL.Resolve.Insert as RI
import qualified Hasura.GraphQL.Resolve.Introspect as RIntro import qualified Hasura.GraphQL.Resolve.Introspect as RIntro
import qualified Hasura.GraphQL.Resolve.Mutation as RM import qualified Hasura.GraphQL.Resolve.Mutation as RM
import qualified Hasura.GraphQL.Resolve.Select as RS import qualified Hasura.GraphQL.Resolve.Select as RS
import qualified Hasura.GraphQL.Schema.Common as GS
import qualified Hasura.GraphQL.Validate as V import qualified Hasura.GraphQL.Validate as V
import qualified Hasura.RQL.DML.Select as DS import qualified Hasura.RQL.DML.Select as DS
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
data QueryRootFldAST v data QueryRootFldAST v
= QRFPk !(DS.AnnSimpleSelG v) = QRFNode !(DS.AnnSimpleSelG v)
| QRFPk !(DS.AnnSimpleSelG v)
| QRFSimple !(DS.AnnSimpleSelG v) | QRFSimple !(DS.AnnSimpleSelG v)
| QRFAgg !(DS.AnnAggSelG v) | QRFAgg !(DS.AnnAggregateSelectG v)
| QRFConnection !(DS.ConnectionSelect v)
| QRFActionSelect !(DS.AnnSimpleSelG v) | QRFActionSelect !(DS.AnnSimpleSelG v)
| QRFActionExecuteObject !(DS.AnnSimpleSelG v) | QRFActionExecuteObject !(DS.AnnSimpleSelG v)
| QRFActionExecuteList !(DS.AnnSimpleSelG v) | QRFActionExecuteList !(DS.AnnSimpleSelG v)
@ -58,21 +62,28 @@ traverseQueryRootFldAST
-> QueryRootFldAST a -> QueryRootFldAST a
-> f (QueryRootFldAST b) -> f (QueryRootFldAST b)
traverseQueryRootFldAST f = \case traverseQueryRootFldAST f = \case
QRFPk s -> QRFPk <$> DS.traverseAnnSimpleSel f s QRFNode s -> QRFNode <$> DS.traverseAnnSimpleSelectect f s
QRFSimple s -> QRFSimple <$> DS.traverseAnnSimpleSel f s QRFPk s -> QRFPk <$> DS.traverseAnnSimpleSelect f s
QRFAgg s -> QRFAgg <$> DS.traverseAnnAggSel f s QRFSimple s -> QRFSimple <$> DS.traverseAnnSimpleSelect f s
QRFActionSelect s -> QRFActionSelect <$> DS.traverseAnnSimpleSel f s QRFAgg s -> QRFAgg <$> DS.traverseAnnAggregateSelect f s
QRFActionExecuteObject s -> QRFActionExecuteObject <$> DS.traverseAnnSimpleSel f s QRFActionSelect s -> QRFActionSelect <$> DS.traverseAnnSimpleSelect f s
QRFActionExecuteList s -> QRFActionExecuteList <$> DS.traverseAnnSimpleSel f s QRFActionExecuteObject s -> QRFActionExecuteObject <$> DS.traverseAnnSimpleSelect f s
QRFActionExecuteList s -> QRFActionExecuteList <$> DS.traverseAnnSimpleSelect f s
QRFConnection s -> QRFConnection <$> DS.traverseConnectionSelect f s
toPGQuery :: QueryRootFldResolved -> Q.Query toPGQuery :: QueryRootFldResolved -> Q.Query
toPGQuery = \case toPGQuery = \case
QRFPk s -> DS.selectQuerySQL DS.JASSingleObject s QRFNode s -> first (toQuery . DS.mkSQLSelect DS.JASSingleObject) $ RR.getRemoteJoins s
QRFSimple s -> DS.selectQuerySQL DS.JASMultipleRows s QRFPk s -> first (toQuery . DS.mkSQLSelect DS.JASSingleObject) $ RR.getRemoteJoins s
QRFAgg s -> DS.selectAggQuerySQL s QRFSimple s -> first (toQuery . DS.mkSQLSelect DS.JASMultipleRows) $ RR.getRemoteJoins s
QRFActionSelect s -> DS.selectQuerySQL DS.JASSingleObject s QRFAgg s -> first (toQuery . DS.mkAggregateSelect) $ RR.getRemoteJoinsAggregateSelect s
QRFActionExecuteObject s -> DS.selectQuerySQL DS.JASSingleObject s QRFActionSelect s -> first (toQuery . DS.mkSQLSelect DS.JASSingleObject) $ RR.getRemoteJoins s
QRFActionExecuteList s -> DS.selectQuerySQL DS.JASMultipleRows s QRFActionExecuteObject s -> first (toQuery . DS.mkSQLSelect DS.JASSingleObject) $ RR.getRemoteJoins s
QRFActionExecuteList s -> first (toQuery . DS.mkSQLSelect DS.JASMultipleRows) $ RR.getRemoteJoins s
QRFConnection s -> first (toQuery . DS.mkConnectionSelect) $ RR.getRemoteJoinsConnectionSelect s
where
toQuery :: ToSQL a => a -> Q.Query
toQuery = Q.fromBuilder . toSQL
validateHdrs validateHdrs
:: (Foldable t, QErrM m) => UserInfo -> t Text -> m () :: (Foldable t, QErrM m) => UserInfo -> t Text -> m ()
@ -101,6 +112,13 @@ queryFldToPGAST fld actionExecuter = do
opCtx <- getOpCtx $ V._fName fld opCtx <- getOpCtx $ V._fName fld
userInfo <- asks getter userInfo <- asks getter
case opCtx of case opCtx of
QCNodeSelect nodeSelectMap -> do
NodeIdData table pkeyColumnValues <- RS.resolveNodeId fld
case Map.lookup (GS.mkTableTy table) nodeSelectMap of
Nothing -> throwVE $ "table " <> table <<> " not found"
Just selOpCtx -> do
validateHdrs userInfo (_socHeaders selOpCtx)
QRFNode <$> RS.convertNodeSelect selOpCtx pkeyColumnValues fld
QCSelect ctx -> do QCSelect ctx -> do
validateHdrs userInfo (_socHeaders ctx) validateHdrs userInfo (_socHeaders ctx)
QRFSimple <$> RS.convertSelect ctx fld QRFSimple <$> RS.convertSelect ctx fld
@ -125,13 +143,15 @@ queryFldToPGAST fld actionExecuter = do
-- an SQL query, but in case of query actions it's converted into JSON -- an SQL query, but in case of query actions it's converted into JSON
-- and included in the action's webhook payload. -- and included in the action's webhook payload.
markNotReusable markNotReusable
let f = case jsonAggType of let jsonAggType = RA.mkJsonAggSelect $ _saecOutputType ctx
f = case jsonAggType of
DS.JASMultipleRows -> QRFActionExecuteList DS.JASMultipleRows -> QRFActionExecuteList
DS.JASSingleObject -> QRFActionExecuteObject DS.JASSingleObject -> QRFActionExecuteObject
f <$> actionExecuter (RA.resolveActionQuery fld ctx (userVars userInfo)) f <$> actionExecuter (RA.resolveActionQuery fld ctx (_uiSession userInfo))
where QCSelectConnection pk ctx ->
outputType = _saecOutputType ctx QRFConnection <$> RS.convertConnectionSelect pk ctx fld
jsonAggType = RA.mkJsonAggSelect outputType QCFuncConnection pk ctx ->
QRFConnection <$> RS.convertConnectionFuncQuery pk ctx fld
mutFldToTx mutFldToTx
:: ( HasVersion :: ( HasVersion
@ -187,3 +207,17 @@ getOpCtx f = do
opCtxMap <- asks getter opCtxMap <- asks getter
onNothing (Map.lookup f opCtxMap) $ throw500 $ onNothing (Map.lookup f opCtxMap) $ throw500 $
"lookup failed: opctx: " <> showName f "lookup failed: opctx: " <> showName f
toSQLFromItem :: S.Alias -> QueryRootFldResolved -> S.FromItem
toSQLFromItem alias = \case
QRFNode s -> fromSelect $ DS.mkSQLSelect DS.JASSingleObject s
QRFPk s -> fromSelect $ DS.mkSQLSelect DS.JASSingleObject s
QRFSimple s -> fromSelect $ DS.mkSQLSelect DS.JASMultipleRows s
QRFAgg s -> fromSelect $ DS.mkAggregateSelect s
QRFActionSelect s -> fromSelect $ DS.mkSQLSelect DS.JASSingleObject s
QRFActionExecuteObject s -> fromSelect $ DS.mkSQLSelect DS.JASSingleObject s
QRFActionExecuteList s -> fromSelect $ DS.mkSQLSelect DS.JASSingleObject s
QRFConnection s -> flip (S.FISelectWith (S.Lateral False)) alias
$ DS.mkConnectionSelect s
where
fromSelect = flip (S.FISelect (S.Lateral False)) alias

View File

@ -36,6 +36,16 @@ import qualified Network.Wreq as Wreq
import qualified Hasura.RQL.DML.Select as RS import qualified Hasura.RQL.DML.Select as RS
import qualified Control.Concurrent.Async as A
import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.TH as J
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Database.PG.Query as Q
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Execute.Prepare import Hasura.GraphQL.Execute.Prepare
import Hasura.GraphQL.Parser import Hasura.GraphQL.Parser
@ -48,9 +58,34 @@ import Hasura.RQL.Types
import Hasura.RQL.Types.Run import Hasura.RQL.Types.Run
import Hasura.Server.Utils (mkClientHeadersForward, mkSetCookieHeaders) import Hasura.Server.Utils (mkClientHeadersForward, mkSetCookieHeaders)
import Hasura.Server.Version (HasVersion) import Hasura.Server.Version (HasVersion)
import Hasura.Session
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value (PGScalarValue (..), toTxtValue) import Hasura.SQL.Value (PGScalarValue (..), toTxtValue)
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq as Wreq
-- import qualified Hasura.GraphQL.Resolve.Select as GRS
import qualified Hasura.RQL.DML.RemoteJoin as RJ
import qualified Hasura.RQL.DML.Select as RS
import Hasura.EncJSON
-- import Hasura.GraphQL.Resolve.Context
-- import Hasura.GraphQL.Resolve.InputValue
-- import Hasura.GraphQL.Resolve.Select (processTableSelectionSet)
-- import Hasura.GraphQL.Validate.SelectionSet
import Hasura.HTTP
import Hasura.RQL.DDL.Headers (makeHeadersFromConf, toHeadersConf)
import Hasura.RQL.DDL.Schema.Cache
import Hasura.RQL.DML.Select (asSingleRowJsonResp)
import Hasura.RQL.Types
import Hasura.RQL.Types.Run
import Hasura.Server.Utils (mkClientHeadersForward, mkSetCookieHeaders)
import Hasura.Server.Version (HasVersion)
import Hasura.Session import Hasura.Session
import Hasura.SQL.Types
import Hasura.SQL.Value (PGScalarValue (..), toTxtValue)
newtype ActionContext newtype ActionContext
= ActionContext {_acName :: ActionName} = ActionContext {_acName :: ActionName}
@ -136,10 +171,11 @@ resolveActionExecution
, MonadError QErr m , MonadError QErr m
, MonadIO m , MonadIO m
) )
=> AnnActionExecution UnpreparedValue => UserInfo
-> AnnActionExecution UnpreparedValue
-> ActionExecContext -> ActionExecContext
-> m (RespTx, HTTP.ResponseHeaders) -> m (RespTx, HTTP.ResponseHeaders)
resolveActionExecution annAction execContext = do resolveActionExecution userInfo annAction execContext = do
let actionContext = ActionContext actionName let actionContext = ActionContext actionName
handlerPayload = ActionWebhookPayload actionContext sessionVariables inputPayload handlerPayload = ActionWebhookPayload actionContext sessionVariables inputPayload
(webhookRes, respHeaders) <- callWebhook manager outputType outputFields reqHeaders confHeaders (webhookRes, respHeaders) <- callWebhook manager outputType outputFields reqHeaders confHeaders
@ -148,9 +184,17 @@ resolveActionExecution annAction execContext = do
toTxtValue $ WithScalarType PGJSONB $ PGValJSONB $ Q.JSONB $ J.toJSON webhookRes toTxtValue $ WithScalarType PGJSONB $ PGValJSONB $ Q.JSONB $ J.toJSON webhookRes
selectAstUnresolved = processOutputSelectionSet webhookResponseExpression selectAstUnresolved = processOutputSelectionSet webhookResponseExpression
outputType definitionList annFields stringifyNum outputType definitionList annFields stringifyNum
astResolved <- RS.traverseAnnSimpleSel (pure . unpreparedToTextSQL) selectAstUnresolved astResolved <- RS.traverseAnnSimpleSelect (pure . unpreparedToTextSQL) selectAstUnresolved
let jsonAggType = mkJsonAggSelect outputType let (astResolvedWithoutRemoteJoins,maybeRemoteJoins) = RJ.getRemoteJoins astResolved
return $ (,respHeaders) $ asSingleRowJsonResp (RS.selectQuerySQL jsonAggType astResolved) [] jsonAggType = mkJsonAggSelect outputType
return $ (,respHeaders) $
case maybeRemoteJoins of
Just remoteJoins ->
let query = Q.fromBuilder $ toSQL $
RS.mkSQLSelect jsonAggType astResolvedWithoutRemoteJoins
in RJ.executeQueryWithRemoteJoins manager reqHeaders userInfo query [] remoteJoins
Nothing ->
asSingleRowJsonResp (Q.fromBuilder $ toSQL $ RS.mkSQLSelect jsonAggType astResolved) []
where where
AnnActionExecution actionName outputType annFields inputPayload AnnActionExecution actionName outputType annFields inputPayload
outputFields definitionList resolvedWebhook confHeaders outputFields definitionList resolvedWebhook confHeaders
@ -177,10 +221,17 @@ restrictActionExecuter errMsg _ =
-- resolveActionQuery -- resolveActionQuery
-- :: ( HasVersion -- :: ( HasVersion
-- , MonadReusability m
-- , MonadError QErr m -- , MonadError QErr m
-- , MonadReader r m
-- , MonadIO m -- , MonadIO m
-- , Has FieldMap r
-- , Has OrdByCtx r
-- , Has SQLGenCtx r
-- ) -- )
-- => UserVars -- => Field
-- -> ActionExecutionContext
-- -> SessionVariables
-- -> HTTP.Manager -- -> HTTP.Manager
-- -> [HTTP.Header] -- -> [HTTP.Header]
-- -> m (RS.AnnSimpleSelG UnresolvedVal) -- -> m (RS.AnnSimpleSelG UnresolvedVal)
@ -192,9 +243,10 @@ restrictActionExecuter errMsg _ =
-- forwardClientHeaders resolvedWebhook handlerPayload -- forwardClientHeaders resolvedWebhook handlerPayload
-- let webhookResponseExpression = RS.AEInput $ UVSQL $ -- let webhookResponseExpression = RS.AEInput $ UVSQL $
-- toTxtValue $ WithScalarType PGJSONB $ PGValJSONB $ Q.JSONB $ J.toJSON webhookRes -- toTxtValue $ WithScalarType PGJSONB $ PGValJSONB $ Q.JSONB $ J.toJSON webhookRes
-- selSet <- asObjectSelectionSet $ _fSelSet field
-- selectAstUnresolved <- -- selectAstUnresolved <-
-- processOutputSelectionSet webhookResponseExpression outputType definitionList -- processOutputSelectionSet webhookResponseExpression outputType definitionList
-- (_fType field) $ _fSelSet field -- (_fType field) selSet
-- return selectAstUnresolved -- return selectAstUnresolved
-- where -- where
-- ActionExecutionContext actionName outputType outputFields definitionList resolvedWebhook confHeaders -- ActionExecutionContext actionName outputType outputFields definitionList resolvedWebhook confHeaders
@ -254,12 +306,12 @@ resolveAsyncActionQuery
-> RS.AnnSimpleSelG UnpreparedValue -> RS.AnnSimpleSelG UnpreparedValue
resolveAsyncActionQuery userInfo annAction = resolveAsyncActionQuery userInfo annAction =
let annotatedFields = asyncFields <&> second \case let annotatedFields = asyncFields <&> second \case
AsyncTypename t -> RS.FExp t AsyncTypename t -> RS.AFExpression t
AsyncOutput annFields -> AsyncOutput annFields ->
-- See Note [Resolving async action query/subscription] -- See Note [Resolving async action query/subscription]
let inputTableArgument = RS.AETableRow $ Just $ Iden "response_payload" let inputTableArgument = RS.AETableRow $ Just $ Iden "response_payload"
jsonAggSelect = mkJsonAggSelect outputType jsonAggSelect = mkJsonAggSelect outputType
in RS.FComputedField $ RS.CFSTable jsonAggSelect $ in RS.AFComputedField $ RS.CFSTable jsonAggSelect $
processOutputSelectionSet inputTableArgument outputType processOutputSelectionSet inputTableArgument outputType
definitionList annFields stringifyNumerics definitionList annFields stringifyNumerics
@ -268,20 +320,20 @@ resolveAsyncActionQuery userInfo annAction =
AsyncErrors -> mkAnnFldFromPGCol "errors" PGJSONB AsyncErrors -> mkAnnFldFromPGCol "errors" PGJSONB
tableFromExp = RS.FromTable actionLogTable tableFromExp = RS.FromTable actionLogTable
tableArguments = RS.noTableArgs tableArguments = RS.noSelectArgs
{ RS._taWhere = Just tableBoolExpression} { RS._saWhere = Just tableBoolExpression}
tablePermissions = RS.TablePerm annBoolExpTrue Nothing tablePermissions = RS.TablePerm annBoolExpTrue Nothing
in RS.AnnSelG annotatedFields tableFromExp tablePermissions in RS.AnnSelectG annotatedFields tableFromExp tablePermissions
tableArguments stringifyNumerics tableArguments stringifyNumerics
where where
AnnActionAsyncQuery actionName actionId outputType asyncFields definitionList stringifyNumerics = annAction AnnActionAsyncQuery actionName actionId outputType asyncFields definitionList stringifyNumerics = annAction
actionLogTable = QualifiedObject (SchemaName "hdb_catalog") (TableName "hdb_action_log") actionLogTable = QualifiedObject (SchemaName "hdb_catalog") (TableName "hdb_action_log")
-- TODO:- Avoid using PGColumnInfo -- TODO:- Avoid using PGColumnInfo
mkAnnFldFromPGCol col columnType = mkAnnFldFromPGCol column columnType =
flip RS.mkAnnColField Nothing $ flip RS.mkAnnColumnField Nothing $
PGColumnInfo (unsafePGCol col) (G.unsafeMkName col) 0 (PGColumnScalar columnType) True Nothing PGColumnInfo (unsafePGCol column) (G.unsafeMkName column) 0 (PGColumnScalar columnType) True Nothing
tableBoolExpression = tableBoolExpression =
let actionIdColumnInfo = PGColumnInfo (unsafePGCol "id") $$(G.litName "id") let actionIdColumnInfo = PGColumnInfo (unsafePGCol "id") $$(G.litName "id")
@ -510,12 +562,12 @@ processOutputSelectionSet
:: RS.ArgumentExp v :: RS.ArgumentExp v
-> GraphQLType -> GraphQLType
-> [(PGCol, PGScalarType)] -> [(PGCol, PGScalarType)]
-> RS.AnnFldsG v -> RS.AnnFieldsG v
-> Bool -> Bool
-> RS.AnnSimpleSelG v -> RS.AnnSimpleSelG v
processOutputSelectionSet tableRowInput actionOutputType definitionList processOutputSelectionSet tableRowInput actionOutputType definitionList
annotatedFields = annotatedFields =
RS.AnnSelG annotatedFields selectFrom RS.noTablePermissions RS.noTableArgs RS.AnnSelectG annotatedFields selectFrom RS.noTablePermissions RS.noSelectArgs
where where
jsonbToPostgresRecordFunction = jsonbToPostgresRecordFunction =
QualifiedObject "pg_catalog" $ FunctionName $ QualifiedObject "pg_catalog" $ FunctionName $

View File

@ -169,6 +169,10 @@ parseColExp nt n val = do
fmapAnnBoolExp partialSQLExpToUnresolvedVal permExp fmapAnnBoolExp partialSQLExpToUnresolvedVal permExp
RFComputedField _ -> throw500 RFComputedField _ -> throw500
"computed fields are not allowed in bool_exp" "computed fields are not allowed in bool_exp"
RFRemoteRelationship _ -> throw500
"remote relationships are not allowed in bool_exp"
RFNodeId _ _ -> throw500
"node id is not allowed in bool_exp"
parseBoolExp parseBoolExp
:: ( MonadReusability m :: ( MonadReusability m

View File

@ -23,7 +23,7 @@ module Hasura.GraphQL.Resolve.Context
, txtConverter , txtConverter
, withSelSet , traverseObjectSelectionSet
, fieldAsPath , fieldAsPath
, resolvePGCol , resolvePGCol
, module Hasura.GraphQL.Utils , module Hasura.GraphQL.Utils
@ -33,21 +33,21 @@ module Hasura.GraphQL.Resolve.Context
import Data.Has import Data.Has
import Hasura.Prelude import Hasura.Prelude
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.Resolve.Types import Hasura.GraphQL.Resolve.Types
import Hasura.GraphQL.Utils import Hasura.GraphQL.Utils
import Hasura.GraphQL.Validate.Field import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.DML.Internal (currentSession, sessVarFromCurrentSetting) import Hasura.RQL.DML.Internal (currentSession, sessVarFromCurrentSetting)
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
getFldInfo getFldInfo
:: (MonadError QErr m, MonadReader r m, Has FieldMap r) :: (MonadError QErr m, MonadReader r m, Has FieldMap r)
@ -65,9 +65,11 @@ getPGColInfo
getPGColInfo nt n = do getPGColInfo nt n = do
fldInfo <- getFldInfo nt n fldInfo <- getFldInfo nt n
case fldInfo of case fldInfo of
RFPGColumn pgColInfo -> return pgColInfo RFPGColumn pgColInfo -> return pgColInfo
RFRelationship _ -> throw500 $ mkErrMsg "relation" RFRelationship _ -> throw500 $ mkErrMsg "relation"
RFComputedField _ -> throw500 $ mkErrMsg "computed field" RFComputedField _ -> throw500 $ mkErrMsg "computed field"
RFRemoteRelationship _ -> throw500 $ mkErrMsg "remote relationship"
RFNodeId _ _ -> throw500 $ mkErrMsg "node id"
where where
mkErrMsg ty = mkErrMsg ty =
"found " <> ty <> " when expecting pgcolinfo for " "found " <> ty <> " when expecting pgcolinfo for "
@ -139,12 +141,6 @@ prepareColVal (WithScalarType scalarType colVal) = do
txtConverter :: Applicative f => AnnPGVal -> f S.SQLExp txtConverter :: Applicative f => AnnPGVal -> f S.SQLExp
txtConverter (AnnPGVal _ _ scalarValue) = pure $ toTxtValue scalarValue txtConverter (AnnPGVal _ _ scalarValue) = pure $ toTxtValue scalarValue
withSelSet :: (Monad m) => SelSet -> (Field -> m a) -> m [(Text, a)]
withSelSet selSet f =
forM (toList selSet) $ \fld -> do
res <- f fld
return (G.unName $ G.unAlias $ _fAlias fld, res)
fieldAsPath :: (MonadError QErr m) => Field -> m a -> m a fieldAsPath :: (MonadError QErr m) => Field -> m a -> m a
fieldAsPath = nameAsPath . _fName fieldAsPath = nameAsPath . _fName

View File

@ -8,34 +8,36 @@ import Data.Has
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.Prelude import Hasura.Prelude
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.TH as J import qualified Data.Aeson.TH as J
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as T import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Hasura.RQL.DML.Insert as RI import qualified Hasura.RQL.DML.Insert as RI
import qualified Hasura.RQL.DML.Returning as RR import qualified Hasura.RQL.DML.Returning as RR
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
import Hasura.GraphQL.Resolve.BoolExp import Hasura.GraphQL.Resolve.BoolExp
import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Resolve.InputValue
import Hasura.GraphQL.Resolve.Mutation import Hasura.GraphQL.Resolve.Mutation
import Hasura.GraphQL.Resolve.Select import Hasura.GraphQL.Resolve.Select
import Hasura.GraphQL.Validate.Field import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.DML.Insert (insertOrUpdateCheckExpr) import Hasura.RQL.DML.Insert (insertOrUpdateCheckExpr)
import Hasura.RQL.DML.Internal (convAnnBoolExpPartialSQL, convPartialSQLExp, import Hasura.RQL.DML.Internal (convAnnBoolExpPartialSQL, convPartialSQLExp,
dmlTxErrorHandler, sessVarFromCurrentSetting) sessVarFromCurrentSetting)
import Hasura.RQL.DML.Mutation import Hasura.RQL.DML.Mutation
import Hasura.RQL.GBoolExp (toSQLBoolExp) import Hasura.RQL.DML.RemoteJoin
import Hasura.RQL.GBoolExp (toSQLBoolExp)
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
@ -473,7 +475,8 @@ convertInsert
-> Field -- the mutation field -> Field -- the mutation field
-> m RespTx -> m RespTx
convertInsert role tn fld = prefixErrPath fld $ do convertInsert role tn fld = prefixErrPath fld $ do
mutOutputUnres <- RR.MOutMultirowFields <$> resolveMutationFields (_fType fld) (_fSelSet fld) selSet <- asObjectSelectionSet $ _fSelSet fld
mutOutputUnres <- RR.MOutMultirowFields <$> resolveMutationFields (_fType fld) selSet
mutOutputRes <- RR.traverseMutationOutput resolveValTxt mutOutputUnres mutOutputRes <- RR.traverseMutationOutput resolveValTxt mutOutputUnres
annVals <- withArg arguments "objects" asArray annVals <- withArg arguments "objects" asArray
-- if insert input objects is empty array then -- if insert input objects is empty array then
@ -508,7 +511,8 @@ convertInsertOne
-> Field -- the mutation field -> Field -- the mutation field
-> m RespTx -> m RespTx
convertInsertOne role qt field = prefixErrPath field $ do convertInsertOne role qt field = prefixErrPath field $ do
tableSelFields <- processTableSelectionSet (_fType field) $ _fSelSet field selSet <- asObjectSelectionSet $ _fSelSet field
tableSelFields <- processTableSelectionSet (_fType field) selSet
let mutationOutputUnresolved = RR.MOutSinglerowObject tableSelFields let mutationOutputUnresolved = RR.MOutSinglerowObject tableSelFields
mutationOutputResolved <- RR.traverseMutationOutput resolveValTxt mutationOutputUnresolved mutationOutputResolved <- RR.traverseMutationOutput resolveValTxt mutationOutputUnresolved
annInputObj <- withArg arguments "object" asObject annInputObj <- withArg arguments "object" asObject

View File

@ -6,17 +6,19 @@ module Hasura.GraphQL.Resolve.Introspect
import Data.Has import Data.Has
import Hasura.Prelude import Hasura.Prelude
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set import qualified Data.HashSet as Set
import qualified Data.Text as T import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G import qualified Hasura.SQL.Types as S
import qualified Hasura.SQL.Value as S
import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Resolve.InputValue
import Hasura.GraphQL.Validate.Context import Hasura.GraphQL.Validate.Context
import Hasura.GraphQL.Validate.Field
import Hasura.GraphQL.Validate.InputValue import Hasura.GraphQL.Validate.InputValue
import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.Types import Hasura.RQL.Types
@ -35,14 +37,15 @@ instance J.ToJSON TypeKind where
toJSON = J.toJSON . T.pack . drop 2 . show toJSON = J.toJSON . T.pack . drop 2 . show
withSubFields withSubFields
:: (Monad m) :: (MonadError QErr m)
=> SelSet => SelectionSet
-> (Field -> m J.Value) -> (Field -> m J.Value)
-> m J.Object -> m J.Object
withSubFields selSet fn = withSubFields selSet fn = do
fmap Map.fromList $ forM (toList selSet) $ \fld -> do objectSelectionSet <- asObjectSelectionSet selSet
val <- fn fld Map.fromList <$> traverseObjectSelectionSet objectSelectionSet fn
return (G.unName $ G.unAlias $ _fAlias fld, val) -- val <- fn fld
-- return (G.unName $ G.unAlias $ _fAlias fld, val)
namedTyToTxt :: G.NamedType -> Text namedTyToTxt :: G.NamedType -> Text
namedTyToTxt = G.unName . G.unNamedType namedTyToTxt = G.unName . G.unNamedType
@ -101,9 +104,9 @@ notBuiltinFld f =
getImplTypes :: (MonadReader t m, Has TypeMap t) => AsObjType -> m [ObjTyInfo] getImplTypes :: (MonadReader t m, Has TypeMap t) => AsObjType -> m [ObjTyInfo]
getImplTypes aot = do getImplTypes aot = do
tyInfo :: TypeMap <- asks getter tyInfo <- asks getter
return $ sortOn _otiName $ return $ sortOn _otiName $
Map.elems $ getPossibleObjTypes' tyInfo aot Map.elems $ getPossibleObjTypes tyInfo aot
-- 4.5.2.3 -- 4.5.2.3
unionR unionR
@ -139,19 +142,24 @@ ifaceR'
=> IFaceTyInfo => IFaceTyInfo
-> Field -> Field
-> m J.Object -> m J.Object
ifaceR' i@(IFaceTyInfo descM n flds) fld = ifaceR' ifaceTyInfo fld = do
dummyReadIncludeDeprecated fld
withSubFields (_fSelSet fld) $ \subFld -> withSubFields (_fSelSet fld) $ \subFld ->
case _fName subFld of case _fName subFld of
"__typename" -> retJT "__Type" "__typename" -> retJT "__Type"
"kind" -> retJ TKINTERFACE "kind" -> retJ TKINTERFACE
"name" -> retJ $ namedTyToTxt n "name" -> retJ $ namedTyToTxt name
"description" -> retJ $ fmap G.unDescription descM "description" -> retJ $ fmap G.unDescription maybeDescription
"fields" -> fmap J.toJSON $ mapM (`fieldR` subFld) $ "fields" -> fmap J.toJSON $ mapM (`fieldR` subFld) $
sortOn _fiName $ sortOn _fiName $
filter notBuiltinFld $ Map.elems flds filter notBuiltinFld $ Map.elems fields
"possibleTypes" -> fmap J.toJSON $ mapM (`objectTypeR` subFld) "possibleTypes" -> fmap J.toJSON $ mapM (`objectTypeR` subFld)
=<< getImplTypes (AOTIFace i) =<< getImplTypes (AOTIFace ifaceTyInfo)
_ -> return J.Null _ -> return J.Null
where
maybeDescription = _ifDesc ifaceTyInfo
name = _ifName ifaceTyInfo
fields = _ifFields ifaceTyInfo
-- 4.5.2.5 -- 4.5.2.5
enumTypeR enumTypeR
@ -161,14 +169,64 @@ enumTypeR
-> m J.Object -> m J.Object
enumTypeR (EnumTyInfo descM n vals _) fld = enumTypeR (EnumTyInfo descM n vals _) fld =
withSubFields (_fSelSet fld) $ \subFld -> withSubFields (_fSelSet fld) $ \subFld ->
case _fName subFld of case _fName subFld of
"__typename" -> retJT "__Type" "__typename" -> retJT "__Type"
"kind" -> retJ TKENUM "kind" -> retJ TKENUM
"name" -> retJ $ namedTyToTxt n "name" -> retJ $ namedTyToTxt n
"description" -> retJ $ fmap G.unDescription descM "description" -> retJ $ fmap G.unDescription descM
"enumValues" -> fmap J.toJSON $ mapM (enumValueR subFld) $ "enumValues" -> do
sortOn _eviVal $ Map.elems (normalizeEnumValues vals) includeDeprecated <- readIncludeDeprecated subFld
_ -> return J.Null fmap J.toJSON $
mapM (enumValueR subFld) $
filter (\val -> includeDeprecated || not (_eviIsDeprecated val)) $
sortOn _eviVal $
Map.elems (normalizeEnumValues vals)
_ -> return J.Null
readIncludeDeprecated
:: ( Monad m, MonadReusability m, MonadError QErr m )
=> Field
-> m Bool
readIncludeDeprecated subFld = do
let argM = Map.lookup "includeDeprecated" (_fArguments subFld)
case argM of
Nothing -> pure False
Just arg -> asScalarVal arg S.PGBoolean >>= \case
S.PGValBoolean b -> pure b
_ -> throw500 "unexpected non-Boolean argument for includeDeprecated"
{- Note [Reusability of introspection queries with variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Introspection queries can have variables, too, in particular to influence one of
two arguments: the @name@ argument of the @__type@ field, and the
@includeDeprecated@ argument of the @fields@ and @enumValues@ fields. The
current code does not cache all introspection queries with variables correctly.
As a workaround to this, whenever a variable is passed to an @includeDeprecated@
argument, we mark the query as unreusable. This is the purpose of
'dummyReadIncludeDeprecated'.
Now @fields@ and @enumValues@ are intended to be used when introspecting,
respectively [object and interface types] and enum types. However, it does not
suffice to only call 'dummyReadIncludeDeprecated' for such types, since @fields@
and @enumValues@ are valid GraphQL fields regardless of what type we are looking
at. So precisely because @__Type@ is _thought of_ as a union, but _not
actually_ a union, we need to call 'dummyReadIncludeDeprecated' in all cases.
See also issue #4547.
-}
dummyReadIncludeDeprecated
:: ( Monad m, MonadReusability m, MonadError QErr m )
=> Field
-> m ()
dummyReadIncludeDeprecated fld = do
selSet <- unAliasedFields . unObjectSelectionSet
<$> asObjectSelectionSet (_fSelSet fld)
forM_ (toList selSet) $ \subFld ->
case _fName subFld of
"fields" -> readIncludeDeprecated subFld
"enumValues" -> readIncludeDeprecated subFld
_ -> return False
-- 4.5.2.6 -- 4.5.2.6
inputObjR inputObjR
@ -276,7 +334,7 @@ inputValueR fld (InpValInfo descM n defM ty) =
-- 4.5.5 -- 4.5.5
enumValueR enumValueR
:: (Monad m) :: (MonadError QErr m)
=> Field -> EnumValInfo -> m J.Object => Field -> EnumValInfo -> m J.Object
enumValueR fld (EnumValInfo descM enumVal isDeprecated) = enumValueR fld (EnumValInfo descM enumVal isDeprecated) =
withSubFields (_fSelSet fld) $ \subFld -> withSubFields (_fSelSet fld) $ \subFld ->

View File

@ -33,7 +33,7 @@ import Hasura.GraphQL.Resolve.BoolExp
import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Resolve.InputValue
import Hasura.GraphQL.Resolve.Select (processTableSelectionSet) import Hasura.GraphQL.Resolve.Select (processTableSelectionSet)
import Hasura.GraphQL.Validate.Field import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.DML.Internal (currentSession, sessVarFromCurrentSetting) import Hasura.RQL.DML.Internal (currentSession, sessVarFromCurrentSetting)
import Hasura.RQL.Types import Hasura.RQL.Types
@ -44,15 +44,16 @@ resolveMutationFields
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r , Has OrdByCtx r, Has SQLGenCtx r
) )
=> G.NamedType -> SelSet -> m (RR.MutFldsG UnresolvedVal) => G.NamedType -> ObjectSelectionSet -> m (RR.MutFldsG UnresolvedVal)
resolveMutationFields ty selSet = fmap (map (first FieldName)) $ resolveMutationFields ty selSet = fmap (map (first FieldName)) $
withSelSet selSet $ \fld -> case _fName fld of traverseObjectSelectionSet selSet $ \fld -> case _fName fld of
"__typename" -> return $ RR.MExp $ G.unName $ G.unNamedType ty "__typename" -> return $ RR.MExp $ G.unName $ G.unNamedType ty
"affected_rows" -> return RR.MCount "affected_rows" -> return RR.MCount
"returning" -> do "returning" -> do
annFlds <- processTableSelectionSet (_fType fld) $ _fSelSet fld annFlds <- asObjectSelectionSet (_fSelSet fld)
>>= processTableSelectionSet (_fType fld)
annFldsResolved <- traverse annFldsResolved <- traverse
(traverse (RS.traverseAnnFld convertPGValueToTextValue)) annFlds (traverse (RS.traverseAnnField convertPGValueToTextValue)) annFlds
return $ RR.MRet annFldsResolved return $ RR.MRet annFldsResolved
G.Name t -> throw500 $ "unexpected field in mutation resp : " <> t G.Name t -> throw500 $ "unexpected field in mutation resp : " <> t
where where
@ -321,8 +322,9 @@ mutationFieldsResolver
, Has OrdByCtx r, Has SQLGenCtx r , Has OrdByCtx r, Has SQLGenCtx r
) )
=> Field -> m (RR.MutationOutputG UnresolvedVal) => Field -> m (RR.MutationOutputG UnresolvedVal)
mutationFieldsResolver field = mutationFieldsResolver field = do
RR.MOutMultirowFields <$> resolveMutationFields (_fType field) (_fSelSet field) asObjectSelectionSet (_fSelSet field) >>= \selSet ->
RR.MOutMultirowFields <$> resolveMutationFields (_fType field) selSet
tableSelectionAsMutationOutput tableSelectionAsMutationOutput
:: ( MonadReusability m, MonadError QErr m :: ( MonadReusability m, MonadError QErr m
@ -331,7 +333,8 @@ tableSelectionAsMutationOutput
) )
=> Field -> m (RR.MutationOutputG UnresolvedVal) => Field -> m (RR.MutationOutputG UnresolvedVal)
tableSelectionAsMutationOutput field = tableSelectionAsMutationOutput field =
RR.MOutSinglerowObject <$> processTableSelectionSet (_fType field) (_fSelSet field) asObjectSelectionSet (_fSelSet field) >>= \selSet ->
RR.MOutSinglerowObject <$> processTableSelectionSet (_fType field) selSet
-- | build mutation response for empty objects -- | build mutation response for empty objects
buildEmptyMutResp :: RR.MutationOutput -> EncJSON buildEmptyMutResp :: RR.MutationOutput -> EncJSON

View File

@ -1,37 +1,47 @@
module Hasura.GraphQL.Resolve.Select module Hasura.GraphQL.Resolve.Select
( convertSelect ( convertSelect
, convertConnectionSelect
, convertConnectionFuncQuery
, convertSelectByPKey , convertSelectByPKey
, convertAggSelect , convertAggSelect
, convertFuncQuerySimple , convertFuncQuerySimple
, convertFuncQueryAgg , convertFuncQueryAgg
, parseColumns , parseColumns
, processTableSelectionSet , processTableSelectionSet
, resolveNodeId
, convertNodeSelect
, AnnSimpleSelect , AnnSimpleSelect
) where ) where
import Control.Lens ((^?), _2) import Control.Lens (to, (^..), (^?), _2)
import Data.Has import Data.Has
import Data.Parser.JSONPath import Data.Parser.JSONPath
import Hasura.Prelude import Hasura.Prelude
import qualified Data.HashMap.Strict as Map import qualified Data.Aeson as J
import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Data.Aeson.Internal as J
import qualified Data.List.NonEmpty as NE import qualified Data.ByteString.Lazy as BL
import qualified Data.Sequence as Seq import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Language.GraphQL.Draft.Syntax as G import qualified Data.List.NonEmpty as NE
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Hasura.RQL.DML.Select as RS import qualified Hasura.RQL.DML.Select as RS
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
import Hasura.GraphQL.Resolve.BoolExp import Hasura.GraphQL.Resolve.BoolExp
import Hasura.GraphQL.Resolve.Context import Hasura.GraphQL.Resolve.Context
import Hasura.GraphQL.Resolve.InputValue import Hasura.GraphQL.Resolve.InputValue
import Hasura.GraphQL.Schema (isAggFld) import Hasura.GraphQL.Schema (isAggregateField)
import Hasura.GraphQL.Validate.Field import Hasura.GraphQL.Schema.Common (mkTableTy)
import Hasura.GraphQL.Validate
import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.DML.Internal (onlyPositiveInt) import Hasura.RQL.DML.Internal (onlyPositiveInt)
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Utils
import Hasura.SQL.Types import Hasura.SQL.Types
import Hasura.SQL.Value import Hasura.SQL.Value
@ -45,27 +55,29 @@ jsonPathToColExp t = case parseJSONPath t of
elToColExp (Index i) = S.SELit $ T.pack (show i) elToColExp (Index i) = S.SELit $ T.pack (show i)
argsToColOp :: (MonadReusability m, MonadError QErr m) => ArgsMap -> m (Maybe RS.ColOp) argsToColumnOp :: (MonadReusability m, MonadError QErr m) => ArgsMap -> m (Maybe RS.ColumnOp)
argsToColOp args = maybe (return Nothing) toOp $ Map.lookup "path" args argsToColumnOp args = case Map.lookup "path" args of
where Nothing -> return Nothing
toJsonPathExp = fmap (RS.ColOp S.jsonbPathOp) . jsonPathToColExp Just txt -> do
toOp v = asPGColTextM v >>= traverse toJsonPathExp mColTxt <- asPGColTextM txt
mColExps <- maybe (return Nothing) jsonPathToColExp mColTxt
pure $ RS.ColumnOp S.jsonbPathOp <$> mColExps
type AnnFlds = RS.AnnFldsG UnresolvedVal type AnnFields = RS.AnnFieldsG UnresolvedVal
resolveComputedField resolveComputedField
:: ( MonadReusability m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r, MonadError QErr m , Has OrdByCtx r, Has SQLGenCtx r, MonadError QErr m
) )
=> ComputedField -> Field -> m (RS.ComputedFieldSel UnresolvedVal) => ComputedField -> Field -> m (RS.ComputedFieldSelect UnresolvedVal)
resolveComputedField computedField fld = fieldAsPath fld $ do resolveComputedField computedField fld = fieldAsPath fld $ do
funcArgs <- parseFunctionArgs argSeq argFn $ Map.lookup "args" $ _fArguments fld funcArgs <- parseFunctionArgs argSeq argFn $ Map.lookup "args" $ _fArguments fld
let argsWithTableArgument = withTableArgument funcArgs let argsWithTableArgument = withTableArgument funcArgs
case fieldType of case fieldType of
CFTScalar scalarTy -> do CFTScalar scalarTy -> do
colOpM <- argsToColOp $ _fArguments fld colOpM <- argsToColumnOp $ _fArguments fld
pure $ RS.CFSScalar $ pure $ RS.CFSScalar $
RS.ComputedFieldScalarSel qf argsWithTableArgument scalarTy colOpM RS.ComputedFieldScalarSelectect qf argsWithTableArgument scalarTy colOpM
CFTTable (ComputedFieldTable _ cols permFilter permLimit) -> do CFTTable (ComputedFieldTable _ cols permFilter permLimit) -> do
let functionFrom = RS.FromFunction qf argsWithTableArgument Nothing let functionFrom = RS.FromFunction qf argsWithTableArgument Nothing
RS.CFSTable RS.JASMultipleRows <$> fromField functionFrom cols permFilter permLimit fld RS.CFSTable RS.JASMultipleRows <$> fromField functionFrom cols permFilter permLimit fld
@ -86,77 +98,142 @@ processTableSelectionSet
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r , Has OrdByCtx r, Has SQLGenCtx r
) )
=> G.NamedType -> SelSet -> m AnnFlds => G.NamedType -> ObjectSelectionSet -> m AnnFields
processTableSelectionSet fldTy flds = processTableSelectionSet fldTy flds =
forM (toList flds) $ \fld -> do fmap (map (\(a, b) -> (FieldName a, b))) $ traverseObjectSelectionSet flds $ \fld -> do
let fldName = _fName fld let fldName = _fName fld
let rqlFldName = FieldName $ G.unName $ G.unAlias $ _fAlias fld case fldName of
(rqlFldName,) <$> case fldName of "__typename" -> return $ RS.AFExpression $ G.unName $ G.unNamedType fldTy
"__typename" -> return $ RS.FExp $ G.unName $ G.unNamedType fldTy
_ -> do _ -> do
fldInfo <- getFldInfo fldTy fldName fldInfo <- getFldInfo fldTy fldName
case fldInfo of case fldInfo of
RFNodeId tn pkeys -> pure $ RS.AFNodeId tn pkeys
RFPGColumn colInfo -> RFPGColumn colInfo ->
RS.mkAnnColField colInfo <$> argsToColOp (_fArguments fld) RS.mkAnnColumnField colInfo <$> argsToColumnOp (_fArguments fld)
RFComputedField computedField -> RFComputedField computedField ->
RS.FComputedField <$> resolveComputedField computedField fld RS.AFComputedField <$> resolveComputedField computedField fld
RFRelationship (RelationshipField relInfo isAgg colGNameMap tableFilter tableLimit) -> do RFRelationship (RelationshipField relInfo fieldKind colGNameMap tableFilter tableLimit) -> do
let relTN = riRTable relInfo let relTN = riRTable relInfo
colMapping = riMapping relInfo colMapping = riMapping relInfo
rn = riName relInfo rn = riName relInfo
if isAgg then do case fieldKind of
aggSel <- fromAggField (RS.FromTable relTN) colGNameMap tableFilter tableLimit fld RFKSimple -> do
return $ RS.FArr $ RS.ASAgg $ RS.AnnRelG rn colMapping aggSel annSel <- fromField (RS.FromTable relTN) colGNameMap tableFilter tableLimit fld
else do let annRel = RS.AnnRelationSelectG rn colMapping annSel
annSel <- fromField (RS.FromTable relTN) colGNameMap tableFilter tableLimit fld pure $ case riType relInfo of
let annRel = RS.AnnRelG rn colMapping annSel ObjRel -> RS.AFObjectRelation annRel
return $ case riType relInfo of ArrRel -> RS.AFArrayRelation $ RS.ASSimple annRel
ObjRel -> RS.FObj annRel RFKAggregate -> do
ArrRel -> RS.FArr $ RS.ASSimple annRel aggSel <- fromAggField (RS.FromTable relTN) colGNameMap tableFilter tableLimit fld
pure $ RS.AFArrayRelation $ RS.ASAggregate $ RS.AnnRelationSelectG rn colMapping aggSel
RFKConnection pkCols -> do
connSel <- fromConnectionField (RS.FromTable relTN) pkCols tableFilter tableLimit fld
pure $ RS.AFArrayRelation $ RS.ASConnection $ RS.AnnRelationSelectG rn colMapping connSel
type TableAggFlds = RS.TableAggFldsG UnresolvedVal RFRemoteRelationship info ->
pure $ RS.AFRemote $ RS.RemoteSelect
(unValidateArgsMap $ _fArguments fld) -- Unvalidate the input arguments
(unValidateSelectionSet $ _fSelSet fld) -- Unvalidate the selection fields
(_rfiHasuraFields info)
(_rfiRemoteFields info)
(_rfiRemoteSchema info)
type TableAggregateFields = RS.TableAggregateFieldsG UnresolvedVal
fromAggSelSet fromAggSelSet
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r , Has OrdByCtx r, Has SQLGenCtx r
) )
=> PGColGNameMap -> G.NamedType -> SelSet -> m TableAggFlds => PGColGNameMap -> G.NamedType -> ObjectSelectionSet -> m TableAggregateFields
fromAggSelSet colGNameMap fldTy selSet = fmap toFields $ fromAggSelSet colGNameMap fldTy selSet = fmap toFields $
withSelSet selSet $ \f -> do traverseObjectSelectionSet selSet $ \Field{..} ->
let fTy = _fType f case _fName of
fSelSet = _fSelSet f
case _fName f of
"__typename" -> return $ RS.TAFExp $ G.unName $ G.unNamedType fldTy "__typename" -> return $ RS.TAFExp $ G.unName $ G.unNamedType fldTy
"aggregate" -> RS.TAFAgg <$> convertAggFld colGNameMap fTy fSelSet "aggregate" -> do
"nodes" -> RS.TAFNodes <$> processTableSelectionSet fTy fSelSet objSelSet <- asObjectSelectionSet _fSelSet
RS.TAFAgg <$> convertAggregateField colGNameMap _fType objSelSet
"nodes" -> do
objSelSet <- asObjectSelectionSet _fSelSet
RS.TAFNodes <$> processTableSelectionSet _fType objSelSet
G.Name t -> throw500 $ "unexpected field in _agg node: " <> t G.Name t -> throw500 $ "unexpected field in _agg node: " <> t
type TableArgs = RS.TableArgsG UnresolvedVal fromConnectionSelSet
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r
)
=> G.NamedType -> ObjectSelectionSet -> m (RS.ConnectionFields UnresolvedVal)
fromConnectionSelSet fldTy selSet = fmap toFields $
traverseObjectSelectionSet selSet $ \Field{..} ->
case _fName of
"__typename" -> return $ RS.ConnectionTypename $ G.unName $ G.unNamedType fldTy
"pageInfo" -> do
fSelSet <- asObjectSelectionSet _fSelSet
RS.ConnectionPageInfo <$> parsePageInfoSelectionSet _fType fSelSet
"edges" -> do
fSelSet <- asObjectSelectionSet _fSelSet
RS.ConnectionEdges <$> parseEdgeSelectionSet _fType fSelSet
-- "aggregate" -> RS.TAFAgg <$> convertAggregateField colGNameMap fTy fSelSet
-- "nodes" -> RS.TAFNodes <$> processTableSelectionSet fTy fSelSet
G.Name t -> throw500 $ "unexpected field in _connection node: " <> t
parseTableArgs parseEdgeSelectionSet
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r
)
=> G.NamedType -> ObjectSelectionSet -> m (RS.EdgeFields UnresolvedVal)
parseEdgeSelectionSet fldTy selSet = fmap toFields $
traverseObjectSelectionSet selSet $ \f -> do
let fTy = _fType f
case _fName f of
"__typename" -> pure $ RS.EdgeTypename $ G.unName $ G.unNamedType fldTy
"cursor" -> pure RS.EdgeCursor
"node" -> do
fSelSet <- asObjectSelectionSet $ _fSelSet f
RS.EdgeNode <$> processTableSelectionSet fTy fSelSet
G.Name t -> throw500 $ "unexpected field in Edge node: " <> t
parsePageInfoSelectionSet
:: ( MonadReusability m, MonadError QErr m)
=> G.NamedType -> ObjectSelectionSet -> m RS.PageInfoFields
parsePageInfoSelectionSet fldTy selSet =
fmap toFields $ traverseObjectSelectionSet selSet $ \f ->
case _fName f of
"__typename" -> pure $ RS.PageInfoTypename $ G.unName $ G.unNamedType fldTy
"hasNextPage" -> pure RS.PageInfoHasNextPage
"hasPreviousPage" -> pure RS.PageInfoHasPreviousPage
"startCursor" -> pure RS.PageInfoStartCursor
"endCursor" -> pure RS.PageInfoEndCursor
-- "aggregate" -> RS.TAFAgg <$> convertAggregateField colGNameMap fTy fSelSet
-- "nodes" -> RS.TAFNodes <$> processTableSelectionSet fTy fSelSet
G.Name t -> throw500 $ "unexpected field in PageInfo node: " <> t
type SelectArgs = RS.SelectArgsG UnresolvedVal
parseSelectArgs
:: ( MonadReusability m, MonadError QErr m, MonadReader r m :: ( MonadReusability m, MonadError QErr m, MonadReader r m
, Has FieldMap r, Has OrdByCtx r , Has FieldMap r, Has OrdByCtx r
) )
=> PGColGNameMap -> ArgsMap -> m TableArgs => PGColGNameMap -> ArgsMap -> m SelectArgs
parseTableArgs colGNameMap args = do parseSelectArgs colGNameMap args = do
whereExpM <- withArgM args "where" parseBoolExp whereExpM <- withArgM args "where" parseBoolExp
ordByExpML <- withArgM args "order_by" parseOrderBy ordByExpML <- withArgM args "order_by" parseOrderBy
let ordByExpM = NE.nonEmpty =<< ordByExpML let ordByExpM = NE.nonEmpty =<< ordByExpML
limitExpM <- withArgM args "limit" parseLimit limitExpM <- withArgM args "limit" $
parseNonNegativeInt "expecting Integer value for \"limit\""
offsetExpM <- withArgM args "offset" $ asPGColumnValue >=> openOpaqueValue >=> txtConverter offsetExpM <- withArgM args "offset" $ asPGColumnValue >=> openOpaqueValue >=> txtConverter
distOnColsML <- withArgM args "distinct_on" $ parseColumns colGNameMap distOnColsML <- withArgM args "distinct_on" $ parseColumns colGNameMap
let distOnColsM = NE.nonEmpty =<< distOnColsML let distOnColsM = NE.nonEmpty =<< distOnColsML
mapM_ (validateDistOn ordByExpM) distOnColsM mapM_ (validateDistOn ordByExpM) distOnColsM
return $ RS.TableArgs whereExpM ordByExpM limitExpM offsetExpM distOnColsM return $ RS.SelectArgs whereExpM ordByExpM limitExpM offsetExpM distOnColsM
where where
validateDistOn Nothing _ = return () validateDistOn Nothing _ = return ()
validateDistOn (Just ordBys) cols = withPathK "args" $ do validateDistOn (Just ordBys) cols = withPathK "args" $ do
let colsLen = length cols let colsLen = length cols
initOrdBys = take colsLen $ toList ordBys initOrdBys = take colsLen $ toList ordBys
initOrdByCols = flip mapMaybe initOrdBys $ \ob -> initOrdByCols = flip mapMaybe initOrdBys $ \ob ->
case obiColumn ob of case obiColumn ob of
RS.AOCPG pgCol -> Just pgCol RS.AOCColumn pgCol -> Just $ pgiColumn pgCol
_ -> Nothing _ -> Nothing
isValid = (colsLen == length initOrdByCols) isValid = (colsLen == length initOrdByCols)
&& all (`elem` initOrdByCols) (toList cols) && all (`elem` initOrdByCols) (toList cols)
@ -175,12 +252,13 @@ fromField
-> Maybe Int -> Maybe Int
-> Field -> m AnnSimpleSelect -> Field -> m AnnSimpleSelect
fromField selFrom colGNameMap permFilter permLimitM fld = fieldAsPath fld $ do fromField selFrom colGNameMap permFilter permLimitM fld = fieldAsPath fld $ do
tableArgs <- parseTableArgs colGNameMap args tableArgs <- parseSelectArgs colGNameMap args
annFlds <- processTableSelectionSet (_fType fld) $ _fSelSet fld selSet <- asObjectSelectionSet $ _fSelSet fld
annFlds <- processTableSelectionSet (_fType fld) selSet
let unresolvedPermFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter let unresolvedPermFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter
let tabPerm = RS.TablePerm unresolvedPermFltr permLimitM let tabPerm = RS.TablePerm unresolvedPermFltr permLimitM
strfyNum <- stringifyNum <$> asks getter strfyNum <- stringifyNum <$> asks getter
return $ RS.AnnSelG annFlds selFrom tabPerm tableArgs strfyNum return $ RS.AnnSelectG annFlds selFrom tabPerm tableArgs strfyNum
where where
args = _fArguments fld args = _fArguments fld
@ -201,7 +279,8 @@ parseOrderBy
, MonadReader r m , MonadReader r m
, Has OrdByCtx r , Has OrdByCtx r
) )
=> AnnInpVal -> m [RS.AnnOrderByItemG UnresolvedVal] => AnnInpVal
-> m [RS.AnnOrderByItemG UnresolvedVal]
parseOrderBy = fmap concat . withArray f parseOrderBy = fmap concat . withArray f
where where
f _ = mapM (withObject (getAnnObItems id)) f _ = mapM (withObject (getAnnObItems id))
@ -212,7 +291,7 @@ getAnnObItems
, MonadReader r m , MonadReader r m
, Has OrdByCtx r , Has OrdByCtx r
) )
=> (RS.AnnObColG UnresolvedVal -> RS.AnnObColG UnresolvedVal) => (RS.AnnOrderByElement UnresolvedVal -> RS.AnnOrderByElement UnresolvedVal)
-> G.NamedType -> G.NamedType
-> AnnGObject -> AnnGObject
-> m [RS.AnnOrderByItemG UnresolvedVal] -> m [RS.AnnOrderByItemG UnresolvedVal]
@ -224,7 +303,7 @@ getAnnObItems f nt obj = do
<> showNamedTy nt <> " map" <> showNamedTy nt <> " map"
case ordByItem of case ordByItem of
OBIPGCol ci -> do OBIPGCol ci -> do
let aobCol = f $ RS.AOCPG $ pgiColumn ci let aobCol = f $ RS.AOCColumn ci
(_, enumValM) <- asEnumValM v (_, enumValM) <- asEnumValM v
ordByItemM <- forM enumValM $ \enumVal -> do ordByItemM <- forM enumValM $ \enumVal -> do
(ordTy, nullsOrd) <- parseOrderByEnum enumVal (ordTy, nullsOrd) <- parseOrderByEnum enumVal
@ -233,13 +312,13 @@ getAnnObItems f nt obj = do
OBIRel ri fltr -> do OBIRel ri fltr -> do
let unresolvedFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal fltr let unresolvedFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal fltr
let annObColFn = f . RS.AOCObj ri unresolvedFltr let annObColFn = f . RS.AOCObjectRelation ri unresolvedFltr
flip withObjectM v $ \nameTy objM -> flip withObjectM v $ \nameTy objM ->
maybe (pure []) (getAnnObItems annObColFn nameTy) objM maybe (pure []) (getAnnObItems annObColFn nameTy) objM
OBIAgg ri relColGNameMap fltr -> do OBIAgg ri relColGNameMap fltr -> do
let unresolvedFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal fltr let unresolvedFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal fltr
let aobColFn = f . RS.AOCAgg ri unresolvedFltr let aobColFn = f . RS.AOCArrayAggregation ri unresolvedFltr
flip withObjectM v $ \_ objM -> flip withObjectM v $ \_ objM ->
maybe (pure []) (parseAggOrdBy relColGNameMap aobColFn) objM maybe (pure []) (parseAggOrdBy relColGNameMap aobColFn) objM
@ -250,7 +329,7 @@ mkOrdByItemG ordTy aobCol nullsOrd =
parseAggOrdBy parseAggOrdBy
:: (MonadReusability m, MonadError QErr m) :: (MonadReusability m, MonadError QErr m)
=> PGColGNameMap => PGColGNameMap
-> (RS.AnnAggOrdBy -> RS.AnnObColG UnresolvedVal) -> (RS.AnnAggregateOrderBy -> RS.AnnOrderByElement UnresolvedVal)
-> AnnGObject -> AnnGObject
-> m [RS.AnnOrderByItemG UnresolvedVal] -> m [RS.AnnOrderByItemG UnresolvedVal]
parseAggOrdBy colGNameMap f annObj = parseAggOrdBy colGNameMap f annObj =
@ -263,14 +342,14 @@ parseAggOrdBy colGNameMap f annObj =
return $ mkOrdByItemG ordTy (f RS.AAOCount) nullsOrd return $ mkOrdByItemG ordTy (f RS.AAOCount) nullsOrd
return $ maybe [] pure ordByItemM return $ maybe [] pure ordByItemM
G.Name opT -> G.Name opText ->
flip withObject obVal $ \_ opObObj -> fmap catMaybes $ flip withObject obVal $ \_ opObObj -> fmap catMaybes $
forM (OMap.toList opObObj) $ \(colName, eVal) -> do forM (OMap.toList opObObj) $ \(colName, eVal) -> do
(_, enumValM) <- asEnumValM eVal (_, enumValM) <- asEnumValM eVal
forM enumValM $ \enumVal -> do forM enumValM $ \enumVal -> do
(ordTy, nullsOrd) <- parseOrderByEnum enumVal (ordTy, nullsOrd) <- parseOrderByEnum enumVal
col <- pgiColumn <$> resolvePGCol colGNameMap colName col <- resolvePGCol colGNameMap colName
let aobCol = f $ RS.AAOOp opT col let aobCol = f $ RS.AAOOp opText col
return $ mkOrdByItemG ordTy aobCol nullsOrd return $ mkOrdByItemG ordTy aobCol nullsOrd
parseOrderByEnum parseOrderByEnum
@ -287,15 +366,14 @@ parseOrderByEnum = \case
G.EnumValue v -> throw500 $ G.EnumValue v -> throw500 $
"enum value " <> showName v <> " not found in type order_by" "enum value " <> showName v <> " not found in type order_by"
parseLimit :: (MonadReusability m, MonadError QErr m) => AnnInpVal -> m Int parseNonNegativeInt
parseLimit v = do :: (MonadReusability m, MonadError QErr m) => Text -> AnnInpVal -> m Int
parseNonNegativeInt errMsg v = do
pgColVal <- openOpaqueValue =<< asPGColumnValue v pgColVal <- openOpaqueValue =<< asPGColumnValue v
limit <- maybe noIntErr return . pgColValueToInt . pstValue $ _apvValue pgColVal limit <- maybe (throwVE errMsg) return . pgColValueToInt . pstValue $ _apvValue pgColVal
-- validate int value -- validate int value
onlyPositiveInt limit onlyPositiveInt limit
return limit return limit
where
noIntErr = throwVE "expecting Integer value for \"limit\""
type AnnSimpleSel = RS.AnnSimpleSelG UnresolvedVal type AnnSimpleSel = RS.AnnSimpleSelG UnresolvedVal
@ -311,14 +389,15 @@ fromFieldByPKey
-> AnnBoolExpPartialSQL -> Field -> m AnnSimpleSel -> AnnBoolExpPartialSQL -> Field -> m AnnSimpleSel
fromFieldByPKey tn colArgMap permFilter fld = fieldAsPath fld $ do fromFieldByPKey tn colArgMap permFilter fld = fieldAsPath fld $ do
boolExp <- pgColValToBoolExp colArgMap $ _fArguments fld boolExp <- pgColValToBoolExp colArgMap $ _fArguments fld
annFlds <- processTableSelectionSet fldTy $ _fSelSet fld selSet <- asObjectSelectionSet $ _fSelSet fld
annFlds <- processTableSelectionSet fldTy selSet
let tabFrom = RS.FromTable tn let tabFrom = RS.FromTable tn
unresolvedPermFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal unresolvedPermFltr = fmapAnnBoolExp partialSQLExpToUnresolvedVal
permFilter permFilter
tabPerm = RS.TablePerm unresolvedPermFltr Nothing tabPerm = RS.TablePerm unresolvedPermFltr Nothing
tabArgs = RS.noTableArgs { RS._taWhere = Just boolExp} tabArgs = RS.noSelectArgs { RS._saWhere = Just boolExp}
strfyNum <- stringifyNum <$> asks getter strfyNum <- stringifyNum <$> asks getter
return $ RS.AnnSelG annFlds tabFrom tabPerm tabArgs strfyNum return $ RS.AnnSelectG annFlds tabFrom tabPerm tabArgs strfyNum
where where
fldTy = _fType fld fldTy = _fType fld
@ -345,14 +424,18 @@ convertSelectByPKey opCtx fld =
SelPkOpCtx qt _ permFilter colArgMap = opCtx SelPkOpCtx qt _ permFilter colArgMap = opCtx
-- agg select related -- agg select related
parseColumns :: (MonadReusability m, MonadError QErr m) => PGColGNameMap -> AnnInpVal -> m [PGCol] parseColumns
:: (MonadReusability m, MonadError QErr m)
=> PGColGNameMap -> AnnInpVal -> m [PGCol]
parseColumns allColFldMap val = parseColumns allColFldMap val =
flip withArray val $ \_ vals -> flip withArray val $ \_ vals ->
forM vals $ \v -> do forM vals $ \v -> do
(_, G.EnumValue enumVal) <- asEnumVal v (_, G.EnumValue enumVal) <- asEnumVal v
pgiColumn <$> resolvePGCol allColFldMap enumVal pgiColumn <$> resolvePGCol allColFldMap enumVal
convertCount :: (MonadReusability m, MonadError QErr m) => PGColGNameMap -> ArgsMap -> m S.CountType convertCount
:: (MonadReusability m, MonadError QErr m)
=> PGColGNameMap -> ArgsMap -> m S.CountType
convertCount colGNameMap args = do convertCount colGNameMap args = do
columnsM <- withArgM args "columns" $ parseColumns colGNameMap columnsM <- withArgM args "columns" $ parseColumns colGNameMap
isDistinct <- or <$> withArgM args "distinct" parseDistinct isDistinct <- or <$> withArgM args "distinct" parseDistinct
@ -371,34 +454,33 @@ convertCount colGNameMap args = do
toFields :: [(T.Text, a)] -> RS.Fields a toFields :: [(T.Text, a)] -> RS.Fields a
toFields = map (first FieldName) toFields = map (first FieldName)
convertColFlds convertColumnFields
:: (MonadError QErr m) :: (MonadError QErr m)
=> PGColGNameMap -> G.NamedType -> SelSet -> m RS.ColFlds => PGColGNameMap -> G.NamedType -> ObjectSelectionSet -> m RS.ColumnFields
convertColFlds colGNameMap ty selSet = fmap toFields $ convertColumnFields colGNameMap ty selSet = fmap toFields $
withSelSet selSet $ \fld -> traverseObjectSelectionSet selSet $ \fld ->
case _fName fld of case _fName fld of
"__typename" -> return $ RS.PCFExp $ G.unName $ G.unNamedType ty "__typename" -> return $ RS.PCFExp $ G.unName $ G.unNamedType ty
n -> (RS.PCFCol . pgiColumn) <$> resolvePGCol colGNameMap n n -> RS.PCFCol . pgiColumn <$> resolvePGCol colGNameMap n
convertAggFld convertAggregateField
:: (MonadReusability m, MonadError QErr m) :: (MonadReusability m, MonadError QErr m)
=> PGColGNameMap -> G.NamedType -> SelSet -> m RS.AggFlds => PGColGNameMap -> G.NamedType -> ObjectSelectionSet -> m RS.AggregateFields
convertAggFld colGNameMap ty selSet = fmap toFields $ convertAggregateField colGNameMap ty selSet = fmap toFields $
withSelSet selSet $ \fld -> do traverseObjectSelectionSet selSet $ \Field{..} ->
let fType = _fType fld case _fName of
fSelSet = _fSelSet fld
case _fName fld of
"__typename" -> return $ RS.AFExp $ G.unName $ G.unNamedType ty "__typename" -> return $ RS.AFExp $ G.unName $ G.unNamedType ty
"count" -> RS.AFCount <$> convertCount colGNameMap (_fArguments fld) "count" -> RS.AFCount <$> convertCount colGNameMap (_fArguments fld)
n -> do n -> do
colFlds <- convertColFlds colGNameMap fType fSelSet fSelSet <- asObjectSelectionSet _fSelSet
unless (isAggFld n) $ throwInvalidFld n colFlds <- convertColumnFields colGNameMap _fType fSelSet
return $ RS.AFOp $ RS.AggOp (G.unName n) colFlds unless (isAggregateField n) $ throwInvalidFld n
return $ RS.AFOp $ RS.AggregateOp (G.unName n) colFlds
where where
throwInvalidFld (G.Name t) = throwInvalidFld (G.Name t) =
throw500 $ "unexpected field in _aggregate node: " <> t throw500 $ "unexpected field in _aggregate node: " <> t
type AnnAggSel = RS.AnnAggSelG UnresolvedVal type AnnAggregateSelect = RS.AnnAggregateSelectG UnresolvedVal
fromAggField fromAggField
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
@ -408,29 +490,162 @@ fromAggField
-> PGColGNameMap -> PGColGNameMap
-> AnnBoolExpPartialSQL -> AnnBoolExpPartialSQL
-> Maybe Int -> Maybe Int
-> Field -> m AnnAggSel -> Field -> m AnnAggregateSelect
fromAggField selectFrom colGNameMap permFilter permLimit fld = fieldAsPath fld $ do fromAggField selectFrom colGNameMap permFilter permLimit fld = fieldAsPath fld $ do
tableArgs <- parseTableArgs colGNameMap args tableArgs <- parseSelectArgs colGNameMap args
aggSelFlds <- fromAggSelSet colGNameMap (_fType fld) (_fSelSet fld) selSet <- asObjectSelectionSet $ _fSelSet fld
aggSelFlds <- fromAggSelSet colGNameMap (_fType fld) selSet
let unresolvedPermFltr = let unresolvedPermFltr =
fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter
let tabPerm = RS.TablePerm unresolvedPermFltr permLimit let tabPerm = RS.TablePerm unresolvedPermFltr permLimit
strfyNum <- stringifyNum <$> asks getter strfyNum <- stringifyNum <$> asks getter
return $ RS.AnnSelG aggSelFlds selectFrom tabPerm tableArgs strfyNum return $ RS.AnnSelectG aggSelFlds selectFrom tabPerm tableArgs strfyNum
where where
args = _fArguments fld args = _fArguments fld
fromConnectionField
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r
)
=> RS.SelectFromG UnresolvedVal
-> NonEmpty PGColumnInfo
-> AnnBoolExpPartialSQL
-> Maybe Int
-> Field -> m (RS.ConnectionSelect UnresolvedVal)
fromConnectionField selectFrom pkCols permFilter permLimit fld = fieldAsPath fld $ do
(tableArgs, slice, split) <- parseConnectionArgs pkCols args
selSet <- asObjectSelectionSet $ _fSelSet fld
connSelFlds <- fromConnectionSelSet (_fType fld) selSet
strfyNum <- stringifyNum <$> asks getter
let unresolvedPermFltr =
fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter
tabPerm = RS.TablePerm unresolvedPermFltr permLimit
annSel = RS.AnnSelectG connSelFlds selectFrom tabPerm tableArgs strfyNum
pure $ RS.ConnectionSelect pkCols split slice annSel
where
args = _fArguments fld
parseConnectionArgs
:: forall r m.
( MonadReusability m, MonadError QErr m, MonadReader r m
, Has FieldMap r, Has OrdByCtx r
)
=> NonEmpty PGColumnInfo
-> ArgsMap
-> m ( SelectArgs
, Maybe RS.ConnectionSlice
, Maybe (NE.NonEmpty (RS.ConnectionSplit UnresolvedVal))
)
parseConnectionArgs pKeyColumns args = do
whereExpM <- withArgM args "where" parseBoolExp
ordByExpML <- withArgM args "order_by" parseOrderBy
slice <- case (Map.lookup "first" args, Map.lookup "last" args) of
(Nothing, Nothing) -> pure Nothing
(Just _, Just _) -> throwVE "\"first\" and \"last\" are not allowed at once"
(Just v, Nothing) -> Just . RS.SliceFirst <$> parseNonNegativeInt
"expecting Integer value for \"first\"" v
(Nothing, Just v) -> Just . RS.SliceLast <$> parseNonNegativeInt
"expecting Integer value for \"last\"" v
maybeSplit <- case (Map.lookup "after" args, Map.lookup "before" args) of
(Nothing, Nothing) -> pure Nothing
(Just _, Just _) -> throwVE "\"after\" and \"before\" are not allowed at once"
(Just v, Nothing) -> fmap ((RS.CSKAfter,) . base64Decode) <$> asPGColTextM v
(Nothing, Just v) -> fmap ((RS.CSKBefore,) . base64Decode) <$> asPGColTextM v
let ordByExpM = NE.nonEmpty =<< appendPrimaryKeyOrderBy <$> ordByExpML
tableArgs = RS.SelectArgs whereExpM ordByExpM Nothing Nothing Nothing
split <- mapM (uncurry (validateConnectionSplit ordByExpM)) maybeSplit
pure (tableArgs, slice, split)
where
appendPrimaryKeyOrderBy :: [RS.AnnOrderByItemG v] -> [RS.AnnOrderByItemG v]
appendPrimaryKeyOrderBy orderBys =
let orderByColumnNames =
orderBys ^.. traverse . to obiColumn . RS._AOCColumn . to pgiColumn
pkeyOrderBys = flip mapMaybe (toList pKeyColumns) $ \pgColumnInfo ->
if pgiColumn pgColumnInfo `elem` orderByColumnNames then Nothing
else Just $ OrderByItemG Nothing (RS.AOCColumn pgColumnInfo) Nothing
in orderBys <> pkeyOrderBys
validateConnectionSplit
:: Maybe (NonEmpty (RS.AnnOrderByItemG UnresolvedVal))
-> RS.ConnectionSplitKind
-> BL.ByteString
-> m (NonEmpty (RS.ConnectionSplit UnresolvedVal))
validateConnectionSplit maybeOrderBys splitKind cursorSplit = do
cursorValue <- either (const throwInvalidCursor) pure $
J.eitherDecode cursorSplit
case maybeOrderBys of
Nothing -> forM pKeyColumns $
\pgColumnInfo -> do
let columnJsonPath = [J.Key $ getPGColTxt $ pgiColumn pgColumnInfo]
pgColumnValue <- maybe throwInvalidCursor pure $ iResultToMaybe $
executeJSONPath columnJsonPath cursorValue
pgValue <- parsePGScalarValue (pgiType pgColumnInfo) pgColumnValue
let unresolvedValue = UVPG $ AnnPGVal Nothing False pgValue
pure $ RS.ConnectionSplit splitKind unresolvedValue $
OrderByItemG Nothing (RS.AOCColumn pgColumnInfo) Nothing
Just orderBys ->
forM orderBys $ \orderBy -> do
let OrderByItemG orderType annObCol nullsOrder = orderBy
orderByItemValue <- maybe throwInvalidCursor pure $ iResultToMaybe $
executeJSONPath (getPathFromOrderBy annObCol) cursorValue
pgValue <- parsePGScalarValue (getOrderByColumnType annObCol) orderByItemValue
let unresolvedValue = UVPG $ AnnPGVal Nothing False pgValue
pure $ RS.ConnectionSplit splitKind unresolvedValue $
OrderByItemG orderType (() <$ annObCol) nullsOrder
where
throwInvalidCursor = throwVE "the \"after\" or \"before\" cursor is invalid"
iResultToMaybe = \case
J.ISuccess v -> Just v
J.IError{} -> Nothing
getPathFromOrderBy = \case
RS.AOCColumn pgColInfo ->
let pathElement = J.Key $ getPGColTxt $ pgiColumn pgColInfo
in [pathElement]
RS.AOCObjectRelation relInfo _ obCol ->
let pathElement = J.Key $ relNameToTxt $ riName relInfo
in pathElement : getPathFromOrderBy obCol
RS.AOCArrayAggregation relInfo _ aggOb ->
let fieldName = J.Key $ relNameToTxt (riName relInfo) <> "_aggregate"
in fieldName : case aggOb of
RS.AAOCount -> [J.Key "count"]
RS.AAOOp t col -> [J.Key t, J.Key $ getPGColTxt $ pgiColumn col]
getOrderByColumnType = \case
RS.AOCColumn pgColInfo -> pgiType pgColInfo
RS.AOCObjectRelation _ _ obCol -> getOrderByColumnType obCol
RS.AOCArrayAggregation _ _ aggOb ->
case aggOb of
RS.AAOCount -> PGColumnScalar PGInteger
RS.AAOOp _ colInfo -> pgiType colInfo
convertAggSelect convertAggSelect
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r :: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r , Has OrdByCtx r, Has SQLGenCtx r
) )
=> SelOpCtx -> Field -> m (RS.AnnAggSelG UnresolvedVal) => SelOpCtx -> Field -> m (RS.AnnAggregateSelectG UnresolvedVal)
convertAggSelect opCtx fld = convertAggSelect opCtx fld =
withPathK "selectionSet" $ withPathK "selectionSet" $
fromAggField (RS.FromTable qt) colGNameMap permFilter permLimit fld fromAggField (RS.FromTable qt) colGNameMap permFilter permLimit fld
where where
SelOpCtx qt _ colGNameMap permFilter permLimit = opCtx SelOpCtx qt _ colGNameMap permFilter permLimit = opCtx
convertConnectionSelect
:: ( MonadReusability m, MonadError QErr m, MonadReader r m, Has FieldMap r
, Has OrdByCtx r, Has SQLGenCtx r
)
=> NonEmpty PGColumnInfo -> SelOpCtx -> Field -> m (RS.ConnectionSelect UnresolvedVal)
convertConnectionSelect pkCols opCtx fld =
withPathK "selectionSet" $
fromConnectionField (RS.FromTable qt) pkCols permFilter permLimit fld
where
SelOpCtx qt _ _ permFilter permLimit = opCtx
parseFunctionArgs parseFunctionArgs
:: (MonadReusability m, MonadError QErr m) :: (MonadReusability m, MonadError QErr m)
=> Seq.Seq a => Seq.Seq a
@ -506,10 +721,77 @@ convertFuncQueryAgg
, Has OrdByCtx r , Has OrdByCtx r
, Has SQLGenCtx r , Has SQLGenCtx r
) )
=> FuncQOpCtx -> Field -> m AnnAggSel => FuncQOpCtx -> Field -> m AnnAggregateSelect
convertFuncQueryAgg funcOpCtx fld = convertFuncQueryAgg funcOpCtx fld =
withPathK "selectionSet" $ fieldAsPath fld $ do withPathK "selectionSet" $ fieldAsPath fld $ do
selectFrom <- makeFunctionSelectFrom qf argSeq fld selectFrom <- makeFunctionSelectFrom qf argSeq fld
fromAggField selectFrom colGNameMap permFilter permLimit fld fromAggField selectFrom colGNameMap permFilter permLimit fld
where where
FuncQOpCtx qf argSeq _ colGNameMap permFilter permLimit = funcOpCtx FuncQOpCtx qf argSeq _ colGNameMap permFilter permLimit = funcOpCtx
convertConnectionFuncQuery
:: ( MonadReusability m
, MonadError QErr m
, MonadReader r m
, Has FieldMap r
, Has OrdByCtx r
, Has SQLGenCtx r
)
=> NonEmpty PGColumnInfo -> FuncQOpCtx -> Field -> m (RS.ConnectionSelect UnresolvedVal)
convertConnectionFuncQuery pkCols funcOpCtx fld =
withPathK "selectionSet" $ fieldAsPath fld $ do
selectFrom <- makeFunctionSelectFrom qf argSeq fld
fromConnectionField selectFrom pkCols permFilter permLimit fld
where
FuncQOpCtx qf argSeq _ _ permFilter permLimit = funcOpCtx
resolveNodeId
:: forall m. ( MonadError QErr m
, MonadReusability m
)
=> Field -> m NodeIdData
resolveNodeId field =
withPathK "selectionSet" $ fieldAsPath field $ do
nodeIdText <- asPGColText =<< getArg (_fArguments field) "id"
either (const throwInvalidNodeId) pure $
J.eitherDecode $ base64Decode nodeIdText
where
throwInvalidNodeId = throwVE "the node id is invalid"
convertNodeSelect
:: ( MonadReusability m
, MonadError QErr m
, MonadReader r m
, Has FieldMap r
, Has OrdByCtx r
, Has SQLGenCtx r
)
=> SelOpCtx
-> Map.HashMap PGCol J.Value
-> Field
-> m (RS.AnnSimpleSelG UnresolvedVal)
convertNodeSelect selOpCtx pkeyColumnValues field =
withPathK "selectionSet" $ fieldAsPath field $ do
-- Parse selection set as interface
ifaceSelectionSet <- asInterfaceSelectionSet $ _fSelSet field
let tableObjectType = mkTableTy table
selSet = getMemberSelectionSet tableObjectType ifaceSelectionSet
unresolvedPermFilter = fmapAnnBoolExp partialSQLExpToUnresolvedVal permFilter
tablePerm = RS.TablePerm unresolvedPermFilter permLimit
-- Resolve the table selection set
annFields <- processTableSelectionSet tableObjectType selSet
-- Resolve the Node id primary key column values
unresolvedPkeyValues <- flip Map.traverseWithKey pkeyColumnValues $
\pgColumn jsonValue -> case Map.lookup pgColumn pgColumnMap of
Nothing -> throwVE $ "column " <> pgColumn <<> " not found"
Just columnInfo -> (,columnInfo) . UVPG . AnnPGVal Nothing False <$>
parsePGScalarValue (pgiType columnInfo) jsonValue
-- Generate the bool expression from the primary key column values
let pkeyBoolExp = BoolAnd $ flip map (Map.elems unresolvedPkeyValues) $
\(unresolvedValue, columnInfo) -> (BoolFld . AVCol columnInfo) [AEQ True unresolvedValue]
selectArgs = RS.noSelectArgs{RS._saWhere = Just pkeyBoolExp}
strfyNum <- stringifyNum <$> asks getter
pure $ RS.AnnSelectG annFields (RS.FromTable table) tablePerm selectArgs strfyNum
where
SelOpCtx table _ allColumns permFilter permLimit = selOpCtx
pgColumnMap = mapFromL pgiColumn $ Map.elems allColumns

View File

@ -7,6 +7,9 @@ module Hasura.GraphQL.Resolve.Types
import Control.Lens.TH import Control.Lens.TH
import Hasura.Prelude import Hasura.Prelude
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 as Map
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as T import qualified Data.Text as T
@ -27,12 +30,17 @@ import Hasura.SQL.Value
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
type NodeSelectMap = Map.HashMap G.NamedType SelOpCtx
data QueryCtx data QueryCtx
= QCSelect !SelOpCtx = QCNodeSelect !NodeSelectMap
| QCSelect !SelOpCtx
| QCSelectConnection !(NonEmpty PGColumnInfo) !SelOpCtx
| QCSelectPkey !SelPkOpCtx | QCSelectPkey !SelPkOpCtx
| QCSelectAgg !SelOpCtx | QCSelectAgg !SelOpCtx
| QCFuncQuery !FuncQOpCtx | QCFuncQuery !FuncQOpCtx
| QCFuncAggQuery !FuncQOpCtx | QCFuncAggQuery !FuncQOpCtx
| QCFuncConnection !(NonEmpty PGColumnInfo) !FuncQOpCtx
| QCAsyncActionFetch !ActionSelectOpContext | QCAsyncActionFetch !ActionSelectOpContext
| QCAction !ActionExecutionContext | QCAction !ActionExecutionContext
deriving (Show, Eq) deriving (Show, Eq)
@ -130,10 +138,16 @@ data ActionSelectOpContext
-- used in resolvers -- used in resolvers
type PGColGNameMap = Map.HashMap G.Name PGColumnInfo type PGColGNameMap = Map.HashMap G.Name PGColumnInfo
data RelationshipFieldKind
= RFKAggregate
| RFKSimple
| RFKConnection !(NonEmpty PGColumnInfo)
deriving (Show, Eq)
data RelationshipField data RelationshipField
= RelationshipField = RelationshipField
{ _rfInfo :: !RelInfo { _rfInfo :: !RelInfo
, _rfIsAgg :: !Bool , _rfIsAgg :: !RelationshipFieldKind
, _rfCols :: !PGColGNameMap , _rfCols :: !PGColGNameMap
, _rfPermFilter :: !AnnBoolExpPartialSQL , _rfPermFilter :: !AnnBoolExpPartialSQL
, _rfPermLimit :: !(Maybe Int) , _rfPermLimit :: !(Maybe Int)
@ -166,6 +180,8 @@ data ResolveField
= RFPGColumn !PGColumnInfo = RFPGColumn !PGColumnInfo
| RFRelationship !RelationshipField | RFRelationship !RelationshipField
| RFComputedField !ComputedField | RFComputedField !ComputedField
| RFRemoteRelationship !RemoteFieldInfo
| RFNodeId !QualifiedTable !(NonEmpty PGColumnInfo)
deriving (Show, Eq) deriving (Show, Eq)
type FieldMap = Map.HashMap (G.NamedType, G.Name) ResolveField type FieldMap = Map.HashMap (G.NamedType, G.Name) ResolveField
@ -245,6 +261,13 @@ data InputFunctionArgument
| IFAUnknown !FunctionArgItem -- ^ Unknown value, need to be parsed | IFAUnknown !FunctionArgItem -- ^ Unknown value, need to be parsed
deriving (Show, Eq) deriving (Show, Eq)
data NodeIdData
= NodeIdData
{ _nidTable :: !QualifiedTable
, _nidColumns :: !(Map.HashMap PGCol J.Value)
} deriving (Show, Eq)
$(J.deriveFromJSON (J.aesonDrop 4 J.snakeCase) ''NodeIdData)
-- template haskell related -- template haskell related
$(makePrisms ''ResolveField) $(makePrisms ''ResolveField)
$(makeLenses ''ComputedField) $(makeLenses ''ComputedField)

View File

@ -132,7 +132,7 @@ actionIdParser =
actionOutputFields actionOutputFields
:: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r) :: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r)
=> AnnotatedObjectType => AnnotatedObjectType
-> MaybeT m (Parser 'Output n (RQL.AnnFldsG UnpreparedValue)) -> MaybeT m (Parser 'Output n (RQL.AnnFieldsG UnpreparedValue))
actionOutputFields outputObject = do actionOutputFields outputObject = do
let scalarOrEnumFields = map scalarOrEnumFieldParser $ toList $ _otdFields outputObject let scalarOrEnumFields = map scalarOrEnumFieldParser $ toList $ _otdFields outputObject
relationshipFields <- forM (_otdRelationships outputObject) $ traverse relationshipFieldParser relationshipFields <- forM (_otdRelationships outputObject) $ traverse relationshipFieldParser
@ -141,11 +141,11 @@ actionOutputFields outputObject = do
outputTypeName = unObjectTypeName $ _otdName outputObject outputTypeName = unObjectTypeName $ _otdName outputObject
outputTypeDescription = _otdDescription outputObject outputTypeDescription = _otdDescription outputObject
pure $ P.selectionSet outputTypeName outputTypeDescription allFieldParsers pure $ P.selectionSet outputTypeName outputTypeDescription allFieldParsers
<&> parsedSelectionsToFields RQL.FExp <&> parsedSelectionsToFields RQL.AFExpression
where where
scalarOrEnumFieldParser scalarOrEnumFieldParser
:: ObjectFieldDefinition (G.GType, AnnotatedObjectFieldType) :: ObjectFieldDefinition (G.GType, AnnotatedObjectFieldType)
-> FieldParser n (RQL.AnnFldG UnpreparedValue) -> FieldParser n (RQL.AnnFieldG UnpreparedValue)
scalarOrEnumFieldParser (ObjectFieldDefinition name _ description ty) = scalarOrEnumFieldParser (ObjectFieldDefinition name _ description ty) =
let (gType, objectFieldType) = ty let (gType, objectFieldType) = ty
fieldName = unObjectFieldName name fieldName = unObjectFieldName name
@ -157,11 +157,11 @@ actionOutputFields outputObject = do
AOFTEnum def -> customEnumParser def AOFTEnum def -> customEnumParser def
in bool P.nonNullableField id (G.isNullable gType) $ in bool P.nonNullableField id (G.isNullable gType) $
P.selection_ (unObjectFieldName name) description fieldParser P.selection_ (unObjectFieldName name) description fieldParser
$> RQL.mkAnnColField pgColumnInfo Nothing $> RQL.mkAnnColumnField pgColumnInfo Nothing
relationshipFieldParser relationshipFieldParser
:: TypeRelationship TableInfo PGColumnInfo :: TypeRelationship TableInfo PGColumnInfo
-> MaybeT m (FieldParser n (RQL.AnnFldG UnpreparedValue)) -> MaybeT m (FieldParser n (RQL.AnnFieldG UnpreparedValue))
relationshipFieldParser typeRelationship = do relationshipFieldParser typeRelationship = do
let TypeRelationship relName relType tableInfo fieldMapping = typeRelationship let TypeRelationship relName relType tableInfo fieldMapping = typeRelationship
tableName = _tciName $ _tiCoreInfo tableInfo tableName = _tciName $ _tiCoreInfo tableInfo
@ -175,10 +175,10 @@ actionOutputFields outputObject = do
[ (unsafePGCol $ G.unName $ unObjectFieldName k, pgiColumn v) [ (unsafePGCol $ G.unName $ unObjectFieldName k, pgiColumn v)
| (k, v) <- Map.toList fieldMapping | (k, v) <- Map.toList fieldMapping
] ]
annotatedRelationship = RQL.AnnRelG tableRelName columnMapping selectExp annotatedRelationship = RQL.AnnRelationSelectG tableRelName columnMapping selectExp
in case relType of in case relType of
ObjRel -> RQL.FObj annotatedRelationship ObjRel -> RQL.AFObjectRelation annotatedRelationship
ArrRel -> RQL.FArr $ RQL.ASSimple annotatedRelationship ArrRel -> RQL.AFArrayRelation $ RQL.ASSimple annotatedRelationship
mkDefinitionList :: AnnotatedObjectType -> [(PGCol, PGScalarType)] mkDefinitionList :: AnnotatedObjectType -> [(PGCol, PGScalarType)]
mkDefinitionList annotatedOutputType = mkDefinitionList annotatedOutputType =

View File

@ -52,7 +52,7 @@ orderByExp table selectPermissions = memoizeOn 'orderByExp table $ do
FIColumn columnInfo -> do FIColumn columnInfo -> do
let fieldName = pgiName columnInfo let fieldName = pgiName columnInfo
pure $ P.fieldOptional fieldName Nothing orderByOperator pure $ P.fieldOptional fieldName Nothing orderByOperator
<&> fmap (pure . mkOrderByItemG (RQL.AOCPG $ pgiColumn columnInfo)) . join <&> fmap (pure . mkOrderByItemG (RQL.AOCColumn columnInfo)) . join
FIRelationship relationshipInfo -> do FIRelationship relationshipInfo -> do
let remoteTable = riRTable relationshipInfo let remoteTable = riRTable relationshipInfo
fieldName <- MaybeT $ pure $ G.mkName $ relNameToTxt $ riName relationshipInfo fieldName <- MaybeT $ pure $ G.mkName $ relNameToTxt $ riName relationshipInfo
@ -63,13 +63,13 @@ orderByExp table selectPermissions = memoizeOn 'orderByExp table $ do
otherTableParser <- lift $ orderByExp remoteTable perms otherTableParser <- lift $ orderByExp remoteTable perms
pure $ do pure $ do
otherTableOrderBy <- join <$> P.fieldOptional fieldName Nothing (P.nullable otherTableParser) otherTableOrderBy <- join <$> P.fieldOptional fieldName Nothing (P.nullable otherTableParser)
pure $ fmap (map $ fmap $ RQL.AOCObj relationshipInfo newPerms) otherTableOrderBy pure $ fmap (map $ fmap $ RQL.AOCObjectRelation relationshipInfo newPerms) otherTableOrderBy
ArrRel -> do ArrRel -> do
let aggregateFieldName = fieldName <> $$(G.litName "_aggregate") let aggregateFieldName = fieldName <> $$(G.litName "_aggregate")
aggregationParser <- lift $ orderByAggregation remoteTable perms aggregationParser <- lift $ orderByAggregation remoteTable perms
pure $ do pure $ do
aggregationOrderBy <- join <$> P.fieldOptional aggregateFieldName Nothing (P.nullable aggregationParser) aggregationOrderBy <- join <$> P.fieldOptional aggregateFieldName Nothing (P.nullable aggregationParser)
pure $ fmap (map $ fmap $ RQL.AOCAgg relationshipInfo newPerms) aggregationOrderBy pure $ fmap (map $ fmap $ RQL.AOCArrayAggregation relationshipInfo newPerms) aggregationOrderBy
FIComputedField _ -> empty FIComputedField _ -> empty
FIRemoteRelationship _ -> empty FIRemoteRelationship _ -> empty
@ -84,7 +84,7 @@ orderByAggregation
:: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m) :: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m)
=> QualifiedTable => QualifiedTable
-> SelPermInfo -> SelPermInfo
-> m (Parser 'Input n [OrderByItemG RQL.AnnAggOrdBy]) -> m (Parser 'Input n [OrderByItemG RQL.AnnAggregateOrderBy])
orderByAggregation table selectPermissions = do orderByAggregation table selectPermissions = do
-- WIP NOTE -- WIP NOTE
-- there is heavy duplication between this and Select.tableAggregationFields -- there is heavy duplication between this and Select.tableAggregationFields
@ -113,16 +113,16 @@ orderByAggregation table selectPermissions = do
description = G.Description $ "order by aggregate values of table \"" <> table <<> "\"" description = G.Description $ "order by aggregate values of table \"" <> table <<> "\""
pure $ P.object objectName (Just description) aggFields pure $ P.object objectName (Just description) aggFields
where where
mkField :: PGColumnInfo -> InputFieldsParser n (Maybe (PGCol, OrderInfo)) mkField :: PGColumnInfo -> InputFieldsParser n (Maybe (PGColumnInfo, OrderInfo))
mkField columnInfo = mkField columnInfo =
P.fieldOptional (pgiName columnInfo) (pgiDescription columnInfo) orderByOperator P.fieldOptional (pgiName columnInfo) (pgiDescription columnInfo) orderByOperator
<&> fmap (pgiColumn columnInfo,) . join <&> fmap (columnInfo,) . join
parseOperator parseOperator
:: G.Name :: G.Name
-> G.Name -> G.Name
-> InputFieldsParser n [(PGCol, OrderInfo)] -> InputFieldsParser n [(PGColumnInfo, OrderInfo)]
-> InputFieldsParser n (Maybe [OrderByItemG RQL.AnnAggOrdBy]) -> InputFieldsParser n (Maybe [OrderByItemG RQL.AnnAggregateOrderBy])
parseOperator operator tableName columns = parseOperator operator tableName columns =
let opText = G.unName operator let opText = G.unName operator
-- FIXME: isn't G.Name a Monoid? -- FIXME: isn't G.Name a Monoid?

View File

@ -51,11 +51,11 @@ import Hasura.SQL.Value
type SelectExp = RQL.AnnSimpleSelG UnpreparedValue type SelectExp = RQL.AnnSimpleSelG UnpreparedValue
type AggSelectExp = RQL.AnnAggSelG UnpreparedValue type AggSelectExp = RQL.AnnAggregateSelectG UnpreparedValue
type TableArgs = RQL.TableArgsG UnpreparedValue type SelectArgs = RQL.SelectArgsG UnpreparedValue
type TablePerms = RQL.TablePermG UnpreparedValue type TablePerms = RQL.TablePermG UnpreparedValue
type AnnotatedFields = RQL.AnnFldsG UnpreparedValue type AnnotatedFields = RQL.AnnFieldsG UnpreparedValue
type AnnotatedField = RQL.AnnFldG UnpreparedValue type AnnotatedField = RQL.AnnFieldG UnpreparedValue
@ -83,7 +83,7 @@ selectTable table fieldName description selectPermissions = do
tableArgsParser <- tableArgs table selectPermissions tableArgsParser <- tableArgs table selectPermissions
selectionSetParser <- tableSelectionSet table selectPermissions Nothing selectionSetParser <- tableSelectionSet table selectPermissions Nothing
pure $ P.subselection fieldName description tableArgsParser selectionSetParser pure $ P.subselection fieldName description tableArgsParser selectionSetParser
<&> \(args, fields) -> RQL.AnnSelG <&> \(args, fields) -> RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromTable table , RQL._asnFrom = RQL.FromTable table
, RQL._asnPerm = tablePermissionsInfo selectPermissions , RQL._asnPerm = tablePermissionsInfo selectPermissions
@ -121,13 +121,13 @@ selectTableByPk table fieldName description selectPermissions = runMaybeT do
<&> \(boolExpr, fields) -> <&> \(boolExpr, fields) ->
let defaultPerms = tablePermissionsInfo selectPermissions let defaultPerms = tablePermissionsInfo selectPermissions
whereExpr = Just $ BoolAnd $ toList boolExpr whereExpr = Just $ BoolAnd $ toList boolExpr
in RQL.AnnSelG in RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromTable table , RQL._asnFrom = RQL.FromTable table
, RQL._asnPerm = defaultPerms { RQL._tpLimit = Nothing } , RQL._asnPerm = defaultPerms { RQL._tpLimit = Nothing }
-- TODO: check whether this is necessary: ^^^^^^^ -- TODO: check whether this is necessary: ^^^^^^^
-- This is how it was in legacy code. -- This is how it was in legacy code.
, RQL._asnArgs = RQL.noTableArgs { RQL._taWhere = whereExpr } , RQL._asnArgs = RQL.noSelectArgs { RQL._saWhere = whereExpr }
, RQL._asnStrfyNum = stringifyNum , RQL._asnStrfyNum = stringifyNum
} }
@ -161,7 +161,7 @@ selectTableAggregate table fieldName description selectPermissions = runMaybeT d
, RQL.TAFAgg <$> P.subselection_ $$(G.litName "aggregate") Nothing aggregateParser , RQL.TAFAgg <$> P.subselection_ $$(G.litName "aggregate") Nothing aggregateParser
] ]
pure $ P.subselection fieldName description tableArgsParser aggregationParser pure $ P.subselection fieldName description tableArgsParser aggregationParser
<&> \(args, fields) -> RQL.AnnSelG <&> \(args, fields) -> RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromTable table , RQL._asnFrom = RQL.FromTable table
, RQL._asnPerm = tablePermissionsInfo selectPermissions , RQL._asnPerm = tablePermissionsInfo selectPermissions
@ -249,7 +249,7 @@ tableSelectionSet table selectPermissions interfaceM = memoizeOn 'tableSelection
let description = G.Description . getPGDescription <$> _tciDescription tableInfo let description = G.Description . getPGDescription <$> _tciDescription tableInfo
pure $ P.selectionSetObject tableName description fieldParsers (toList interfaceM) pure $ P.selectionSetObject tableName description fieldParsers (toList interfaceM)
<&> parsedSelectionsToFields RQL.FExp <&> parsedSelectionsToFields RQL.AFExpression
-- | User-defined function (AKA custom function) -- | User-defined function (AKA custom function)
@ -268,7 +268,7 @@ selectFunction function fieldName description selectPermissions = do
selectionSetParser <- tableSelectionSet table selectPermissions Nothing selectionSetParser <- tableSelectionSet table selectPermissions Nothing
let argsParser = liftA2 (,) functionArgsParser tableArgsParser let argsParser = liftA2 (,) functionArgsParser tableArgsParser
pure $ P.subselection fieldName description argsParser selectionSetParser pure $ P.subselection fieldName description argsParser selectionSetParser
<&> \((funcArgs, tableArgs'), fields) -> RQL.AnnSelG <&> \((funcArgs, tableArgs'), fields) -> RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromFunction (fiName function) funcArgs Nothing , RQL._asnFrom = RQL.FromFunction (fiName function) funcArgs Nothing
, RQL._asnPerm = tablePermissionsInfo selectPermissions , RQL._asnPerm = tablePermissionsInfo selectPermissions
@ -299,7 +299,7 @@ selectFunctionAggregate function fieldName description selectPermissions = runMa
, RQL.TAFAgg <$> P.subselection_ $$(G.litName "aggregate") Nothing aggregateParser , RQL.TAFAgg <$> P.subselection_ $$(G.litName "aggregate") Nothing aggregateParser
] ]
pure $ P.subselection fieldName description argsParser aggregationParser pure $ P.subselection fieldName description argsParser aggregationParser
<&> \((funcArgs, tableArgs'), fields) -> RQL.AnnSelG <&> \((funcArgs, tableArgs'), fields) -> RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromFunction (fiName function) funcArgs Nothing , RQL._asnFrom = RQL.FromFunction (fiName function) funcArgs Nothing
, RQL._asnPerm = tablePermissionsInfo selectPermissions , RQL._asnPerm = tablePermissionsInfo selectPermissions
@ -323,7 +323,7 @@ tableArgs
:: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m) :: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m)
=> QualifiedTable => QualifiedTable
-> SelPermInfo -> SelPermInfo
-> m (InputFieldsParser n TableArgs) -> m (InputFieldsParser n SelectArgs)
tableArgs table selectPermissions = do tableArgs table selectPermissions = do
boolExpParser <- boolExp table (Just selectPermissions) boolExpParser <- boolExp table (Just selectPermissions)
orderByParser <- orderByExp table selectPermissions orderByParser <- orderByExp table selectPermissions
@ -342,7 +342,7 @@ tableArgs table selectPermissions = do
-- despite the schema explicitly declaring it as an int; the suspected goal -- despite the schema explicitly declaring it as an int; the suspected goal
-- of this was to allow for bigint offsets, but there's no surviving commit -- of this was to allow for bigint offsets, but there's no surviving commit
-- message or documentation that states it explicity. A visible artefact of -- message or documentation that states it explicity. A visible artefact of
-- this is the fact that in the TableArgs we store a SQL expression for the -- this is the fact that in the SelectArgs we store a SQL expression for the
-- offet while the limit is stored as a normal int. -- offet while the limit is stored as a normal int.
-- --
-- While it would be possible to write a custom parser that advertises -- While it would be possible to write a custom parser that advertises
@ -352,12 +352,12 @@ tableArgs table selectPermissions = do
-- TODO: distinct_on must be validated ungainst order_by -- TODO: distinct_on must be validated ungainst order_by
-- the check at Resolve/Select.hs:152 must be ported here -- the check at Resolve/Select.hs:152 must be ported here
pure $ RQL.TableArgs pure $ RQL.SelectArgs
{ RQL._taWhere = whereF { RQL._saWhere = whereF
, RQL._taOrderBy = nonEmpty . concat =<< orderBy , RQL._saOrderBy = nonEmpty . concat =<< orderBy
, RQL._taLimit = fromIntegral <$> limit , RQL._saLimit = fromIntegral <$> limit
, RQL._taOffset = txtEncoder . PGValInteger <$> offset , RQL._saOffset = txtEncoder . PGValInteger <$> offset
, RQL._taDistCols = nonEmpty =<< distinct , RQL._saDistinct = nonEmpty =<< distinct
} }
where where
-- TH splices mess up ApplicativeDo -- TH splices mess up ApplicativeDo
@ -398,7 +398,7 @@ tableAggregationFields
:: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m) :: forall m n r. (MonadSchema n m, MonadTableInfo r m, MonadRole r m)
=> QualifiedTable => QualifiedTable
-> SelPermInfo -> SelPermInfo
-> m (Parser 'Output n RQL.AggFlds) -> m (Parser 'Output n RQL.AggregateFields)
tableAggregationFields table selectPermissions = do tableAggregationFields table selectPermissions = do
tableName <- qualifiedObjectToName table tableName <- qualifiedObjectToName table
allColumns <- tableSelectColumns table selectPermissions allColumns <- tableSelectColumns table selectPermissions
@ -447,7 +447,7 @@ tableAggregationFields table selectPermissions = do
:: G.Name :: G.Name
-> G.Name -> G.Name
-> [FieldParser n RQL.PGColFld] -> [FieldParser n RQL.PGColFld]
-> FieldParser n RQL.AggFld -> FieldParser n RQL.AggregateField
parseOperator operator tableName columns = parseOperator operator tableName columns =
let opText = G.unName operator let opText = G.unName operator
setName = tableName <> $$(G.litName "_") <> operator <> $$(G.litName "_fields") setName = tableName <> $$(G.litName "_") <> operator <> $$(G.litName "_fields")
@ -455,7 +455,7 @@ tableAggregationFields table selectPermissions = do
subselectionParser = P.selectionSet setName setDesc columns subselectionParser = P.selectionSet setName setDesc columns
<&> parsedSelectionsToFields RQL.PCFExp <&> parsedSelectionsToFields RQL.PCFExp
in P.subselection_ operator Nothing subselectionParser in P.subselection_ operator Nothing subselectionParser
<&> (RQL.AFOp . RQL.AggOp opText) <&> (RQL.AFOp . RQL.AggregateOp opText)
lookupRemoteField' lookupRemoteField'
:: (MonadSchema n m, MonadTableInfo r m) :: (MonadSchema n m, MonadTableInfo r m)
@ -499,7 +499,7 @@ fieldSelection fieldInfo selectPermissions = do
pathArg = jsonPathArg $ pgiType columnInfo pathArg = jsonPathArg $ pgiType columnInfo
field <- lift $ P.column (pgiType columnInfo) (G.Nullability $ pgiIsNullable columnInfo) field <- lift $ P.column (pgiType columnInfo) (G.Nullability $ pgiIsNullable columnInfo)
pure $ P.selection fieldName (pgiDescription columnInfo) pathArg field pure $ P.selection fieldName (pgiDescription columnInfo) pathArg field
<&> RQL.mkAnnColField columnInfo <&> RQL.mkAnnColumnField columnInfo
FIRelationship relationshipInfo -> concat . maybeToList <$> runMaybeT do FIRelationship relationshipInfo -> concat . maybeToList <$> runMaybeT do
-- TODO: move this to a separate function? -- TODO: move this to a separate function?
@ -514,10 +514,10 @@ fieldSelection fieldInfo selectPermissions = do
relFieldName <- lift $ textToName $ relNameToTxt relName relFieldName <- lift $ textToName $ relNameToTxt relName
otherTableParser <- lift $ selectTable otherTable relFieldName desc remotePerms otherTableParser <- lift $ selectTable otherTable relFieldName desc remotePerms
let field = otherTableParser <&> \selectExp -> let field = otherTableParser <&> \selectExp ->
let annotatedRelationship = RQL.AnnRelG relName colMapping selectExp let annotatedRelationship = RQL.AnnRelationSelectG relName colMapping selectExp
in case riType relationshipInfo of in case riType relationshipInfo of
ObjRel -> RQL.FObj annotatedRelationship ObjRel -> RQL.AFObjectRelation annotatedRelationship
ArrRel -> RQL.FArr $ RQL.ASSimple annotatedRelationship ArrRel -> RQL.AFArrayRelation $ RQL.ASSimple annotatedRelationship
case riType relationshipInfo of case riType relationshipInfo of
ObjRel -> pure [field] ObjRel -> pure [field]
ArrRel -> do ArrRel -> do
@ -525,7 +525,7 @@ fieldSelection fieldInfo selectPermissions = do
relAggDesc = Just $ G.Description "An aggregate relationship" relAggDesc = Just $ G.Description "An aggregate relationship"
remoteAggField <- lift $ selectTableAggregate otherTable relAggFieldName relAggDesc remotePerms remoteAggField <- lift $ selectTableAggregate otherTable relAggFieldName relAggDesc remotePerms
pure $ catMaybes [ Just field pure $ catMaybes [ Just field
, fmap (RQL.FArr . RQL.ASAgg . RQL.AnnRelG relName colMapping) <$> remoteAggField , fmap (RQL.AFArrayRelation . RQL.ASAggregate . RQL.AnnRelationSelectG relName colMapping) <$> remoteAggField
] ]
FIComputedField computedFieldInfo -> FIComputedField computedFieldInfo ->
@ -562,7 +562,7 @@ fieldSelection fieldInfo selectPermissions = do
pure $ pure $ P.unsafeRawField (P.mkDefinition fieldName Nothing fieldInfo') pure $ pure $ P.unsafeRawField (P.mkDefinition fieldName Nothing fieldInfo')
`P.bindField` \G.Field{ G._fArguments = args, G._fSelectionSet = selSet } -> do `P.bindField` \G.Field{ G._fArguments = args, G._fSelectionSet = selSet } -> do
remoteArgs <- P.ifParser remoteFieldsArgumentsParser args remoteArgs <- P.ifParser remoteFieldsArgumentsParser args
pure $ RQL.FRemote $ RQL.RemoteSelect pure $ RQL.AFRemote $ RQL.RemoteSelect
{ _rselArgs = remoteArgs { _rselArgs = remoteArgs
, _rselSelection = selSet , _rselSelection = selSet
, _rselHasuraColumns = _rfiHasuraFields remoteFieldInfo , _rselHasuraColumns = _rfiHasuraFields remoteFieldInfo
@ -697,7 +697,7 @@ computedFieldFunctionArgs ComputedFieldFunction{..} =
-- FIXME: move to common? -- FIXME: move to common?
jsonPathArg :: MonadParse n => PGColumnType -> InputFieldsParser n (Maybe RQL.ColOp) jsonPathArg :: MonadParse n => PGColumnType -> InputFieldsParser n (Maybe RQL.ColumnOp)
jsonPathArg columnType jsonPathArg columnType
| isScalarColumnWhere isJSONType columnType = | isScalarColumnWhere isJSONType columnType =
P.fieldOptional fieldName description P.string `P.bindFields` traverse toColExp P.fieldOptional fieldName description P.string `P.bindFields` traverse toColExp
@ -707,7 +707,7 @@ jsonPathArg columnType
description = Just "JSON select path" description = Just "JSON select path"
toColExp textValue = case parseJSONPath textValue of toColExp textValue = case parseJSONPath textValue of
Left err -> parseError $ T.pack $ "parse json path error: " ++ err Left err -> parseError $ T.pack $ "parse json path error: " ++ err
Right jPaths -> return $ RQL.ColOp SQL.jsonbPathOp $ SQL.SEArray $ map elToColExp jPaths Right jPaths -> return $ RQL.ColumnOp SQL.jsonbPathOp $ SQL.SEArray $ map elToColExp jPaths
elToColExp (Key k) = SQL.SELit k elToColExp (Key k) = SQL.SELit k
elToColExp (Index i) = SQL.SELit $ T.pack (show i) elToColExp (Index i) = SQL.SELit $ T.pack (show i)
@ -726,7 +726,7 @@ computedField ComputedFieldInfo{..} selectPermissions = runMaybeT do
let fieldArgsParser = do let fieldArgsParser = do
args <- functionArgsParser args <- functionArgsParser
colOp <- jsonPathArg $ PGColumnScalar scalarReturnType colOp <- jsonPathArg $ PGColumnScalar scalarReturnType
pure $ RQL.FComputedField $ RQL.CFSScalar $ RQL.ComputedFieldScalarSel pure $ RQL.AFComputedField $ RQL.CFSScalar $ RQL.ComputedFieldScalarSelect
{ RQL._cfssFunction = _cffName _cfiFunction { RQL._cfssFunction = _cffName _cfiFunction
, RQL._cfssType = scalarReturnType , RQL._cfssType = scalarReturnType
, RQL._cfssColumnOp = colOp , RQL._cfssColumnOp = colOp
@ -741,7 +741,7 @@ computedField ComputedFieldInfo{..} selectPermissions = runMaybeT do
let fieldArgsParser = liftA2 (,) functionArgsParser selectArgsParser let fieldArgsParser = liftA2 (,) functionArgsParser selectArgsParser
pure $ P.subselection fieldName Nothing fieldArgsParser selectionSetParser <&> pure $ P.subselection fieldName Nothing fieldArgsParser selectionSetParser <&>
\((functionArgs', args), fields) -> \((functionArgs', args), fields) ->
RQL.FComputedField $ RQL.CFSTable RQL.JASMultipleRows $ RQL.AnnSelG RQL.AFComputedField $ RQL.CFSTable RQL.JASMultipleRows $ RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromFunction (_cffName _cfiFunction) functionArgs' Nothing , RQL._asnFrom = RQL.FromFunction (_cffName _cfiFunction) functionArgs' Nothing
, RQL._asnPerm = tablePermissionsInfo remotePerms , RQL._asnPerm = tablePermissionsInfo remotePerms
@ -891,16 +891,16 @@ nodeField allTables = do
(perms, pkeyColumns, fields) <- (perms, pkeyColumns, fields) <-
onNothing (Map.lookup table parseds) $ throwInvalidNodeId $ "the table " <>> ident onNothing (Map.lookup table parseds) $ throwInvalidNodeId $ "the table " <>> ident
whereExp <- buildNodeIdBoolExp columnValues pkeyColumns whereExp <- buildNodeIdBoolExp columnValues pkeyColumns
return $ RQL.AnnSelG return $ RQL.AnnSelectG
{ RQL._asnFields = fields { RQL._asnFields = fields
, RQL._asnFrom = RQL.FromTable table , RQL._asnFrom = RQL.FromTable table
, RQL._asnPerm = tablePermissionsInfo perms , RQL._asnPerm = tablePermissionsInfo perms
, RQL._asnArgs = RQL.TableArgs , RQL._asnArgs = RQL.SelectArgs
{ RQL._taWhere = Just whereExp { RQL._saWhere = Just whereExp
, RQL._taOrderBy = Nothing , RQL._saOrderBy = Nothing
, RQL._taLimit = Nothing , RQL._saLimit = Nothing
, RQL._taOffset = Nothing , RQL._saOffset = Nothing
, RQL._taDistCols = Nothing , RQL._saDistinct = Nothing
} }
, RQL._asnStrfyNum = stringifyNum , RQL._asnStrfyNum = stringifyNum
} }

View File

@ -44,7 +44,7 @@ runGQ reqId userInfo reqHdrs queryType req = do
(telemTimeTot_DT, (telemCacheHit, telemLocality, (telemTimeIO_DT, telemQueryType, !resp))) <- withElapsedTime $ do (telemTimeTot_DT, (telemCacheHit, telemLocality, (telemTimeIO_DT, telemQueryType, !resp))) <- withElapsedTime $ do
E.ExecutionCtx _ sqlGenCtx pgExecCtx planCache sc scVer httpManager enableAL <- ask E.ExecutionCtx _ sqlGenCtx pgExecCtx planCache sc scVer httpManager enableAL <- ask
(telemCacheHit, execPlan) <- E.getResolvedExecPlan pgExecCtx planCache (telemCacheHit, execPlan) <- E.getResolvedExecPlan pgExecCtx planCache
userInfo sqlGenCtx enableAL sc scVer queryType httpManager reqHdrs req userInfo sqlGenCtx enableAL sc scVer queryType httpManager reqHdrs req
case execPlan of case execPlan of
E.QueryExecutionPlan queryPlan -> do E.QueryExecutionPlan queryPlan -> do
case queryPlan of case queryPlan of
@ -76,8 +76,8 @@ runGQ reqId userInfo reqHdrs queryType req = do
return (telemCacheHit, Telem.Local, (telemTimeIO, telemQueryType, HttpResponse resp respHdrs)) return (telemCacheHit, Telem.Local, (telemTimeIO, telemQueryType, HttpResponse resp respHdrs))
E.GExPRemote rsi opDef -> do E.GExPRemote rsi opDef -> do
let telemQueryType | G._todType opDef == G.OperationTypeMutation = Telem.Mutation let telemQueryType | G._todType opDef == G.OperationTypeMutation = Telem.Mutation
| otherwise = Telem.Query | otherwise = Telem.Query
(telemTimeIO, resp) <- E.execRemoteGQ reqId userInfo reqHdrs req rsi opDef (telemTimeIO, resp) <- E.execRemoteGQ reqId userInfo reqHdrs req rsi $ G._todType opDef
return (telemCacheHit, Telem.Remote, (telemTimeIO, telemQueryType, resp)) return (telemCacheHit, Telem.Remote, (telemTimeIO, telemQueryType, resp))
-} -}
let telemTimeIO = fromUnits telemTimeIO_DT let telemTimeIO = fromUnits telemTimeIO_DT

View File

@ -1,8 +1,8 @@
module Hasura.GraphQL.Validate module Hasura.GraphQL.Validate
( validateGQ ( validateGQ
, showVars , showVars
, RootSelSet(..) , RootSelectionSet(..)
, SelSet , SelectionSet(..)
, Field(..) , Field(..)
, getTypedOp , getTypedOp
, QueryParts(..) , QueryParts(..)
@ -13,6 +13,9 @@ module Hasura.GraphQL.Validate
, validateVariablesForReuse , validateVariablesForReuse
, isQueryInAllowlist , isQueryInAllowlist
, unValidateArgsMap
, unValidateSelectionSet
, unValidateField
) where ) where
import Hasura.Prelude import Hasura.Prelude
@ -22,16 +25,24 @@ import Data.Has
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as HS import qualified Data.HashSet as HS
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.NormalForm
import Hasura.GraphQL.Resolve.InputValue (annInpValueToJson)
import Hasura.GraphQL.Schema import Hasura.GraphQL.Schema
import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.GraphQL.Validate.Context import Hasura.GraphQL.Validate.Context
import Hasura.GraphQL.Validate.Field
import Hasura.GraphQL.Validate.InputValue import Hasura.GraphQL.Validate.InputValue
import Hasura.GraphQL.Validate.SelectionSet
import Hasura.GraphQL.Validate.Types import Hasura.GraphQL.Validate.Types
import Hasura.RQL.DML.Select.Types
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.RQL.Types.QueryCollection import Hasura.RQL.Types.QueryCollection
import Hasura.SQL.Time
import Hasura.SQL.Value
data QueryParts data QueryParts
= QueryParts = QueryParts
@ -137,19 +148,12 @@ validateFrag
validateFrag (G.FragmentDefinition n onTy dirs selSet) = do validateFrag (G.FragmentDefinition n onTy dirs selSet) = do
unless (null dirs) $ throwVE unless (null dirs) $ throwVE
"unexpected directives at fragment definition" "unexpected directives at fragment definition"
tyInfo <- getTyInfoVE onTy fragmentTypeInfo <- getFragmentTyInfo onTy
objTyInfo <- onNothing (getObjTyM tyInfo) $ throwVE return $ FragDef n fragmentTypeInfo selSet
"fragments can only be defined on object types"
return $ FragDef n objTyInfo selSet
data RootSelSet
= RQuery !SelSet
| RMutation !SelSet
| RSubscription !Field
deriving (Show, Eq)
validateGQ validateGQ
:: (MonadError QErr m, MonadReader GCtx m, MonadReusability m) => QueryParts -> m RootSelSet :: (MonadError QErr m, MonadReader GCtx m, MonadReusability m)
=> QueryParts -> m RootSelectionSet
validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do
ctx <- ask ctx <- ask
@ -165,19 +169,22 @@ validateGQ (QueryParts opDef opRoot fragDefsL varValsM) = do
-- build a validation ctx -- build a validation ctx
let valCtx = ValidationCtx (_gTypes ctx) annVarVals annFragDefs let valCtx = ValidationCtx (_gTypes ctx) annVarVals annFragDefs
selSet <- flip runReaderT valCtx $ denormSelSet [] opRoot $ selSet <- flip runReaderT valCtx $ parseObjectSelectionSet valCtx opRoot $
G._todSelectionSet opDef G._todSelectionSet opDef
case G._todType opDef of case G._todType opDef of
G.OperationTypeQuery -> return $ RQuery selSet G.OperationTypeQuery -> return $ RQuery selSet
G.OperationTypeMutation -> return $ RMutation selSet G.OperationTypeMutation -> return $ RMutation selSet
G.OperationTypeSubscription -> G.OperationTypeSubscription ->
case Seq.viewl selSet of case OMap.toList $ unAliasedFields $ unObjectSelectionSet selSet of
Seq.EmptyL -> throw500 "empty selset for subscription" [] -> throw500 "empty selset for subscription"
fld Seq.:< rst -> do (_:rst) -> do
unless (null rst) $ -- As an internal testing feature, we support subscribing to multiple
throwVE "subscription must select only one top level field" -- selection sets. First check if the corresponding directive is set.
return $ RSubscription fld let multipleAllowed = G.Directive "_multiple_top_level_fields" [] `elem` G._todDirectives opDef
unless (multipleAllowed || null rst) $
throwVE "subscriptions must select one top level field"
return $ RSubscription selSet
isQueryInAllowlist :: GQLExecDoc -> HS.HashSet GQLQuery -> Bool isQueryInAllowlist :: GQLExecDoc -> HS.HashSet GQLQuery -> Bool
isQueryInAllowlist q = HS.member gqlQuery isQueryInAllowlist q = HS.member gqlQuery
@ -204,3 +211,119 @@ getQueryParts (GQLReq opNameM q varValsM) = do
return $ QueryParts opDef opRoot fragDefsL varValsM return $ QueryParts opDef opRoot fragDefsL varValsM
where where
(selSets, opDefs, fragDefsL) = G.partitionExDefs $ unGQLExecDoc q (selSets, opDefs, fragDefsL) = G.partitionExDefs $ unGQLExecDoc q
-- | Convert the validated arguments to GraphQL parser AST arguments
unValidateArgsMap :: ArgsMap -> [RemoteFieldArgument]
unValidateArgsMap argsMap =
map (\(n, inpVal) ->
let _rfaArgument = G.Argument n $ unValidateInpVal inpVal
_rfaVariable = unValidateInpVariable inpVal
in RemoteFieldArgument {..})
. Map.toList $ argsMap
-- | Convert the validated field to GraphQL parser AST field
unValidateField :: G.Alias -> Field -> G.Field
unValidateField alias (Field name _ argsMap selSet) =
let args = map (\(n, inpVal) -> G.Argument n $ unValidateInpVal inpVal) $
Map.toList argsMap
in G.Field (Just alias) name args [] $ unValidateSelectionSet selSet
-- | Convert the validated selection set to GraphQL parser AST selection set
unValidateSelectionSet :: SelectionSet -> G.SelectionSet
unValidateSelectionSet = \case
SelectionSetObject selectionSet -> fromSelectionSet selectionSet
SelectionSetInterface selectionSet -> fromScopedSelectionSet selectionSet
SelectionSetUnion selectionSet -> fromScopedSelectionSet selectionSet
SelectionSetNone -> mempty
where
fromAliasedFields :: (IsField f) => AliasedFields f -> G.SelectionSet
fromAliasedFields =
map (G.SelectionField . uncurry unValidateField) .
OMap.toList . fmap toField . unAliasedFields
fromSelectionSet =
fromAliasedFields . unObjectSelectionSet
toInlineSelection typeName =
G.SelectionInlineFragment . G.InlineFragment (Just typeName) mempty .
fromSelectionSet
fromScopedSelectionSet (ScopedSelectionSet base specific) =
map (uncurry toInlineSelection) (Map.toList specific) <> fromAliasedFields base
-- | Get the variable definition and it's value (if exists)
unValidateInpVariable :: AnnInpVal -> Maybe [(G.VariableDefinition,A.Value)]
unValidateInpVariable inputValue =
case (_aivValue inputValue) of
AGScalar _ _ -> mkVariableDefnValueTuple inputValue
AGEnum _ _ -> mkVariableDefnValueTuple inputValue
AGObject _ o ->
(\obj ->
let listObjects = OMap.toList obj
in concat $
mapMaybe (\(_, inpVal) -> unValidateInpVariable inpVal) listObjects)
<$> o
AGArray _ _ -> mkVariableDefnValueTuple inputValue
where
mkVariableDefnValueTuple val = maybe Nothing (\vars -> Just [vars]) $
variableDefnValueTuple val
variableDefnValueTuple :: AnnInpVal -> Maybe (G.VariableDefinition,A.Value)
variableDefnValueTuple inpVal@AnnInpVal {..} =
let varDefn = G.VariableDefinition <$> _aivVariable <*> Just _aivType <*> Just Nothing
in (,) <$> varDefn <*> Just (annInpValueToJson inpVal)
-- | Convert the validated input value to GraphQL value, if the input value
-- is a variable then it will be returned without resolving it, otherwise it
-- will be resolved
unValidateInpVal :: AnnInpVal -> G.Value
unValidateInpVal (AnnInpVal _ var val) = fromMaybe G.VNull $
-- if a variable is found, then directly return that, if not found then
-- convert it into a G.Value and return it
case var of
Just var' -> Just $ G.VVariable var'
Nothing ->
case val of
AGScalar _ v -> pgScalarToGValue <$> v
AGEnum _ v -> pgEnumToGEnum v
AGObject _ o ->
(G.VObject . G.ObjectValueG
. map (uncurry G.ObjectFieldG . (second unValidateInpVal))
. OMap.toList
) <$> o
AGArray _ vs -> (G.VList . G.ListValueG . map unValidateInpVal) <$> vs
where
pgEnumToGEnum :: AnnGEnumValue -> Maybe G.Value
pgEnumToGEnum = \case
AGESynthetic v -> G.VEnum <$> v
AGEReference _ v -> (G.VEnum . G.EnumValue . G.Name . getEnumValue) <$> v
pgScalarToGValue :: PGScalarValue -> G.Value
pgScalarToGValue = \case
PGValInteger i -> G.VInt $ fromIntegral i
PGValSmallInt i -> G.VInt $ fromIntegral i
PGValBigInt i -> G.VInt $ fromIntegral i
PGValFloat f -> G.VFloat $ realToFrac f
PGValDouble d -> G.VFloat $ realToFrac d
-- TODO: Scientific is a danger zone; use its safe conv function.
PGValNumeric sc -> G.VFloat $ realToFrac sc
PGValMoney m -> G.VFloat $ realToFrac m
PGValBoolean b -> G.VBoolean b
PGValChar t -> toStringValue $ T.singleton t
PGValVarchar t -> toStringValue t
PGValText t -> toStringValue t
PGValCitext t -> toStringValue t
PGValDate d -> toStringValue $ T.pack $ showGregorian d
PGValTimeStampTZ u -> toStringValue $ T.pack $
formatTime defaultTimeLocale "%FT%T%QZ" u
PGValTimeStamp u -> toStringValue $ T.pack $
formatTime defaultTimeLocale "%FT%T%QZ" u
PGValTimeTZ (ZonedTimeOfDay tod tz) ->
toStringValue $ T.pack (show tod ++ timeZoneOffsetString tz)
PGNull _ -> G.VNull
PGValJSON (Q.JSON v) -> jsonValueToGValue v
PGValJSONB (Q.JSONB v) -> jsonValueToGValue v
PGValGeo v -> jsonValueToGValue $ A.toJSON v
PGValRaster v -> jsonValueToGValue $ A.toJSON v
PGValUUID u -> toStringValue $ UUID.toText u
PGValUnknown t -> toStringValue t
where
toStringValue = G.VString . G.StringValue

View File

@ -4,6 +4,7 @@ module Hasura.GraphQL.Validate.Context
, getInpFieldInfo , getInpFieldInfo
, getTyInfo , getTyInfo
, getTyInfoVE , getTyInfoVE
, getFragmentTyInfo
, module Hasura.GraphQL.Utils , module Hasura.GraphQL.Utils
) where ) where
@ -19,11 +20,11 @@ import Hasura.RQL.Types
getFieldInfo getFieldInfo
:: ( MonadError QErr m) :: ( MonadError QErr m)
=> ObjTyInfo -> G.Name -> m ObjFldInfo => G.NamedType -> ObjFieldMap -> G.Name -> m ObjFldInfo
getFieldInfo oti fldName = getFieldInfo typeName fieldMap fldName =
onNothing (Map.lookup fldName $ _otiFields oti) $ throwVE $ onNothing (Map.lookup fldName fieldMap) $ throwVE $
"field " <> showName fldName <> "field " <> showName fldName <>
" not found in type: " <> showNamedTy (_otiName oti) " not found in type: " <> showNamedTy typeName
getInpFieldInfo getInpFieldInfo
:: ( MonadError QErr m) :: ( MonadError QErr m)
@ -65,3 +66,13 @@ getTyInfoVE namedTy = do
tyMap <- asks getter tyMap <- asks getter
onNothing (Map.lookup namedTy tyMap) $ onNothing (Map.lookup namedTy tyMap) $
throwVE $ "no such type exists in the schema: " <> showNamedTy namedTy throwVE $ "no such type exists in the schema: " <> showNamedTy namedTy
getFragmentTyInfo
:: (MonadReader r m, Has TypeMap r, MonadError QErr m)
=> G.NamedType -> m FragmentTypeInfo
getFragmentTyInfo onType =
getTyInfoVE onType >>= \case
TIObj tyInfo -> pure $ FragmentTyObject tyInfo
TIIFace tyInfo -> pure $ FragmentTyInterface tyInfo
TIUnion tyInfo -> pure $ FragmentTyUnion tyInfo
_ -> throwVE "fragments can only be defined on object/interface/union types"

View File

@ -0,0 +1,550 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Hasura.GraphQL.Validate.SelectionSet
( ArgsMap
, Field(..)
, AliasedFields(..)
, SelectionSet(..)
, ObjectSelectionSet(..)
, traverseObjectSelectionSet
, InterfaceSelectionSet
, UnionSelectionSet
, RootSelectionSet(..)
, parseObjectSelectionSet
, asObjectSelectionSet
, asInterfaceSelectionSet
, getMemberSelectionSet
) where
import Hasura.Prelude
import qualified Data.HashMap.Strict as Map
import qualified Data.HashMap.Strict.InsOrd.Extended as OMap
import qualified Data.HashSet as Set
import qualified Data.List as L
import qualified Data.Sequence.NonEmpty as NE
import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.GraphQL.NormalForm
import Hasura.GraphQL.Validate.Context
import Hasura.GraphQL.Validate.InputValue
import Hasura.GraphQL.Validate.Types
import Hasura.RQL.Types
import Hasura.SQL.Value
class HasSelectionSet a where
getTypename :: a -> G.NamedType
getMemberTypes :: a -> Set.HashSet G.NamedType
fieldToSelectionSet
:: G.Alias -> NormalizedField a -> NormalizedSelectionSet a
parseField_
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
, MonadState [G.Name] m
)
=> a
-> G.Field
-> m (Maybe (NormalizedField a))
mergeNormalizedSelectionSets
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
)
=> [NormalizedSelectionSet a]
-> m (NormalizedSelectionSet a)
fromObjectSelectionSet
:: G.NamedType
-- ^ parent typename
-> G.NamedType
-- ^ fragment typename
-> Set.HashSet G.NamedType
-- ^ common types
-> NormalizedSelectionSet ObjTyInfo
-> NormalizedSelectionSet a
fromInterfaceSelectionSet
:: G.NamedType
-- ^ parent typename
-> G.NamedType
-- ^ fragment typename
-> Set.HashSet G.NamedType
-> NormalizedSelectionSet IFaceTyInfo
-> NormalizedSelectionSet a
fromUnionSelectionSet
:: G.NamedType
-- ^ parent typename
-> G.NamedType
-- ^ fragment typename
-> Set.HashSet G.NamedType
-- ^ common types
-> NormalizedSelectionSet UnionTyInfo
-> NormalizedSelectionSet a
parseObjectSelectionSet
:: ( MonadError QErr m
, MonadReusability m
)
=> ValidationCtx
-> ObjTyInfo
-> G.SelectionSet
-> m ObjectSelectionSet
parseObjectSelectionSet validationCtx objectTypeInfo selectionSet =
flip evalStateT [] $ flip runReaderT validationCtx $
parseSelectionSet objectTypeInfo selectionSet
selectionToSelectionSet
:: HasSelectionSet a
=> NormalizedSelection a -> NormalizedSelectionSet a
selectionToSelectionSet = \case
SelectionField alias fld -> fieldToSelectionSet alias fld
SelectionInlineFragmentSpread selectionSet -> selectionSet
SelectionFragmentSpread _ selectionSet -> selectionSet
parseSelectionSet
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
, HasSelectionSet a
, MonadState [G.Name] m
)
=> a
-> G.SelectionSet
-> m (NormalizedSelectionSet a)
parseSelectionSet fieldTypeInfo selectionSet = do
visitedFragments <- get
withPathK "selectionSet" $ do
-- The visited fragments state shouldn't accumulate over a selection set.
normalizedSelections <-
catMaybes <$> mapM (parseSelection visitedFragments fieldTypeInfo) selectionSet
mergeNormalizedSelections normalizedSelections
where
mergeNormalizedSelections = mergeNormalizedSelectionSets . map selectionToSelectionSet
-- | While interfaces and objects have fields, unions do not, so
-- this is a specialized function for every Object type
parseSelection
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
, HasSelectionSet a
)
=> [G.Name]
-> a -- parent type info
-> G.Selection
-> m (Maybe (NormalizedSelection a))
parseSelection visitedFragments parentTypeInfo =
flip evalStateT visitedFragments . \case
G.SelectionField fld -> withPathK (G.unName $ G._fName fld) $ do
let fieldName = G._fName fld
fieldAlias = fromMaybe (G.Alias fieldName) $ G._fAlias fld
fmap (SelectionField fieldAlias) <$> parseField_ parentTypeInfo fld
G.SelectionFragmentSpread (G.FragmentSpread name directives) -> do
FragDef _ fragmentTyInfo fragmentSelectionSet <- getFragmentInfo name
withPathK (G.unName name) $
fmap (SelectionFragmentSpread name) <$>
parseFragment parentTypeInfo fragmentTyInfo directives fragmentSelectionSet
G.SelectionInlineFragment G.InlineFragment{..} -> do
let fragmentType = fromMaybe (getTypename parentTypeInfo) _ifTypeCondition
fragmentTyInfo <- getFragmentTyInfo fragmentType
withPathK "inlineFragment" $ fmap SelectionInlineFragmentSpread <$>
parseFragment parentTypeInfo fragmentTyInfo _ifDirectives _ifSelectionSet
parseFragment
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
, MonadState [G.Name] m
, HasSelectionSet a
)
=> a
-> FragmentTypeInfo
-> [G.Directive]
-> G.SelectionSet
-> m (Maybe (NormalizedSelectionSet a))
parseFragment parentTyInfo fragmentTyInfo directives fragmentSelectionSet = do
commonTypes <- validateSpread
case fragmentTyInfo of
FragmentTyObject objTyInfo ->
withDirectives directives $
fmap (fromObjectSelectionSet parentType fragmentType commonTypes) $
parseSelectionSet objTyInfo fragmentSelectionSet
FragmentTyInterface interfaceTyInfo ->
withDirectives directives $
fmap (fromInterfaceSelectionSet parentType fragmentType commonTypes) $
parseSelectionSet interfaceTyInfo fragmentSelectionSet
FragmentTyUnion unionTyInfo ->
withDirectives directives $
fmap (fromUnionSelectionSet parentType fragmentType commonTypes) $
parseSelectionSet unionTyInfo fragmentSelectionSet
where
validateSpread = do
let commonTypes = parentTypeMembers `Set.intersection` fragmentTypeMembers
if null commonTypes then
-- TODO: better error location by capturing the fragment source -
-- named or otherwise
-- throwVE $ "cannot spread fragment " <> showName name <> " defined on " <>
throwVE $ "cannot spread fragment defined on " <> showNamedTy fragmentType
<> " when selecting fields of type " <> showNamedTy parentType
else pure commonTypes
parentType = getTypename parentTyInfo
parentTypeMembers = getMemberTypes parentTyInfo
fragmentType = case fragmentTyInfo of
FragmentTyObject tyInfo -> getTypename tyInfo
FragmentTyInterface tyInfo -> getTypename tyInfo
FragmentTyUnion tyInfo -> getTypename tyInfo
fragmentTypeMembers = case fragmentTyInfo of
FragmentTyObject tyInfo -> getMemberTypes tyInfo
FragmentTyInterface tyInfo -> getMemberTypes tyInfo
FragmentTyUnion tyInfo -> getMemberTypes tyInfo
class IsField f => MergeableField f where
checkFieldMergeability
:: (MonadError QErr m) => G.Alias -> NE.NESeq f -> m f
instance MergeableField Field where
checkFieldMergeability alias fields = do
let groupedFlds = toList $ NE.toSeq fields
fldNames = L.nub $ map getFieldName groupedFlds
args = L.nub $ map getFieldArguments groupedFlds
when (length fldNames > 1) $
throwVE $ "cannot merge different fields under the same alias ("
<> showName (G.unAlias alias) <> "): "
<> showNames fldNames
when (length args > 1) $
throwVE $ "cannot merge fields with different arguments"
<> " under the same alias: "
<> showName (G.unAlias alias)
let fld = NE.head fields
mergedGroupSelectionSet <- mergeSelectionSets $ fmap _fSelSet fields
return $ fld { _fSelSet = mergedGroupSelectionSet }
instance MergeableField Typename where
checkFieldMergeability _ fields = pure $ NE.head fields
parseArguments
:: ( MonadReader ValidationCtx m
, MonadError QErr m
)
=> ParamMap
-> [G.Argument]
-> m ArgsMap
parseArguments fldParams argsL = do
args <- onLeft (mkMapWith G._aName argsL) $ \dups ->
throwVE $ "the following arguments are defined more than once: " <>
showNames dups
let requiredParams = Map.filter (G.isNotNull . _iviType) fldParams
inpArgs <- forM args $ \(G.Argument argName argVal) ->
withPathK (G.unName argName) $ do
argTy <- getArgTy argName
validateInputValue valueParser argTy argVal
forM_ requiredParams $ \argDef -> do
let param = _iviName argDef
onNothing (Map.lookup param inpArgs) $ throwVE $ mconcat
[ "the required argument ", showName param, " is missing"]
return inpArgs
where
getArgTy argName =
onNothing (_iviType <$> Map.lookup argName fldParams) $ throwVE $
"no such argument " <> showName argName <> " is expected"
mergeFields
:: ( MonadError QErr m
, MergeableField f
)
-- => Seq.Seq Field
=> [AliasedFields f]
-> m (AliasedFields f)
mergeFields flds =
AliasedFields <$> OMap.traverseWithKey checkFieldMergeability groups
where
groups = foldr (OMap.unionWith (<>)) mempty $
map (fmap NE.init . unAliasedFields) flds
appendSelectionSets
:: (MonadError QErr m) => SelectionSet -> SelectionSet -> m SelectionSet
appendSelectionSets = curry \case
(SelectionSetObject s1, SelectionSetObject s2) ->
SelectionSetObject <$> mergeObjectSelectionSets [s1, s2]
(SelectionSetInterface s1, SelectionSetInterface s2) ->
SelectionSetInterface <$> appendScopedSelectionSet s1 s2
(SelectionSetUnion s1, SelectionSetUnion s2) ->
SelectionSetUnion <$> appendScopedSelectionSet s1 s2
(SelectionSetNone, SelectionSetNone) -> pure SelectionSetNone
(_, _) -> throw500 $ "mergeSelectionSets: 'same kind' assertion failed"
-- query q {
-- author {
-- id
-- }
-- author {
-- name
-- }
-- }
--
-- | When we are merging two selection sets down two different trees they
-- should be of the same type, however, as it is not enforced in the type
-- system, an internal error is thrown when this assumption is violated
mergeSelectionSets
:: (MonadError QErr m) => NE.NESeq SelectionSet -> m SelectionSet
-- mergeSelectionSets = curry $ \case
mergeSelectionSets selectionSets =
foldM appendSelectionSets (NE.head selectionSets) $ NE.tail selectionSets
mergeObjectSelectionSets
:: (MonadError QErr m) => [ObjectSelectionSet] -> m ObjectSelectionSet
mergeObjectSelectionSets =
fmap ObjectSelectionSet . mergeFields . map unObjectSelectionSet
mergeObjectSelectionSetMaps
:: (MonadError QErr m) => [ObjectSelectionSetMap] -> m ObjectSelectionSetMap
mergeObjectSelectionSetMaps selectionSetMaps =
traverse mergeObjectSelectionSets $
foldr (Map.unionWith (<>)) mempty $ map (fmap (:[])) selectionSetMaps
appendScopedSelectionSet
:: (MonadError QErr m, MergeableField f)
=> ScopedSelectionSet f -> ScopedSelectionSet f -> m (ScopedSelectionSet f)
appendScopedSelectionSet s1 s2 =
ScopedSelectionSet
<$> mergeFields [_sssBaseSelectionSet s1, _sssBaseSelectionSet s2]
<*> mergeObjectSelectionSetMaps [s1MembersUnified, s2MembersUnified]
where
s1Base = fmap toField $ _sssBaseSelectionSet s1
s2Base = fmap toField $ _sssBaseSelectionSet s2
s1MembersUnified =
(_sssMemberSelectionSets s1)
<> fmap (const (ObjectSelectionSet s1Base)) (_sssMemberSelectionSets s2)
s2MembersUnified =
(_sssMemberSelectionSets s2)
<> fmap (const (ObjectSelectionSet s2Base)) (_sssMemberSelectionSets s1)
mergeScopedSelectionSets
:: (MonadError QErr m, MergeableField f)
=> [ScopedSelectionSet f] -> m (ScopedSelectionSet f)
mergeScopedSelectionSets selectionSets =
foldM appendScopedSelectionSet emptyScopedSelectionSet selectionSets
withDirectives
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
)
=> [G.Directive]
-> m a
-> m (Maybe a)
withDirectives dirs act = do
procDirs <- withPathK "directives" $ do
dirDefs <- onLeft (mkMapWith G._dName dirs) $ \dups ->
throwVE $ "the following directives are used more than once: " <>
showNames dups
flip Map.traverseWithKey dirDefs $ \name dir ->
withPathK (G.unName name) $ do
dirInfo <- onNothing (Map.lookup (G._dName dir) defDirectivesMap) $
throwVE $ "unexpected directive: " <> showName name
procArgs <- withPathK "args" $ parseArguments (_diParams dirInfo)
(G._dArguments dir)
getIfArg procArgs
let shouldSkip = fromMaybe False $ Map.lookup "skip" procDirs
shouldInclude = fromMaybe True $ Map.lookup "include" procDirs
if not shouldSkip && shouldInclude
then Just <$> act
else return Nothing
where
getIfArg m = do
val <- onNothing (Map.lookup "if" m) $ throw500
"missing if argument in the directive"
when (isJust $ _aivVariable val) markNotReusable
case _aivValue val of
AGScalar _ (Just (PGValBoolean v)) -> return v
_ -> throw500 "did not find boolean scalar for if argument"
getFragmentInfo
:: (MonadReader ValidationCtx m, MonadError QErr m, MonadState [G.Name] m)
=> G.Name
-- ^ fragment name
-> m FragDef
getFragmentInfo name = do
-- check for cycles
visitedFragments <- get
if name `elem` visitedFragments
then throwVE $ "cannot spread fragment " <> showName name
<> " within itself via "
<> T.intercalate "," (map G.unName visitedFragments)
else put $ name:visitedFragments
fragInfo <- Map.lookup name <$> asks _vcFragDefMap
onNothing fragInfo $ throwVE $ "fragment '" <> G.unName name <> "' not found"
denormalizeField
:: ( MonadReader ValidationCtx m
, MonadError QErr m
, MonadReusability m
, MonadState [G.Name] m
)
=> ObjFldInfo
-> G.Field
-> m (Maybe Field)
denormalizeField fldInfo (G.Field _ name args dirs selSet) = do
let fldTy = _fiTy fldInfo
fldBaseTy = getBaseTy fldTy
fldTyInfo <- getTyInfo fldBaseTy
argMap <- withPathK "args" $ parseArguments (_fiParams fldInfo) args
fields <- case (fldTyInfo, selSet) of
(TIObj _, []) ->
throwVE $ "field " <> showName name <> " of type "
<> G.showGT fldTy <> " must have a selection of subfields"
(TIObj objTyInfo, _) ->
SelectionSetObject <$> parseSelectionSet objTyInfo selSet
(TIIFace _, []) ->
throwVE $ "field " <> showName name <> " of type "
<> G.showGT fldTy <> " must have a selection of subfields"
(TIIFace interfaceTyInfo, _) ->
SelectionSetInterface <$> parseSelectionSet interfaceTyInfo selSet
(TIUnion _, []) ->
throwVE $ "field " <> showName name <> " of type "
<> G.showGT fldTy <> " must have a selection of subfields"
(TIUnion unionTyInfo, _) ->
SelectionSetUnion <$> parseSelectionSet unionTyInfo selSet
(TIScalar _, []) -> return SelectionSetNone
-- when scalar/enum and no empty set
(TIScalar _, _) ->
throwVE $ "field " <> showName name <> " must not have a "
<> "selection since type " <> G.showGT fldTy <> " has no subfields"
(TIEnum _, []) -> return SelectionSetNone
(TIEnum _, _) ->
throwVE $ "field " <> showName name <> " must not have a "
<> "selection since type " <> G.showGT fldTy <> " has no subfields"
(TIInpObj _, _) ->
throwVE $ "internal error: unexpected input type for field: "
<> showName name
withDirectives dirs $ pure $ Field name fldBaseTy argMap fields
type instance NormalizedSelectionSet ObjTyInfo = ObjectSelectionSet
type instance NormalizedField ObjTyInfo = Field
instance HasSelectionSet ObjTyInfo where
getTypename = _otiName
getMemberTypes = Set.singleton . _otiName
parseField_ objTyInfo field = do
fieldInfo <- getFieldInfo (_otiName objTyInfo) (_otiFields objTyInfo) $ G._fName field
denormalizeField fieldInfo field
fieldToSelectionSet alias fld =
ObjectSelectionSet $ AliasedFields $ OMap.singleton alias fld
mergeNormalizedSelectionSets = mergeObjectSelectionSets
fromObjectSelectionSet _ _ _ objectSelectionSet =
objectSelectionSet
fromInterfaceSelectionSet parentType _ _ interfaceSelectionSet =
getMemberSelectionSet parentType interfaceSelectionSet
fromUnionSelectionSet parentType _ _ unionSelectionSet =
getMemberSelectionSet parentType unionSelectionSet
type instance NormalizedSelectionSet IFaceTyInfo = InterfaceSelectionSet
type instance NormalizedField IFaceTyInfo = Field
instance HasSelectionSet IFaceTyInfo where
getTypename = _ifName
getMemberTypes = _ifMemberTypes
parseField_ interfaceTyInfo field = do
fieldInfo <- getFieldInfo (_ifName interfaceTyInfo) (_ifFields interfaceTyInfo)
$ G._fName field
denormalizeField fieldInfo field
fieldToSelectionSet alias field =
ScopedSelectionSet (AliasedFields $ OMap.singleton alias field) mempty
mergeNormalizedSelectionSets = mergeScopedSelectionSets
fromObjectSelectionSet _ fragmentType _ objectSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.singleton fragmentType objectSelectionSet
fromInterfaceSelectionSet _ _ commonTypes interfaceSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.fromList $ flip map (toList commonTypes) $
\commonType -> (commonType, getMemberSelectionSet commonType interfaceSelectionSet)
fromUnionSelectionSet _ _ commonTypes unionSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.fromList $ flip map (toList commonTypes) $
\commonType -> (commonType, getMemberSelectionSet commonType unionSelectionSet)
type instance NormalizedSelectionSet UnionTyInfo = UnionSelectionSet
type instance NormalizedField UnionTyInfo = Typename
instance HasSelectionSet UnionTyInfo where
getTypename = _utiName
getMemberTypes = _utiMemberTypes
parseField_ unionTyInfo field = do
let fieldMap = Map.singleton (_fiName typenameFld) typenameFld
fieldInfo <- getFieldInfo (_utiName unionTyInfo) fieldMap $ G._fName field
fmap (const Typename) <$> denormalizeField fieldInfo field
fieldToSelectionSet alias field =
ScopedSelectionSet (AliasedFields $ OMap.singleton alias field) mempty
mergeNormalizedSelectionSets = mergeScopedSelectionSets
fromObjectSelectionSet _ fragmentType _ objectSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.singleton fragmentType objectSelectionSet
fromInterfaceSelectionSet _ _ commonTypes interfaceSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.fromList $ flip map (toList commonTypes) $
\commonType -> (commonType, getMemberSelectionSet commonType interfaceSelectionSet)
fromUnionSelectionSet _ _ commonTypes unionSelectionSet =
ScopedSelectionSet (AliasedFields mempty) $
Map.fromList $ flip map (toList commonTypes) $
\commonType -> (commonType, getMemberSelectionSet commonType unionSelectionSet)

View File

@ -0,0 +1,812 @@
{-# LANGUAGE GADTs #-}
module Hasura.GraphQL.Validate.Types
( InpValInfo(..)
, ParamMap
, typenameFld
, ObjFldInfo(..)
, mkHsraObjFldInfo
, ObjFieldMap
-- Don't expose 'ObjTyInfo' constructor. Instead use 'mkObjTyInfo' or 'mkHsraObjTyInfo'
-- which will auto-insert the compulsory '__typename' field.
, ObjTyInfo
, _otiDesc
, _otiName
, _otiImplIFaces
, _otiFields
, mkObjTyInfo
, mkHsraObjTyInfo
-- Don't expose 'IFaceTyInfo' constructor. Instead use 'mkIFaceTyInfo'
-- which will auto-insert the compulsory '__typename' field.
, IFaceTyInfo
, _ifDesc
, _ifName
, _ifFields
, _ifMemberTypes
, mkIFaceTyInfo
, IFacesSet
, UnionTyInfo(..)
, FragDef(..)
, FragmentTypeInfo(..)
, FragDefMap
, AnnVarVals
, AnnInpVal(..)
, EnumTyInfo(..)
, mkHsraEnumTyInfo
, EnumValuesInfo(..)
, normalizeEnumValues
, EnumValInfo(..)
, InpObjFldMap
, InpObjTyInfo(..)
, mkHsraInpTyInfo
, ScalarTyInfo(..)
, fromScalarTyDef
, mkHsraScalarTyInfo
, DirectiveInfo(..)
, AsObjType(..)
, defaultDirectives
, defDirectivesMap
, defaultSchema
, TypeInfo(..)
, isObjTy
, isIFaceTy
, getPossibleObjTypes
, getObjTyM
, getUnionTyM
, mkScalarTy
, pgColTyToScalar
, getNamedTy
, mkTyInfoMap
, fromTyDef
, fromSchemaDoc
, fromSchemaDocQ
, TypeMap
, TypeLoc (..)
, typeEq
, AnnGValue(..)
, AnnGEnumValue(..)
, AnnGObject
, hasNullVal
, getAnnInpValKind
, stripTypenames
, ReusableVariableTypes(..)
, ReusableVariableValues
, QueryReusability(..)
, _Reusable
, _NotReusable
, MonadReusability(..)
, ReusabilityT
, runReusabilityT
, runReusabilityTWith
, evalReusabilityT
, module Hasura.GraphQL.Utils
) where
import Hasura.Prelude
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.HashSet as Set
import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Language.GraphQL.Draft.TH as G
import qualified Language.Haskell.TH.Syntax as TH
import Control.Lens (makePrisms)
import qualified Hasura.RQL.Types.Column as RQL
import Hasura.GraphQL.NormalForm
import Hasura.GraphQL.Utils
import Hasura.RQL.Instances ()
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.RemoteSchema (RemoteSchemaInfo, RemoteSchemaName)
import Hasura.SQL.Types
import Hasura.SQL.Value
typeEq :: (EquatableGType a, Eq (EqProps a)) => a -> a -> Bool
typeEq a b = getEqProps a == getEqProps b
data EnumValInfo
= EnumValInfo
{ _eviDesc :: !(Maybe G.Description)
, _eviVal :: !G.EnumValue
, _eviIsDeprecated :: !Bool
} deriving (Show, Eq, TH.Lift)
fromEnumValDef :: G.EnumValueDefinition -> EnumValInfo
fromEnumValDef (G.EnumValueDefinition descM val _) =
EnumValInfo descM val False
data EnumValuesInfo
= EnumValuesSynthetic !(Map.HashMap G.EnumValue EnumValInfo)
-- ^ Values for an enum that exists only in the GraphQL schema and does not
-- have any external source of truth.
| EnumValuesReference !RQL.EnumReference
-- ^ Values for an enum that is backed by an enum table reference (see
-- "Hasura.RQL.Schema.Enum").
deriving (Show, Eq, TH.Lift)
normalizeEnumValues :: EnumValuesInfo -> Map.HashMap G.EnumValue EnumValInfo
normalizeEnumValues = \case
EnumValuesSynthetic values -> values
EnumValuesReference (RQL.EnumReference _ values) ->
mapFromL _eviVal . flip map (Map.toList values) $
\(RQL.EnumValue name, RQL.EnumValueInfo maybeDescription) -> EnumValInfo
{ _eviVal = G.EnumValue $ G.Name name
, _eviDesc = G.Description <$> maybeDescription
, _eviIsDeprecated = False }
data EnumTyInfo
= EnumTyInfo
{ _etiDesc :: !(Maybe G.Description)
, _etiName :: !G.NamedType
, _etiValues :: !EnumValuesInfo
, _etiLoc :: !TypeLoc
} deriving (Show, Eq, TH.Lift)
instance EquatableGType EnumTyInfo where
type EqProps EnumTyInfo = (G.NamedType, Map.HashMap G.EnumValue EnumValInfo)
getEqProps ety = (,) (_etiName ety) (normalizeEnumValues $ _etiValues ety)
fromEnumTyDef :: G.EnumTypeDefinition -> TypeLoc -> EnumTyInfo
fromEnumTyDef (G.EnumTypeDefinition descM n _ valDefs) loc =
EnumTyInfo descM (G.NamedType n) (EnumValuesSynthetic enumVals) loc
where
enumVals = Map.fromList
[(G._evdName valDef, fromEnumValDef valDef) | valDef <- valDefs]
mkHsraEnumTyInfo
:: Maybe G.Description
-> G.NamedType
-> EnumValuesInfo
-> EnumTyInfo
mkHsraEnumTyInfo descM ty enumVals =
EnumTyInfo descM ty enumVals TLHasuraType
fromInpValDef :: G.InputValueDefinition -> InpValInfo
fromInpValDef (G.InputValueDefinition descM n ty defM) =
InpValInfo descM n defM ty
type ParamMap = Map.HashMap G.Name InpValInfo
-- | location of the type: a hasura type or a remote type
data TypeLoc
= TLHasuraType
| TLRemoteType !RemoteSchemaName !RemoteSchemaInfo
| TLCustom
deriving (Show, Eq, TH.Lift, Generic)
$(J.deriveJSON
J.defaultOptions { J.constructorTagModifier = J.snakeCase . drop 2
, J.sumEncoding = J.TaggedObject "type" "detail"
}
''TypeLoc)
instance Hashable TypeLoc
data ObjFldInfo
= ObjFldInfo
{ _fiDesc :: !(Maybe G.Description)
, _fiName :: !G.Name
, _fiParams :: !ParamMap
, _fiTy :: !G.GType
, _fiLoc :: !TypeLoc
} deriving (Show, Eq, TH.Lift)
instance EquatableGType ObjFldInfo where
type EqProps ObjFldInfo = (G.Name, G.GType, ParamMap)
getEqProps o = (,,) (_fiName o) (_fiTy o) (_fiParams o)
fromFldDef :: G.FieldDefinition -> TypeLoc -> ObjFldInfo
fromFldDef (G.FieldDefinition descM n args ty _) loc =
ObjFldInfo descM n params ty loc
where
params = Map.fromList [(G._ivdName arg, fromInpValDef arg) | arg <- args]
mkHsraObjFldInfo
:: Maybe G.Description
-> G.Name
-> ParamMap
-> G.GType
-> ObjFldInfo
mkHsraObjFldInfo descM name params ty =
ObjFldInfo descM name params ty TLHasuraType
type ObjFieldMap = Map.HashMap G.Name ObjFldInfo
type IFacesSet = Set.HashSet G.NamedType
data ObjTyInfo
= ObjTyInfo
{ _otiDesc :: !(Maybe G.Description)
, _otiName :: !G.NamedType
, _otiImplIFaces :: !IFacesSet
, _otiFields :: !ObjFieldMap
} deriving (Show, Eq, TH.Lift)
instance EquatableGType ObjTyInfo where
type EqProps ObjTyInfo =
(G.NamedType, Set.HashSet G.NamedType, Map.HashMap G.Name (G.Name, G.GType, ParamMap))
getEqProps a = (,,) (_otiName a) (_otiImplIFaces a) (Map.map getEqProps (_otiFields a))
instance Monoid ObjTyInfo where
mempty = ObjTyInfo Nothing (G.NamedType "") Set.empty Map.empty
instance Semigroup ObjTyInfo where
objA <> objB =
objA { _otiFields = Map.union (_otiFields objA) (_otiFields objB)
, _otiImplIFaces = _otiImplIFaces objA `Set.union` _otiImplIFaces objB
}
mkObjTyInfo
:: Maybe G.Description -> G.NamedType
-> IFacesSet -> ObjFieldMap -> TypeLoc -> ObjTyInfo
mkObjTyInfo descM ty iFaces flds _ =
ObjTyInfo descM ty iFaces $ Map.insert (_fiName newFld) newFld flds
where newFld = typenameFld
mkHsraObjTyInfo
:: Maybe G.Description
-> G.NamedType
-> IFacesSet
-> ObjFieldMap
-> ObjTyInfo
mkHsraObjTyInfo descM ty implIFaces flds =
mkObjTyInfo descM ty implIFaces flds TLHasuraType
mkIFaceTyInfo
:: Maybe G.Description -> G.NamedType
-> Map.HashMap G.Name ObjFldInfo -> MemberTypes -> IFaceTyInfo
mkIFaceTyInfo descM ty flds =
IFaceTyInfo descM ty $ Map.insert (_fiName newFld) newFld flds
where
newFld = typenameFld
typenameFld :: ObjFldInfo
typenameFld =
ObjFldInfo (Just desc) "__typename" Map.empty
(G.toGT $ G.toNT $ G.NamedType "String") TLHasuraType
where
desc = "The name of the current Object type at runtime"
fromObjTyDef :: G.ObjectTypeDefinition -> TypeLoc -> ObjTyInfo
fromObjTyDef (G.ObjectTypeDefinition descM n ifaces _ flds) loc =
mkObjTyInfo descM (G.NamedType n) (Set.fromList ifaces) fldMap loc
where
fldMap = Map.fromList [(G._fldName fld, fromFldDef fld loc) | fld <- flds]
data IFaceTyInfo
= IFaceTyInfo
{ _ifDesc :: !(Maybe G.Description)
, _ifName :: !G.NamedType
, _ifFields :: !ObjFieldMap
, _ifMemberTypes :: !MemberTypes
} deriving (Show, Eq, TH.Lift)
instance EquatableGType IFaceTyInfo where
type EqProps IFaceTyInfo =
(G.NamedType, Map.HashMap G.Name (G.Name, G.GType, ParamMap))
getEqProps a = (,) (_ifName a) (Map.map getEqProps (_ifFields a))
instance Semigroup IFaceTyInfo where
objA <> objB =
objA { _ifFields = Map.union (_ifFields objA) (_ifFields objB)
}
fromIFaceDef
:: InterfaceImplementations -> G.InterfaceTypeDefinition -> TypeLoc -> IFaceTyInfo
fromIFaceDef interfaceImplementations (G.InterfaceTypeDefinition descM n _ flds) loc =
mkIFaceTyInfo descM (G.NamedType n) fldMap implementations
where
fldMap = Map.fromList [(G._fldName fld, fromFldDef fld loc) | fld <- flds]
implementations = fromMaybe mempty $ Map.lookup (G.NamedType n) interfaceImplementations
type MemberTypes = Set.HashSet G.NamedType
data UnionTyInfo
= UnionTyInfo
{ _utiDesc :: !(Maybe G.Description)
, _utiName :: !G.NamedType
, _utiMemberTypes :: !MemberTypes
} deriving (Show, Eq, TH.Lift)
instance EquatableGType UnionTyInfo where
type EqProps UnionTyInfo =
(G.NamedType, Set.HashSet G.NamedType)
getEqProps a = (,) (_utiName a) (_utiMemberTypes a)
instance Monoid UnionTyInfo where
mempty = UnionTyInfo Nothing (G.NamedType "") Set.empty
instance Semigroup UnionTyInfo where
objA <> objB =
objA { _utiMemberTypes = Set.union (_utiMemberTypes objA) (_utiMemberTypes objB)
}
fromUnionTyDef :: G.UnionTypeDefinition -> UnionTyInfo
fromUnionTyDef (G.UnionTypeDefinition descM n _ mt) = UnionTyInfo descM (G.NamedType n) $ Set.fromList mt
type InpObjFldMap = Map.HashMap G.Name InpValInfo
data InpObjTyInfo
= InpObjTyInfo
{ _iotiDesc :: !(Maybe G.Description)
, _iotiName :: !G.NamedType
, _iotiFields :: !InpObjFldMap
, _iotiLoc :: !TypeLoc
} deriving (Show, Eq, TH.Lift)
instance EquatableGType InpObjTyInfo where
type EqProps InpObjTyInfo = (G.NamedType, Map.HashMap G.Name (G.Name, G.GType))
getEqProps a = (,) (_iotiName a) (Map.map getEqProps $ _iotiFields a)
fromInpObjTyDef :: G.InputObjectTypeDefinition -> TypeLoc -> InpObjTyInfo
fromInpObjTyDef (G.InputObjectTypeDefinition descM n _ inpFlds) loc =
InpObjTyInfo descM (G.NamedType n) fldMap loc
where
fldMap = Map.fromList
[(G._ivdName inpFld, fromInpValDef inpFld) | inpFld <- inpFlds]
mkHsraInpTyInfo
:: Maybe G.Description
-> G.NamedType
-> InpObjFldMap
-> InpObjTyInfo
mkHsraInpTyInfo descM ty flds =
InpObjTyInfo descM ty flds TLHasuraType
data ScalarTyInfo
= ScalarTyInfo
{ _stiDesc :: !(Maybe G.Description)
, _stiName :: !G.Name
, _stiType :: !PGScalarType
, _stiLoc :: !TypeLoc
} deriving (Show, Eq, TH.Lift)
mkHsraScalarTyInfo :: PGScalarType -> ScalarTyInfo
mkHsraScalarTyInfo ty =
ScalarTyInfo Nothing (G.Name $ pgColTyToScalar ty) ty TLHasuraType
instance EquatableGType ScalarTyInfo where
type EqProps ScalarTyInfo = PGScalarType
getEqProps = _stiType
fromScalarTyDef
:: G.ScalarTypeDefinition
-> TypeLoc
-> ScalarTyInfo
fromScalarTyDef (G.ScalarTypeDefinition descM n _) =
ScalarTyInfo descM n ty
where
ty = case n of
"Int" -> PGInteger
"Float" -> PGFloat
"String" -> PGText
"Boolean" -> PGBoolean
"ID" -> PGText
_ -> textToPGScalarType $ G.unName n
data TypeInfo
= TIScalar !ScalarTyInfo
| TIObj !ObjTyInfo
| TIEnum !EnumTyInfo
| TIInpObj !InpObjTyInfo
| TIIFace !IFaceTyInfo
| TIUnion !UnionTyInfo
deriving (Show, Eq, TH.Lift)
instance J.ToJSON TypeInfo where
toJSON _ = J.String "toJSON not implemented for TypeInfo"
data AsObjType
= AOTIFace IFaceTyInfo
| AOTUnion UnionTyInfo
getPossibleObjTypes :: TypeMap -> AsObjType -> Map.HashMap G.NamedType ObjTyInfo
getPossibleObjTypes tyMap = \case
(AOTIFace i) ->
toObjMap $ mapMaybe (extrObjTyInfoM tyMap) $ Set.toList $ _ifMemberTypes i
(AOTUnion u) ->
toObjMap $ mapMaybe (extrObjTyInfoM tyMap) $ Set.toList $ _utiMemberTypes u
-- toObjMap $ mapMaybe previewImplTypeM $ Map.elems tyMap
-- where
-- previewImplTypeM = \case
-- TIObj objTyInfo -> bool Nothing (Just objTyInfo) $
-- _ifName i `elem` _otiImplIFaces objTyInfo
-- _ -> Nothing
toObjMap :: [ObjTyInfo] -> Map.HashMap G.NamedType ObjTyInfo
toObjMap = foldr (\o -> Map.insert (_otiName o) o) Map.empty
isObjTy :: TypeInfo -> Bool
isObjTy = \case
(TIObj _) -> True
_ -> False
getObjTyM :: TypeInfo -> Maybe ObjTyInfo
getObjTyM = \case
(TIObj t) -> return t
_ -> Nothing
getUnionTyM :: TypeInfo -> Maybe UnionTyInfo
getUnionTyM = \case
(TIUnion u) -> return u
_ -> Nothing
isIFaceTy :: TypeInfo -> Bool
isIFaceTy = \case
(TIIFace _) -> True
_ -> False
data SchemaPath
= SchemaPath
{ _spTypeName :: !(Maybe G.NamedType)
, _spFldName :: !(Maybe G.Name)
, _spArgName :: !(Maybe G.Name)
, _spType :: !(Maybe T.Text)
}
setFldNameSP :: SchemaPath -> G.Name -> SchemaPath
setFldNameSP sp fn = sp { _spFldName = Just fn}
setArgNameSP :: SchemaPath -> G.Name -> SchemaPath
setArgNameSP sp an = sp { _spArgName = Just an}
showSP :: SchemaPath -> Text
showSP (SchemaPath t f a _) = maybe "" (\x -> showNamedTy x <> fN) t
where
fN = maybe "" (\x -> "." <> showName x <> aN) f
aN = maybe "" showArg a
showArg x = "(" <> showName x <> ":)"
showSPTxt' :: SchemaPath -> Text
showSPTxt' (SchemaPath _ f a t) = maybe "" (<> " "<> fld) t
where
fld = maybe "" (const $ "field " <> arg) f
arg = maybe "" (const "argument ") a
showSPTxt :: SchemaPath -> Text
showSPTxt p = showSPTxt' p <> showSP p
validateIFace :: MonadError Text f => IFaceTyInfo -> f ()
validateIFace (IFaceTyInfo _ n flds _) =
when (isFldListEmpty flds) $ throwError $ "List of fields cannot be empty for interface " <> showNamedTy n
validateObj :: TypeMap -> ObjTyInfo -> Either Text ()
validateObj tyMap objTyInfo@(ObjTyInfo _ n _ flds) = do
when (isFldListEmpty flds) $ throwError $ "List of fields cannot be empty for " <> objTxt
mapM_ (extrIFaceTyInfo' >=> validateIFaceImpl objTyInfo) $ _otiImplIFaces objTyInfo
where
extrIFaceTyInfo' t = withObjTxt $ extrIFaceTyInfo tyMap t
withObjTxt x = x `catchError` \e -> throwError $ e <> " implemented by " <> objTxt
objTxt = "Object type " <> showNamedTy n
validateIFaceImpl = implmntsIFace tyMap
isFldListEmpty :: ObjFieldMap -> Bool
isFldListEmpty = Map.null . Map.delete "__typename"
validateUnion :: MonadError Text m => TypeMap -> UnionTyInfo -> m ()
validateUnion tyMap (UnionTyInfo _ un mt) = do
when (Set.null mt) $ throwError $ "List of member types cannot be empty for union type " <> showNamedTy un
mapM_ valIsObjTy $ Set.toList mt
where
valIsObjTy mn = case Map.lookup mn tyMap of
Just (TIObj t) -> return t
Nothing -> throwError $ "Could not find type " <> showNamedTy mn <> ", which is defined as a member type of Union " <> showNamedTy un
_ -> throwError $ "Union type " <> showNamedTy un <> " can only include object types. It cannot include " <> showNamedTy mn
implmntsIFace :: TypeMap -> ObjTyInfo -> IFaceTyInfo -> Either Text ()
implmntsIFace tyMap objTyInfo iFaceTyInfo = do
let path =
( SchemaPath (Just $ _otiName objTyInfo) Nothing Nothing (Just "Object")
, SchemaPath (Just $ _ifName iFaceTyInfo) Nothing Nothing (Just "Interface")
)
mapM_ (includesIFaceFld path) $ _ifFields iFaceTyInfo
where
includesIFaceFld (spO,spIF) ifFld = do
let pathA@(spOA, spIFA) = (spO, setFldNameSP spIF $ _fiName ifFld)
objFld <- sameNameFld pathA ifFld
let pathB = (setFldNameSP spOA $ _fiName objFld, spIFA)
validateIsSubType' pathB (_fiTy objFld) (_fiTy ifFld)
hasAllArgs pathB objFld ifFld
isExtraArgsNullable pathB objFld ifFld
validateIsSubType' (spO,spIF) oFld iFld = validateIsSubType tyMap oFld iFld `catchError` \_ ->
throwError $ "The type of " <> showSPTxt spO <> " (" <> G.showGT oFld <>
") is not the same type/sub type of " <> showSPTxt spIF <> " (" <> G.showGT iFld <> ")"
sameNameFld (spO, spIF) ifFld = do
let spIFN = setFldNameSP spIF $ _fiName ifFld
onNothing (Map.lookup (_fiName ifFld) objFlds)
$ throwError $ showSPTxt spIFN <> " expected, but " <> showSP spO <> " does not provide it"
hasAllArgs (spO, spIF) objFld ifFld = forM_ (_fiParams ifFld) $ \ifArg -> do
objArg <- sameNameArg ifArg
let (spON, spIFN) = (setArgNameSP spO $ _iviName objArg, setArgNameSP spIF $ _iviName ifArg)
unless (_iviType objArg == _iviType ifArg) $ throwError $
showSPTxt spIFN <> " expects type " <> G.showGT (_iviType ifArg) <> ", but " <>
showSP spON <> " has type " <> G.showGT (_iviType objArg)
where
sameNameArg ivi = do
let spIFN = setArgNameSP spIF $ _iviName ivi
onNothing (Map.lookup (_iviName ivi) objArgs) $ throwError $ showSPTxt spIFN <> " required, but " <>
showSPTxt spO <> " does not provide it"
objArgs = _fiParams objFld
isExtraArgsNullable (spO, spIF) objFld ifFld = forM_ extraArgs isInpValNullable
where
extraArgs = Map.difference (_fiParams objFld) (_fiParams ifFld)
isInpValNullable ivi = unless (G.isNullable $ _iviType ivi) $ throwError $
showSPTxt (setArgNameSP spO $ _iviName ivi) <> " is of required type "
<> G.showGT (_iviType ivi) <> ", but is not provided by " <> showSPTxt spIF
objFlds = _otiFields objTyInfo
extrTyInfo :: TypeMap -> G.NamedType -> Either Text TypeInfo
extrTyInfo tyMap tn = maybe
(throwError $ "Could not find type with name " <> showNamedTy tn)
return
$ Map.lookup tn tyMap
extrIFaceTyInfo :: MonadError Text m => Map.HashMap G.NamedType TypeInfo -> G.NamedType -> m IFaceTyInfo
extrIFaceTyInfo tyMap tn = case Map.lookup tn tyMap of
Just (TIIFace i) -> return i
_ -> throwError $ "Could not find interface " <> showNamedTy tn
extrObjTyInfoM :: TypeMap -> G.NamedType -> Maybe ObjTyInfo
extrObjTyInfoM tyMap tn = case Map.lookup tn tyMap of
Just (TIObj o) -> return o
_ -> Nothing
validateIsSubType :: Map.HashMap G.NamedType TypeInfo -> G.GType -> G.GType -> Either Text ()
validateIsSubType tyMap subFldTy supFldTy = do
checkNullMismatch subFldTy supFldTy
case (subFldTy,supFldTy) of
(G.TypeNamed _ subTy, G.TypeNamed _ supTy) -> do
subTyInfo <- extrTyInfo tyMap subTy
supTyInfo <- extrTyInfo tyMap supTy
isSubTypeBase subTyInfo supTyInfo
(G.TypeList _ (G.ListType sub), G.TypeList _ (G.ListType sup) ) ->
validateIsSubType tyMap sub sup
_ -> throwError $ showIsListTy subFldTy <> " Type " <> G.showGT subFldTy <>
" cannot be a sub-type of " <> showIsListTy supFldTy <> " Type " <> G.showGT supFldTy
where
checkNullMismatch subTy supTy = when (G.isNotNull supTy && G.isNullable subTy ) $
throwError $ "Nullable Type " <> G.showGT subFldTy <> " cannot be a sub-type of Non-Null Type " <> G.showGT supFldTy
showIsListTy = \case
G.TypeList {} -> "List"
G.TypeNamed {} -> "Named"
-- TODO Should we check the schema location as well?
isSubTypeBase :: (MonadError Text m) => TypeInfo -> TypeInfo -> m ()
isSubTypeBase subTyInfo supTyInfo = case (subTyInfo,supTyInfo) of
(TIObj obj, TIIFace iFace) -> unless (_ifName iFace `elem` _otiImplIFaces obj) notSubTyErr
_ -> unless (subTyInfo == supTyInfo) notSubTyErr
where
showTy = showNamedTy . getNamedTy
notSubTyErr = throwError $ "Type " <> showTy subTyInfo <> " is not a sub type of " <> showTy supTyInfo
-- map postgres types to builtin scalars
pgColTyToScalar :: PGScalarType -> Text
pgColTyToScalar = \case
PGInteger -> "Int"
PGBoolean -> "Boolean"
PGFloat -> "Float"
PGText -> "String"
PGVarchar -> "String"
t -> toSQLTxt t
mkScalarTy :: PGScalarType -> G.NamedType
mkScalarTy =
G.NamedType . G.Name . pgColTyToScalar
getNamedTy :: TypeInfo -> G.NamedType
getNamedTy = \case
TIScalar t -> G.NamedType $ _stiName t
TIObj t -> _otiName t
TIIFace i -> _ifName i
TIEnum t -> _etiName t
TIInpObj t -> _iotiName t
TIUnion u -> _utiName u
mkTyInfoMap :: [TypeInfo] -> TypeMap
mkTyInfoMap tyInfos =
Map.fromList [(getNamedTy tyInfo, tyInfo) | tyInfo <- tyInfos]
fromTyDef :: InterfaceImplementations -> TypeLoc -> G.TypeDefinition -> TypeInfo
fromTyDef interfaceImplementations loc tyDef = case tyDef of
G.TypeDefinitionScalar t -> TIScalar $ fromScalarTyDef t loc
G.TypeDefinitionObject t -> TIObj $ fromObjTyDef t loc
G.TypeDefinitionInterface t -> TIIFace $ fromIFaceDef interfaceImplementations t loc
G.TypeDefinitionUnion t -> TIUnion $ fromUnionTyDef t
G.TypeDefinitionEnum t -> TIEnum $ fromEnumTyDef t loc
G.TypeDefinitionInputObject t -> TIInpObj $ fromInpObjTyDef t loc
type InterfaceImplementations = Map.HashMap G.NamedType MemberTypes
fromSchemaDoc :: G.SchemaDocument -> TypeLoc -> Either Text TypeMap
fromSchemaDoc (G.SchemaDocument tyDefs) loc = do
let tyMap = mkTyInfoMap $ map (fromTyDef interfaceImplementations loc) tyDefs
validateTypeMap tyMap
return tyMap
where
interfaceImplementations :: InterfaceImplementations
interfaceImplementations =
foldr (Map.unionWith (<>)) mempty $ flip mapMaybe tyDefs $ \case
G.TypeDefinitionObject objectDefinition ->
Just $ Map.fromList $ zip
(G._otdImplementsInterfaces objectDefinition)
(repeat $ Set.singleton $ G.NamedType $ G._otdName objectDefinition)
_ -> Nothing
validateTypeMap :: TypeMap -> Either Text ()
validateTypeMap tyMap = mapM_ validateTy $ Map.elems tyMap
where
validateTy (TIObj o) = validateObj tyMap o
validateTy (TIUnion u) = validateUnion tyMap u
validateTy (TIIFace i) = validateIFace i
validateTy _ = return ()
fromSchemaDocQ :: G.SchemaDocument -> TypeLoc -> TH.Q TH.Exp
fromSchemaDocQ sd loc = case fromSchemaDoc sd loc of
Left e -> fail $ T.unpack e
Right tyMap -> TH.ListE <$> mapM TH.lift (Map.elems tyMap)
defaultSchema :: G.SchemaDocument
defaultSchema = $(G.parseSchemaDocQ "src-rsr/schema.graphql")
-- fromBaseSchemaFileQ :: FilePath -> TH.Q TH.Exp
-- fromBaseSchemaFileQ fp =
-- fromSchemaDocQ $(G.parseSchemaDocQ fp)
type TypeMap = Map.HashMap G.NamedType TypeInfo
data DirectiveInfo
= DirectiveInfo
{ _diDescription :: !(Maybe G.Description)
, _diName :: !G.Name
, _diParams :: !ParamMap
, _diLocations :: ![G.DirectiveLocation]
} deriving (Show, Eq)
-- TODO: generate this from template haskell once we have a parser for directive defs
-- directive @skip(if: Boolean!) on FIELD | FRAGMENT_SPREAD | INLINE_FRAGMENT
defaultDirectives :: [DirectiveInfo]
defaultDirectives =
[mkDirective "skip", mkDirective "include"]
where
mkDirective n = DirectiveInfo Nothing n args dirLocs
args = Map.singleton "if" $ InpValInfo Nothing "if" Nothing $
G.TypeNamed (G.Nullability False) $ mkScalarTy PGBoolean
dirLocs = map G.DLExecutable
[G.EDLFIELD, G.EDLFRAGMENT_SPREAD, G.EDLINLINE_FRAGMENT]
defDirectivesMap :: Map.HashMap G.Name DirectiveInfo
defDirectivesMap = mapFromL _diName defaultDirectives
data FragDef
= FragDef
{ _fdName :: !G.Name
, _fdTyInfo :: !FragmentTypeInfo
, _fdSelSet :: !G.SelectionSet
} deriving (Show, Eq)
data FragmentTypeInfo
= FragmentTyObject !ObjTyInfo
| FragmentTyInterface !IFaceTyInfo
| FragmentTyUnion !UnionTyInfo
deriving (Show, Eq)
type FragDefMap = Map.HashMap G.Name FragDef
type AnnVarVals =
Map.HashMap G.Variable AnnInpVal
stripTypenames :: [G.ExecutableDefinition] -> [G.ExecutableDefinition]
stripTypenames = map filterExecDef
where
filterExecDef = \case
G.ExecutableDefinitionOperation opDef ->
G.ExecutableDefinitionOperation $ filterOpDef opDef
G.ExecutableDefinitionFragment fragDef ->
let newSelset = filterSelSet $ G._fdSelectionSet fragDef
in G.ExecutableDefinitionFragment fragDef{G._fdSelectionSet = newSelset}
filterOpDef = \case
G.OperationDefinitionTyped typeOpDef ->
let newSelset = filterSelSet $ G._todSelectionSet typeOpDef
in G.OperationDefinitionTyped typeOpDef{G._todSelectionSet = newSelset}
G.OperationDefinitionUnTyped selset ->
G.OperationDefinitionUnTyped $ filterSelSet selset
filterSelSet = mapMaybe filterSel
filterSel s = case s of
G.SelectionField f ->
if G._fName f == "__typename"
then Nothing
else
let newSelset = filterSelSet $ G._fSelectionSet f
in Just $ G.SelectionField f{G._fSelectionSet = newSelset}
_ -> Just s
-- | Used by 'Hasura.GraphQL.Validate.validateVariablesForReuse' to parse new sets of variables for
-- reusable query plans; see also 'QueryReusability'.
newtype ReusableVariableTypes
= ReusableVariableTypes { unReusableVarTypes :: Map.HashMap G.Variable RQL.PGColumnType }
deriving (Show, Eq, Semigroup, Monoid, J.ToJSON)
type ReusableVariableValues = Map.HashMap G.Variable (WithScalarType PGScalarValue)
-- | Tracks whether or not a query is /reusable/. Reusable queries are nice, since we can cache
-- their resolved ASTs and avoid re-resolving them if we receive an identical query. However, we
-- cant always safely reuse queries if they have variables, since some variable values can affect
-- the generated SQL. For example, consider the following query:
--
-- > query users_where($condition: users_bool_exp!) {
-- > users(where: $condition) {
-- > id
-- > }
-- > }
--
-- Different values for @$condition@ will produce completely different queries, so we cant reuse
-- its plan (unless the variable values were also all identical, of course, but we dont bother
-- caching those).
--
-- If a query does turn out to be reusable, we build up a 'ReusableVariableTypes' value that maps
-- variable names to their types so that we can use a fast path for validating new sets of
-- variables (namely 'Hasura.GraphQL.Validate.validateVariablesForReuse').
data QueryReusability
= Reusable !ReusableVariableTypes
| NotReusable
deriving (Show, Eq)
$(makePrisms ''QueryReusability)
instance Semigroup QueryReusability where
Reusable a <> Reusable b = Reusable (a <> b)
_ <> _ = NotReusable
instance Monoid QueryReusability where
mempty = Reusable mempty
class (Monad m) => MonadReusability m where
recordVariableUse :: G.Variable -> RQL.PGColumnType -> m ()
markNotReusable :: m ()
instance (MonadReusability m) => MonadReusability (ReaderT r m) where
recordVariableUse a b = lift $ recordVariableUse a b
markNotReusable = lift markNotReusable
instance (MonadReusability m) => MonadReusability (StateT s m) where
recordVariableUse a b = lift $ recordVariableUse a b
markNotReusable = lift markNotReusable
newtype ReusabilityT m a = ReusabilityT { unReusabilityT :: StateT QueryReusability m a }
deriving (Functor, Applicative, Monad, MonadError e, MonadReader r, MonadIO)
instance (Monad m) => MonadReusability (ReusabilityT m) where
recordVariableUse varName varType = ReusabilityT $
modify' (<> Reusable (ReusableVariableTypes $ Map.singleton varName varType))
markNotReusable = ReusabilityT $ put NotReusable
runReusabilityT :: ReusabilityT m a -> m (a, QueryReusability)
runReusabilityT = runReusabilityTWith mempty
-- | Like 'runReusabilityT', but starting from an existing 'QueryReusability' state.
runReusabilityTWith :: QueryReusability -> ReusabilityT m a -> m (a, QueryReusability)
runReusabilityTWith initialReusability = flip runStateT initialReusability . unReusabilityT
evalReusabilityT :: (Monad m) => ReusabilityT m a -> m a
evalReusabilityT = flip evalStateT mempty . unReusabilityT

View File

@ -10,6 +10,9 @@ module Hasura.RQL.DDL.RemoteSchema
) where ) where
import Hasura.EncJSON import Hasura.EncJSON
-- import Hasura.GraphQL.NormalForm
import Hasura.GraphQL.RemoteServer
-- import Hasura.GraphQL.Schema.Merge
import Hasura.Prelude import Hasura.Prelude
import qualified Data.Aeson as J import qualified Data.Aeson as J
@ -121,3 +124,34 @@ fetchRemoteSchemas =
where where
fromRow (name, Q.AltJ def, comment) = fromRow (name, Q.AltJ def, comment) =
AddRemoteSchemaQuery name def comment AddRemoteSchemaQuery name def comment
-- runIntrospectRemoteSchema
-- :: (CacheRM m, QErrM m) => RemoteSchemaNameQuery -> m EncJSON
-- runIntrospectRemoteSchema (RemoteSchemaNameQuery rsName) = do
-- sc <- askSchemaCache
-- rGCtx <-
-- case Map.lookup rsName (scRemoteSchemas sc) of
-- Nothing ->
-- throw400 NotExists $
-- "remote schema: " <> remoteSchemaNameToTxt rsName <> " not found"
-- Just rCtx -> mergeGCtx (rscGCtx rCtx) GC.emptyGCtx
-- -- merge with emptyGCtx to get default query fields
-- queryParts <- flip runReaderT rGCtx $ VQ.getQueryParts introspectionQuery
-- (rootSelSet, _) <- flip runReaderT rGCtx $ VT.runReusabilityT $ VQ.validateGQ queryParts
-- schemaField <-
-- case rootSelSet of
-- VQ.RQuery selSet -> getSchemaField $ toList $ unAliasedFields $
-- unObjectSelectionSet selSet
-- _ -> throw500 "expected query for introspection"
-- (introRes, _) <- flip runReaderT rGCtx $ VT.runReusabilityT $ RI.schemaR schemaField
-- pure $ wrapInSpecKeys introRes
-- where
-- wrapInSpecKeys introObj =
-- encJFromAssocList
-- [ ( T.pack "data"
-- , encJFromAssocList [(T.pack "__schema", encJFromJValue introObj)])
-- ]
-- getSchemaField = \case
-- [] -> throw500 "found empty when looking for __schema field"
-- [f] -> pure f
-- _ -> throw500 "expected __schema field, found many fields"

View File

@ -47,6 +47,7 @@ import Hasura.RQL.DDL.CustomTypes
import Hasura.RQL.DDL.Deps import Hasura.RQL.DDL.Deps
import Hasura.RQL.DDL.EventTrigger import Hasura.RQL.DDL.EventTrigger
import Hasura.RQL.DDL.RemoteSchema import Hasura.RQL.DDL.RemoteSchema
-- import Hasura.RQL.DDL.ScheduledTrigger
import Hasura.RQL.DDL.Schema.Cache.Common import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.DDL.Schema.Cache.Dependencies import Hasura.RQL.DDL.Schema.Cache.Dependencies
import Hasura.RQL.DDL.Schema.Cache.Fields import Hasura.RQL.DDL.Schema.Cache.Fields
@ -192,6 +193,9 @@ buildSchemaCacheRule = proc (catalogMetadata, invalidationKeys) -> do
-- Step 4: Build the relay GraphQL schema
-- relayGQLSchema <- bindA -< Relay.mkRelayGCtxMap (_boTables resolvedOutputs) (_boFunctions resolvedOutputs)
returnA -< SchemaCache returnA -< SchemaCache
{ scTables = _boTables resolvedOutputs { scTables = _boTables resolvedOutputs
, scActions = _boActions resolvedOutputs , scActions = _boActions resolvedOutputs

View File

@ -71,7 +71,7 @@ mutateAndFetchCols qt cols (cte, p) strfyNum =
tabFrom = FromIden aliasIden tabFrom = FromIden aliasIden
tabPerm = TablePerm annBoolExpTrue Nothing tabPerm = TablePerm annBoolExpTrue Nothing
selFlds = flip map cols $ selFlds = flip map cols $
\ci -> (fromPGCol $ pgiColumn ci, mkAnnColFieldAsText ci) \ci -> (fromPGCol $ pgiColumn ci, mkAnnColumnFieldAsText ci)
sql = toSQL selectWith sql = toSQL selectWith
selectWith = S.SelectWith [(S.Alias aliasIden, cte)] select selectWith = S.SelectWith [(S.Alias aliasIden, cte)] select
@ -87,7 +87,7 @@ mutateAndFetchCols qt cols (cte, p) strfyNum =
, S.selFrom = Just $ S.FromExp [S.FIIden aliasIden] , S.selFrom = Just $ S.FromExp [S.FIIden aliasIden]
} }
colSel = S.SESelect $ mkSQLSelect JASMultipleRows $ colSel = S.SESelect $ mkSQLSelect JASMultipleRows $
AnnSelG selFlds tabFrom tabPerm noTableArgs strfyNum AnnSelectG selFlds tabFrom tabPerm noSelectArgs strfyNum
-- | Note:- Using sorted columns is necessary to enable casting the rows returned by VALUES expression to table type. -- | Note:- Using sorted columns is necessary to enable casting the rows returned by VALUES expression to table type.
-- For example, let's consider the table, `CREATE TABLE test (id serial primary key, name text not null, age int)`. -- For example, let's consider the table, `CREATE TABLE test (id serial primary key, name text not null, age int)`.

View File

@ -12,23 +12,20 @@ import Hasura.Prelude
import Control.Lens import Control.Lens
import Data.List (nub) import Data.List (nub)
import Data.Validation
import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Scientific (toBoundedInteger, toRealFloat)
import Data.Validation
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Parser
import Hasura.GraphQL.RemoteServer (execRemoteGQ') import Hasura.GraphQL.RemoteServer (execRemoteGQ')
import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.GraphQL.Utils
import Hasura.GraphQL.Parser
import Hasura.GraphQL.Execute.Resolve
import Hasura.RQL.DML.Internal import Hasura.RQL.DML.Internal
import Hasura.RQL.DML.Returning
import Hasura.RQL.DML.Returning.Types import Hasura.RQL.DML.Returning.Types
import Hasura.RQL.DML.Select.Types import Hasura.RQL.DML.Select.Types
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion) import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types ((<<>))
import Hasura.Session import Hasura.Session
import Hasura.SQL.Types ((<<>))
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
@ -45,8 +42,6 @@ import qualified Language.GraphQL.Draft.Printer.Text as G
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as N import qualified Network.HTTP.Types as N
import qualified Data.ByteString.Lazy as BL
import qualified Network.Wreq as Wreq
-- | Executes given query and fetch response JSON from Postgres. Substitutes remote relationship fields. -- | Executes given query and fetch response JSON from Postgres. Substitutes remote relationship fields.
executeQueryWithRemoteJoins executeQueryWithRemoteJoins
@ -106,7 +101,7 @@ pathToAlias path counter = do
parseGraphQLName $ T.intercalate "_" (map getFieldNameTxt $ unFieldPath path) parseGraphQLName $ T.intercalate "_" (map getFieldNameTxt $ unFieldPath path)
<> "__" <> (T.pack . show . unCounter) counter <> "__" <> (T.pack . show . unCounter) counter
-- | A 'RemoteJoin' represents the context of remote relationship to be extracted from 'AnnFldG's. -- | A 'RemoteJoin' represents the context of remote relationship to be extracted from 'AnnFieldG's.
data RemoteJoin data RemoteJoin
= RemoteJoin = RemoteJoin
{ _rjName :: !FieldName -- ^ The remote join field name. { _rjName :: !FieldName -- ^ The remote join field name.
@ -139,14 +134,14 @@ transformSelect path sel = do
pure sel{_asnFields = transformedFields} pure sel{_asnFields = transformedFields}
-- | Traverse through @'AnnAggregateSelect' and collect remote join fields (if any). -- | Traverse through @'AnnAggregateSelect' and collect remote join fields (if any).
getRemoteJoinsAggregateSelect :: AnnAggSel -> (AnnAggSel, Maybe RemoteJoins) getRemoteJoinsAggregateSelect :: AnnAggregateSelect -> (AnnAggregateSelect, Maybe RemoteJoins)
getRemoteJoinsAggregateSelect = getRemoteJoinsAggregateSelect =
second mapToNonEmpty . flip runState mempty . transformAggregateSelect mempty second mapToNonEmpty . flip runState mempty . transformAggregateSelect mempty
transformAggregateSelect transformAggregateSelect
:: FieldPath :: FieldPath
-> AnnAggSel -> AnnAggregateSelect
-> State RemoteJoinMap AnnAggSel -> State RemoteJoinMap AnnAggregateSelect
transformAggregateSelect path sel = do transformAggregateSelect path sel = do
let aggFields = _asnFields sel let aggFields = _asnFields sel
transformedFields <- forM aggFields $ \(fieldName, aggField) -> transformedFields <- forM aggFields $ \(fieldName, aggField) ->
@ -156,32 +151,32 @@ transformAggregateSelect path sel = do
TAFExp t -> pure $ TAFExp t TAFExp t -> pure $ TAFExp t
pure sel{_asnFields = transformedFields} pure sel{_asnFields = transformedFields}
-- -- | Traverse through @'ConnectionSelect' and collect remote join fields (if any). -- | Traverse through @'ConnectionSelect' and collect remote join fields (if any).
-- getRemoteJoinsConnectionSelect :: ConnectionSelect S.SQLExp -> (ConnectionSelect S.SQLExp, Maybe RemoteJoins) getRemoteJoinsConnectionSelect :: ConnectionSelect S.SQLExp -> (ConnectionSelect S.SQLExp, Maybe RemoteJoins)
-- getRemoteJoinsConnectionSelect = getRemoteJoinsConnectionSelect =
-- second mapToNonEmpty . flip runState mempty . transformConnectionSelect mempty second mapToNonEmpty . flip runState mempty . transformConnectionSelect mempty
-- transformConnectionSelect transformConnectionSelect
-- :: FieldPath :: FieldPath
-- -> ConnectionSelect S.SQLExp -> ConnectionSelect S.SQLExp
-- -> State RemoteJoinMap (ConnectionSelect S.SQLExp) -> State RemoteJoinMap (ConnectionSelect S.SQLExp)
-- transformConnectionSelect path ConnectionSelect{..} = do transformConnectionSelect path ConnectionSelect{..} = do
-- let connectionFields = _asnFields _csSelect let connectionFields = _asnFields _csSelect
-- transformedFields <- forM connectionFields $ \(fieldName, field) -> transformedFields <- forM connectionFields $ \(fieldName, field) ->
-- (fieldName,) <$> case field of (fieldName,) <$> case field of
-- ConnectionTypename t -> pure $ ConnectionTypename t ConnectionTypename t -> pure $ ConnectionTypename t
-- ConnectionPageInfo p -> pure $ ConnectionPageInfo p ConnectionPageInfo p -> pure $ ConnectionPageInfo p
-- ConnectionEdges edges -> ConnectionEdges <$> transformEdges (appendPath fieldName path) edges ConnectionEdges edges -> ConnectionEdges <$> transformEdges (appendPath fieldName path) edges
-- let select = _csSelect{_asnFields = transformedFields} let select = _csSelect{_asnFields = transformedFields}
-- pure $ ConnectionSelect _csPrimaryKeyColumns _csSplit _csSlice select pure $ ConnectionSelect _csPrimaryKeyColumns _csSplit _csSlice select
-- where where
-- transformEdges edgePath edgeFields = transformEdges edgePath edgeFields =
-- forM edgeFields $ \(fieldName, edgeField) -> forM edgeFields $ \(fieldName, edgeField) ->
-- (fieldName,) <$> case edgeField of (fieldName,) <$> case edgeField of
-- EdgeTypename t -> pure $ EdgeTypename t EdgeTypename t -> pure $ EdgeTypename t
-- EdgeCursor -> pure EdgeCursor EdgeCursor -> pure EdgeCursor
-- EdgeNode annFields -> EdgeNode annFields ->
-- EdgeNode <$> transformAnnFields (appendPath fieldName edgePath) annFields EdgeNode <$> transformAnnFields (appendPath fieldName edgePath) annFields
-- | Traverse through 'MutationOutput' and collect remote join fields (if any) -- | Traverse through 'MutationOutput' and collect remote join fields (if any)
getRemoteJoinsMutationOutput :: MutationOutput -> (MutationOutput, Maybe RemoteJoins) getRemoteJoinsMutationOutput :: MutationOutput -> (MutationOutput, Maybe RemoteJoins)
@ -203,10 +198,10 @@ getRemoteJoinsMutationOutput =
MExp t -> pure $ MExp t MExp t -> pure $ MExp t
MRet annFields -> MRet <$> transformAnnFields fieldPath annFields MRet annFields -> MRet <$> transformAnnFields fieldPath annFields
transformAnnFields :: FieldPath -> AnnFlds -> State RemoteJoinMap AnnFlds transformAnnFields :: FieldPath -> AnnFields -> State RemoteJoinMap AnnFields
transformAnnFields path fields = do transformAnnFields path fields = do
let pgColumnFields = map fst $ getFields _FCol fields let pgColumnFields = map fst $ getFields _AFColumn fields
remoteSelects = getFields _FRemote fields remoteSelects = getFields _AFRemote fields
remoteJoins = flip map remoteSelects $ \(fieldName, remoteSelect) -> remoteJoins = flip map remoteSelects $ \(fieldName, remoteSelect) ->
let RemoteSelect argsMap selSet hasuraColumns remoteFields rsi = remoteSelect let RemoteSelect argsMap selSet hasuraColumns remoteFields rsi = remoteSelect
hasuraColumnL = toList hasuraColumns hasuraColumnL = toList hasuraColumns
@ -217,44 +212,46 @@ transformAnnFields path fields = do
transformedFields <- forM fields $ \(fieldName, field') -> do transformedFields <- forM fields $ \(fieldName, field') -> do
let fieldPath = appendPath fieldName path let fieldPath = appendPath fieldName path
(fieldName,) <$> case field' of (fieldName,) <$> case field' of
FCol c -> pure $ FCol c AFNodeId qt pkeys -> pure $ AFNodeId qt pkeys
FObj annRel -> AFColumn c -> pure $ AFColumn c
FObj <$> transformAnnRelation fieldPath annRel AFObjectRelation annRel ->
FArr (ASSimple annRel) -> AFObjectRelation <$> transformAnnRelation fieldPath annRel
FArr . ASSimple <$> transformAnnRelation fieldPath annRel AFArrayRelation (ASSimple annRel) ->
FArr (ASAgg aggRel) -> AFArrayRelation . ASSimple <$> transformAnnRelation fieldPath annRel
FArr . ASAgg <$> transformAnnAggregateRelation fieldPath aggRel AFArrayRelation (ASAggregate aggRel) ->
-- AFArrayRelation (ASConnection annRel) -> AFArrayRelation . ASAggregate <$> transformAnnAggregateRelation fieldPath aggRel
-- AFArrayRelation . ASConnection <$> transformArrayConnection fieldPath annRel AFArrayRelation (ASConnection annRel) ->
FComputedField computedField -> AFArrayRelation . ASConnection <$> transformArrayConnection fieldPath annRel
FComputedField <$> case computedField of AFComputedField computedField ->
AFComputedField <$> case computedField of
CFSScalar _ -> pure computedField CFSScalar _ -> pure computedField
CFSTable jas annSel -> CFSTable jas <$> transformSelect fieldPath annSel CFSTable jas annSel -> CFSTable jas <$> transformSelect fieldPath annSel
FRemote rs -> pure $ FRemote rs AFRemote rs -> pure $ AFRemote rs
AFExpression t -> pure $ AFExpression t
case NE.nonEmpty remoteJoins of case NE.nonEmpty remoteJoins of
Nothing -> pure transformedFields Nothing -> pure transformedFields
Just nonEmptyRemoteJoins -> do Just nonEmptyRemoteJoins -> do
let phantomColumns = map (\ci -> (fromPGCol $ pgiColumn ci, FCol $ AnnColField ci False Nothing)) $ let phantomColumns = map (\ci -> (fromPGCol $ pgiColumn ci, AFColumn $ AnnColumnField ci False Nothing)) $
concatMap _rjPhantomFields remoteJoins concatMap _rjPhantomFields remoteJoins
modify (Map.insert path nonEmptyRemoteJoins) modify (Map.insert path nonEmptyRemoteJoins)
pure $ transformedFields <> phantomColumns pure $ transformedFields <> phantomColumns
where where
getFields f = mapMaybe (sequence . second (^? f)) getFields f = mapMaybe (sequence . second (^? f))
transformAnnRelation fieldPath annRel = do transformAnnRelation fieldPath annRel = do
let annSel = aarAnnSel annRel let annSel = aarAnnSelect annRel
transformedSel <- transformSelect fieldPath annSel transformedSel <- transformSelect fieldPath annSel
pure annRel{aarAnnSel = transformedSel} pure annRel{aarAnnSelect = transformedSel}
transformAnnAggregateRelation fieldPath annRel = do transformAnnAggregateRelation fieldPath annRel = do
let annSel = aarAnnSel annRel let annSel = aarAnnSelect annRel
transformedSel <- transformAggregateSelect fieldPath annSel transformedSel <- transformAggregateSelect fieldPath annSel
pure annRel{aarAnnSel = transformedSel} pure annRel{aarAnnSelect = transformedSel}
-- transformArrayConnection fieldPath annRel = do transformArrayConnection fieldPath annRel = do
-- let connectionSelect = aarAnnSelect annRel let connectionSelect = aarAnnSelect annRel
-- transformedConnectionSelect <- transformConnectionSelect fieldPath connectionSelect transformedConnectionSelect <- transformConnectionSelect fieldPath connectionSelect
-- pure annRel{aarAnnSelect = transformedConnectionSelect} pure annRel{aarAnnSelect = transformedConnectionSelect}
type CompositeObject a = OMap.InsOrdHashMap Text (CompositeValue a) type CompositeObject a = OMap.InsOrdHashMap Text (CompositeValue a)
@ -338,7 +335,7 @@ traverseQueryResponseJSON rjm =
A.Number val -> A.Number val ->
case (toBoundedInteger val) of case (toBoundedInteger val) of
Just intVal -> pure $ G.VInt intVal Just intVal -> pure $ G.VInt intVal
Nothing -> pure $ G.VFloat $ toRealFloat val Nothing -> pure $ G.VFloat $ toRealFloat val
A.Array vals -> G.VList <$> traverse go (toList vals) A.Array vals -> G.VList <$> traverse go (toList vals)
A.Object vals -> A.Object vals ->
G.VObject . Map.fromList <$> for (Map.toList vals) \(key, val) -> do G.VObject . Map.fromList <$> for (Map.toList vals) \(key, val) -> do

View File

@ -10,7 +10,6 @@ import Hasura.SQL.Types
import qualified Data.Text as T import qualified Data.Text as T
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
traverseMutFld traverseMutFld
:: (Applicative f) :: (Applicative f)
=> (a -> f b) => (a -> f b)
@ -19,8 +18,7 @@ traverseMutFld
traverseMutFld f = \case traverseMutFld f = \case
MCount -> pure MCount MCount -> pure MCount
MExp t -> pure $ MExp t MExp t -> pure $ MExp t
MRet flds -> MRet <$> traverse (traverse (traverseAnnFld f)) flds MRet flds -> MRet <$> traverse (traverse (traverseAnnField f)) flds
traverseMutationOutput traverseMutationOutput
:: (Applicative f) :: (Applicative f)
@ -30,7 +28,7 @@ traverseMutationOutput f = \case
MOutMultirowFields mutationFields -> MOutMultirowFields mutationFields ->
MOutMultirowFields <$> traverse (traverse (traverseMutFld f)) mutationFields MOutMultirowFields <$> traverse (traverse (traverseMutFld f)) mutationFields
MOutSinglerowObject annFields -> MOutSinglerowObject annFields ->
MOutSinglerowObject <$> traverseAnnFlds f annFields MOutSinglerowObject <$> traverseAnnFields f annFields
traverseMutFlds traverseMutFlds
:: (Applicative f) :: (Applicative f)
@ -43,15 +41,15 @@ traverseMutFlds f =
hasNestedFld :: MutationOutputG a -> Bool hasNestedFld :: MutationOutputG a -> Bool
hasNestedFld = \case hasNestedFld = \case
MOutMultirowFields flds -> any isNestedMutFld flds MOutMultirowFields flds -> any isNestedMutFld flds
MOutSinglerowObject annFlds -> any isNestedAnnFld annFlds MOutSinglerowObject annFlds -> any isNestedAnnField annFlds
where where
isNestedMutFld (_, mutFld) = case mutFld of isNestedMutFld (_, mutFld) = case mutFld of
MRet annFlds -> any isNestedAnnFld annFlds MRet annFlds -> any isNestedAnnField annFlds
_ -> False _ -> False
isNestedAnnFld (_, annFld) = case annFld of isNestedAnnField (_, annFld) = case annFld of
FObj _ -> True AFObjectRelation _ -> True
FArr _ -> True AFArrayRelation _ -> True
_ -> False _ -> False
pgColsFromMutFld :: MutFld -> [(PGCol, PGColumnType)] pgColsFromMutFld :: MutFld -> [(PGCol, PGColumnType)]
pgColsFromMutFld = \case pgColsFromMutFld = \case
@ -59,16 +57,16 @@ pgColsFromMutFld = \case
MExp _ -> [] MExp _ -> []
MRet selFlds -> MRet selFlds ->
flip mapMaybe selFlds $ \(_, annFld) -> case annFld of flip mapMaybe selFlds $ \(_, annFld) -> case annFld of
FCol (AnnColField (PGColumnInfo col _ _ colTy _ _) _ _) -> Just (col, colTy) AFColumn (AnnColumnField (PGColumnInfo col _ _ colTy _ _) _ _) -> Just (col, colTy)
_ -> Nothing _ -> Nothing
pgColsFromMutFlds :: MutFlds -> [(PGCol, PGColumnType)] pgColsFromMutFlds :: MutFlds -> [(PGCol, PGColumnType)]
pgColsFromMutFlds = concatMap (pgColsFromMutFld . snd) pgColsFromMutFlds = concatMap (pgColsFromMutFld . snd)
pgColsToSelFlds :: [PGColumnInfo] -> [(FieldName, AnnFld)] pgColsToSelFlds :: [PGColumnInfo] -> [(FieldName, AnnField)]
pgColsToSelFlds cols = pgColsToSelFlds cols =
flip map cols $ flip map cols $
\pgColInfo -> (fromPGCol $ pgiColumn pgColInfo, mkAnnColField pgColInfo Nothing) \pgColInfo -> (fromPGCol $ pgiColumn pgColInfo, mkAnnColumnField pgColInfo Nothing)
mkDefaultMutFlds :: Maybe [PGColumnInfo] -> MutationOutput mkDefaultMutFlds :: Maybe [PGColumnInfo] -> MutationOutput
mkDefaultMutFlds = MOutMultirowFields . \case mkDefaultMutFlds = MOutMultirowFields . \case
@ -95,7 +93,7 @@ mkMutFldExp qt preCalAffRows strfyNum = \case
let tabFrom = FromIden cteAlias let tabFrom = FromIden cteAlias
tabPerm = TablePerm annBoolExpTrue Nothing tabPerm = TablePerm annBoolExpTrue Nothing
in S.SESelect $ mkSQLSelect JASMultipleRows $ in S.SESelect $ mkSQLSelect JASMultipleRows $
AnnSelG selFlds tabFrom tabPerm noTableArgs strfyNum AnnSelectG selFlds tabFrom tabPerm noSelectArgs strfyNum
where where
cteAlias = qualTableToAliasIden qt cteAlias = qualTableToAliasIden qt
@ -117,7 +115,7 @@ mkMutationOutputExp qt preCalAffRows cte mutOutput strfyNum =
let tabFrom = FromIden cteAlias let tabFrom = FromIden cteAlias
tabPerm = TablePerm annBoolExpTrue Nothing tabPerm = TablePerm annBoolExpTrue Nothing
in S.SESelect $ mkSQLSelect JASSingleObject $ in S.SESelect $ mkSQLSelect JASSingleObject $
AnnSelG annFlds tabFrom tabPerm noTableArgs strfyNum AnnSelectG annFlds tabFrom tabPerm noSelectArgs strfyNum
checkRetCols checkRetCols

View File

@ -12,7 +12,7 @@ import Hasura.RQL.DML.Select.Types
data MutFldG v data MutFldG v
= MCount = MCount
| MExp !T.Text | MExp !T.Text
| MRet !(AnnFldsG v) | MRet !(AnnFieldsG v)
deriving (Show, Eq) deriving (Show, Eq)
type MutFld = MutFldG S.SQLExp type MutFld = MutFldG S.SQLExp
@ -21,7 +21,7 @@ type MutFldsG v = Fields (MutFldG v)
data MutationOutputG v data MutationOutputG v
= MOutMultirowFields !(MutFldsG v) = MOutMultirowFields !(MutFldsG v)
| MOutSinglerowObject !(AnnFldsG v) | MOutSinglerowObject !(AnnFieldsG v)
deriving (Show, Eq) deriving (Show, Eq)
type MutationOutput = MutationOutputG S.SQLExp type MutationOutput = MutationOutputG S.SQLExp

View File

@ -1,11 +1,11 @@
module Hasura.RQL.DML.Select module Hasura.RQL.DML.Select
( selectP2 ( selectP2
, selectQuerySQL
, selectAggQuerySQL
, convSelectQuery , convSelectQuery
, asSingleRowJsonResp , asSingleRowJsonResp
, module Hasura.RQL.DML.Select.Internal
, runSelect , runSelect
, selectQuerySQL
, selectAggregateQuerySQL
, module Hasura.RQL.DML.Select.Internal
) )
where where
@ -105,7 +105,7 @@ convOrderByElem
=> SessVarBldr m => SessVarBldr m
-> (FieldInfoMap FieldInfo, SelPermInfo) -> (FieldInfoMap FieldInfo, SelPermInfo)
-> OrderByCol -> OrderByCol
-> m AnnObCol -> m (AnnOrderByElement S.SQLExp)
convOrderByElem sessVarBldr (flds, spi) = \case convOrderByElem sessVarBldr (flds, spi) = \case
OCPG fldName -> do OCPG fldName -> do
fldInfo <- askFieldInfo flds fldName fldInfo <- askFieldInfo flds fldName
@ -118,7 +118,7 @@ convOrderByElem sessVarBldr (flds, spi) = \case
[ fldName <<> " has type 'geometry'" [ fldName <<> " has type 'geometry'"
, " and cannot be used in order_by" , " and cannot be used in order_by"
] ]
else return $ AOCPG $ pgiColumn colInfo else return $ AOCColumn colInfo
FIRelationship _ -> throw400 UnexpectedPayload $ mconcat FIRelationship _ -> throw400 UnexpectedPayload $ mconcat
[ fldName <<> " is a" [ fldName <<> " is a"
, " relationship and should be expanded" , " relationship and should be expanded"
@ -149,7 +149,7 @@ convOrderByElem sessVarBldr (flds, spi) = \case
] ]
(relFim, relSpi) <- fetchRelDet (riName relInfo) (riRTable relInfo) (relFim, relSpi) <- fetchRelDet (riName relInfo) (riRTable relInfo)
resolvedSelFltr <- convAnnBoolExpPartialSQL sessVarBldr $ spiFilter relSpi resolvedSelFltr <- convAnnBoolExpPartialSQL sessVarBldr $ spiFilter relSpi
AOCObj relInfo resolvedSelFltr <$> AOCObjectRelation relInfo resolvedSelFltr <$>
convOrderByElem sessVarBldr (relFim, relSpi) rest convOrderByElem sessVarBldr (relFim, relSpi) rest
FIRemoteRelationship {} -> FIRemoteRelationship {} ->
throw400 UnexpectedPayload (mconcat [ fldName <<> " is a remote field" ]) throw400 UnexpectedPayload (mconcat [ fldName <<> " is a remote field" ])
@ -168,12 +168,12 @@ convSelectQ fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
indexedForM (sqColumns selQ) $ \case indexedForM (sqColumns selQ) $ \case
(ECSimple pgCol) -> do (ECSimple pgCol) -> do
colInfo <- convExtSimple fieldInfoMap selPermInfo pgCol colInfo <- convExtSimple fieldInfoMap selPermInfo pgCol
return (fromPGCol pgCol, mkAnnColField colInfo Nothing) return (fromPGCol pgCol, mkAnnColumnField colInfo Nothing)
(ECRel relName mAlias relSelQ) -> do (ECRel relName mAlias relSelQ) -> do
annRel <- convExtRel fieldInfoMap relName mAlias annRel <- convExtRel fieldInfoMap relName mAlias
relSelQ sessVarBldr prepValBldr relSelQ sessVarBldr prepValBldr
return ( fromRel $ fromMaybe relName mAlias return ( fromRel $ fromMaybe relName mAlias
, either FObj FArr annRel , either AFObjectRelation AFArrayRelation annRel
) )
-- let spiT = spiTable selPermInfo -- let spiT = spiTable selPermInfo
@ -198,11 +198,11 @@ convSelectQ fieldInfoMap selPermInfo selQ sessVarBldr prepValBldr = do
let tabFrom = FromTable $ spiTable selPermInfo let tabFrom = FromTable $ spiTable selPermInfo
tabPerm = TablePerm resolvedSelFltr mPermLimit tabPerm = TablePerm resolvedSelFltr mPermLimit
tabArgs = TableArgs wClause annOrdByM mQueryLimit tabArgs = SelectArgs wClause annOrdByM mQueryLimit
(S.intToSQLExp <$> mQueryOffset) Nothing (S.intToSQLExp <$> mQueryOffset) Nothing
strfyNum <- stringifyNum <$> askSQLGenCtx strfyNum <- stringifyNum <$> askSQLGenCtx
return $ AnnSelG annFlds tabFrom tabPerm tabArgs strfyNum return $ AnnSelectG annFlds tabFrom tabPerm tabArgs strfyNum
where where
mQueryOffset = sqOffset selQ mQueryOffset = sqOffset selQ
@ -229,7 +229,7 @@ convExtRel
-> SelectQExt -> SelectQExt
-> SessVarBldr m -> SessVarBldr m
-> (PGColumnType -> Value -> m S.SQLExp) -> (PGColumnType -> Value -> m S.SQLExp)
-> m (Either ObjSel ArrSel) -> m (Either ObjectRelationSelect ArraySelect)
convExtRel fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do convExtRel fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do
-- Point to the name key -- Point to the name key
relInfo <- withPathK "name" $ relInfo <- withPathK "name" $
@ -240,9 +240,9 @@ convExtRel fieldInfoMap relName mAlias selQ sessVarBldr prepValBldr = do
case relTy of case relTy of
ObjRel -> do ObjRel -> do
when misused $ throw400 UnexpectedPayload objRelMisuseMsg when misused $ throw400 UnexpectedPayload objRelMisuseMsg
return $ Left $ AnnRelG (fromMaybe relName mAlias) colMapping annSel return $ Left $ AnnRelationSelectG (fromMaybe relName mAlias) colMapping annSel
ArrRel -> ArrRel ->
return $ Right $ ASSimple $ AnnRelG (fromMaybe relName mAlias) return $ Right $ ASSimple $ AnnRelationSelectG (fromMaybe relName mAlias)
colMapping annSel colMapping annSel
where where
pgWhenRelErr = "only relationships can be expanded" pgWhenRelErr = "only relationships can be expanded"
@ -270,8 +270,7 @@ convSelectQuery sessVarBldr prepArgBuilder (DMLQuery qt selQ) = do
let fieldInfo = _tciFieldInfoMap $ _tiCoreInfo tabInfo let fieldInfo = _tciFieldInfoMap $ _tiCoreInfo tabInfo
extSelQ <- resolveStar fieldInfo selPermInfo selQ extSelQ <- resolveStar fieldInfo selPermInfo selQ
validateHeaders $ spiRequiredHeaders selPermInfo validateHeaders $ spiRequiredHeaders selPermInfo
convSelectQ fieldInfo selPermInfo convSelectQ fieldInfo selPermInfo extSelQ sessVarBldr prepArgBuilder
extSelQ sessVarBldr prepArgBuilder
selectP2 :: JsonAggSelect -> (AnnSimpleSel, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON selectP2 :: JsonAggSelect -> (AnnSimpleSel, DS.Seq Q.PrepArg) -> Q.TxE QErr EncJSON
selectP2 jsonAggSelect (sel, p) = selectP2 jsonAggSelect (sel, p) =
@ -284,9 +283,9 @@ selectQuerySQL :: JsonAggSelect -> AnnSimpleSel -> Q.Query
selectQuerySQL jsonAggSelect sel = selectQuerySQL jsonAggSelect sel =
Q.fromBuilder $ toSQL $ mkSQLSelect jsonAggSelect sel Q.fromBuilder $ toSQL $ mkSQLSelect jsonAggSelect sel
selectAggQuerySQL :: AnnAggSel -> Q.Query selectAggregateQuerySQL :: AnnAggregateSelect -> Q.Query
selectAggQuerySQL = selectAggregateQuerySQL =
Q.fromBuilder . toSQL . mkAggSelect Q.fromBuilder . toSQL . mkAggregateSelect
asSingleRowJsonResp :: Q.Query -> [Q.PrepArg] -> Q.TxE QErr EncJSON asSingleRowJsonResp :: Q.Query -> [Q.PrepArg] -> Q.TxE QErr EncJSON
asSingleRowJsonResp query args = asSingleRowJsonResp query args =

File diff suppressed because it is too large Load Diff

View File

@ -3,19 +3,19 @@
module Hasura.RQL.DML.Select.Types where module Hasura.RQL.DML.Select.Types where
import Control.Lens.TH (makeLenses, makePrisms)
import Data.Aeson.Types import Data.Aeson.Types
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Control.Lens.TH (makePrisms)
import qualified Data.HashMap.Strict as HM import qualified Data.Aeson as J
import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Sequence as Seq
import qualified Data.Aeson as J import qualified Data.Text as T
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import Hasura.Prelude
import Hasura.GraphQL.Parser.Schema import Hasura.GraphQL.Parser.Schema
import Hasura.Prelude
import Hasura.RQL.Types.BoolExp import Hasura.RQL.Types.BoolExp
import Hasura.RQL.Types.Column import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common import Hasura.RQL.Types.Common
@ -23,7 +23,7 @@ import Hasura.RQL.Types.DML
import Hasura.RQL.Types.Function import Hasura.RQL.Types.Function
import Hasura.RQL.Types.RemoteRelationship import Hasura.RQL.Types.RemoteRelationship
import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.RemoteSchema
import qualified Hasura.SQL.DML as S import qualified Hasura.SQL.DML as S
import Hasura.SQL.Types import Hasura.SQL.Types
type SelectQExt = SelectG ExtCol BoolExp Int type SelectQExt = SelectG ExtCol BoolExp Int
@ -31,7 +31,8 @@ type SelectQExt = SelectG ExtCol BoolExp Int
data JsonAggSelect data JsonAggSelect
= JASMultipleRows = JASMultipleRows
| JASSingleObject | JASSingleObject
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Hashable JsonAggSelect
-- Columns in RQL -- Columns in RQL
data ExtCol data ExtCol
@ -60,118 +61,129 @@ instance FromJSON ExtCol where
, "object (relationship)" , "object (relationship)"
] ]
data AnnAggOrdBy data AnnAggregateOrderBy
= AAOCount = AAOCount
| AAOOp !T.Text !PGCol | AAOOp !T.Text !PGColumnInfo
deriving (Show, Eq) deriving (Show, Eq, Generic)
instance Hashable AnnAggregateOrderBy
data AnnObColG v data AnnOrderByElementG v
= AOCPG !PGCol = AOCColumn !PGColumnInfo
| AOCObj !RelInfo !(AnnBoolExp v) !(AnnObColG v) | AOCObjectRelation !RelInfo !v !(AnnOrderByElementG v)
| AOCAgg !RelInfo !(AnnBoolExp v) !AnnAggOrdBy | AOCArrayAggregation !RelInfo !v !AnnAggregateOrderBy
deriving (Show, Eq) deriving (Show, Eq, Generic, Functor)
instance (Hashable v) => Hashable (AnnOrderByElementG v)
traverseAnnObCol type AnnOrderByElement v = AnnOrderByElementG (AnnBoolExp v)
traverseAnnOrderByElement
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> AnnObColG a -> f (AnnObColG b) => (a -> f b) -> AnnOrderByElement a -> f (AnnOrderByElement b)
traverseAnnObCol f = \case traverseAnnOrderByElement f = \case
AOCPG pgColInfo -> pure $ AOCPG pgColInfo AOCColumn pgColInfo -> pure $ AOCColumn pgColInfo
AOCObj relInfo annBoolExp annObCol -> AOCObjectRelation relInfo annBoolExp annObCol ->
AOCObj relInfo AOCObjectRelation relInfo
<$> traverseAnnBoolExp f annBoolExp <$> traverseAnnBoolExp f annBoolExp
<*> traverseAnnObCol f annObCol <*> traverseAnnOrderByElement f annObCol
AOCAgg relInfo annBoolExp annAggOb -> AOCArrayAggregation relInfo annBoolExp annAggOb ->
AOCAgg relInfo AOCArrayAggregation relInfo
<$> traverseAnnBoolExp f annBoolExp <$> traverseAnnBoolExp f annBoolExp
<*> pure annAggOb <*> pure annAggOb
type AnnObCol = AnnObColG S.SQLExp type AnnOrderByItemG v = OrderByItemG (AnnOrderByElement v)
type AnnOrderByItemG v = OrderByItemG (AnnObColG v)
traverseAnnOrderByItem traverseAnnOrderByItem
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> AnnOrderByItemG a -> f (AnnOrderByItemG b) => (a -> f b) -> AnnOrderByItemG a -> f (AnnOrderByItemG b)
traverseAnnOrderByItem f = traverseAnnOrderByItem f =
traverse (traverseAnnObCol f) traverse (traverseAnnOrderByElement f)
type AnnOrderByItem = AnnOrderByItemG S.SQLExp type AnnOrderByItem = AnnOrderByItemG S.SQLExp
data AnnRelG a type OrderByItemExp =
= AnnRelG OrderByItemG (AnnOrderByElement S.SQLExp, (S.Alias, S.SQLExp))
{ aarName :: !RelName -- Relationship name
, aarMapping :: !(HashMap PGCol PGCol) -- Column of left table to join with data AnnRelationSelectG a
, aarAnnSel :: !a -- Current table. Almost ~ to SQL Select = AnnRelationSelectG
{ aarRelationshipName :: !RelName -- Relationship name
, aarColumnMapping :: !(HashMap PGCol PGCol) -- Column of left table to join with
, aarAnnSelect :: !a -- Current table. Almost ~ to SQL Select
} deriving (Show, Eq, Functor, Foldable, Traversable) } deriving (Show, Eq, Functor, Foldable, Traversable)
type ObjSelG v = AnnRelG (AnnSimpleSelG v) type ObjectRelationSelectG v = AnnRelationSelectG (AnnSimpleSelG v)
type ObjSel = ObjSelG S.SQLExp type ObjectRelationSelect = ObjectRelationSelectG S.SQLExp
type ArrRelG v = AnnRelG (AnnSimpleSelG v) type ArrayRelationSelectG v = AnnRelationSelectG (AnnSimpleSelG v)
type ArrRelAggG v = AnnRelG (AnnAggSelG v) type ArrayAggregateSelectG v = AnnRelationSelectG (AnnAggregateSelectG v)
type ArrRelAgg = ArrRelAggG S.SQLExp type ArrayConnectionSelect v = AnnRelationSelectG (ConnectionSelect v)
type ArrayAggregateSelect = ArrayAggregateSelectG S.SQLExp
data ComputedFieldScalarSel v data ComputedFieldScalarSelect v
= ComputedFieldScalarSel = ComputedFieldScalarSelect
{ _cfssFunction :: !QualifiedFunction { _cfssFunction :: !QualifiedFunction
, _cfssArguments :: !(FunctionArgsExpTableRow v) , _cfssArguments :: !(FunctionArgsExpTableRow v)
, _cfssType :: !PGScalarType , _cfssType :: !PGScalarType
, _cfssColumnOp :: !(Maybe ColOp) , _cfssColumnOp :: !(Maybe ColumnOp)
} deriving (Show, Eq, Functor, Foldable, Traversable) } deriving (Show, Eq, Functor, Foldable, Traversable)
data ComputedFieldSel v data ComputedFieldSelect v
= CFSScalar !(ComputedFieldScalarSel v) = CFSScalar !(ComputedFieldScalarSelect v)
| CFSTable !JsonAggSelect !(AnnSimpleSelG v) | CFSTable !JsonAggSelect !(AnnSimpleSelG v)
deriving (Show, Eq) deriving (Show, Eq)
traverseComputedFieldSel traverseComputedFieldSelect
:: (Applicative f) :: (Applicative f)
=> (v -> f w) => (v -> f w)
-> ComputedFieldSel v -> f (ComputedFieldSel w) -> ComputedFieldSelect v -> f (ComputedFieldSelect w)
traverseComputedFieldSel fv = \case traverseComputedFieldSelect fv = \case
CFSScalar scalarSel -> CFSScalar <$> traverse fv scalarSel CFSScalar scalarSel -> CFSScalar <$> traverse fv scalarSel
CFSTable b tableSel -> CFSTable b <$> traverseAnnSimpleSel fv tableSel CFSTable b tableSel -> CFSTable b <$> traverseAnnSimpleSelect fv tableSel
type Fields a = [(FieldName, a)] type Fields a = [(FieldName, a)]
data ArrSelG v data ArraySelectG v
= ASSimple !(ArrRelG v) = ASSimple !(ArrayRelationSelectG v)
| ASAgg !(ArrRelAggG v) | ASAggregate !(ArrayAggregateSelectG v)
| ASConnection !(ArrayConnectionSelect v)
deriving (Show, Eq) deriving (Show, Eq)
traverseArrSel traverseArraySelect
:: (Applicative f) :: (Applicative f)
=> (a -> f b) => (a -> f b)
-> ArrSelG a -> ArraySelectG a
-> f (ArrSelG b) -> f (ArraySelectG b)
traverseArrSel f = \case traverseArraySelect f = \case
ASSimple arrRel -> ASSimple <$> traverse (traverseAnnSimpleSel f) arrRel ASSimple arrRel ->
ASAgg arrRelAgg -> ASAgg <$> traverse (traverseAnnAggSel f) arrRelAgg ASSimple <$> traverse (traverseAnnSimpleSelect f) arrRel
ASAggregate arrRelAgg ->
ASAggregate <$> traverse (traverseAnnAggregateSelect f) arrRelAgg
ASConnection relConnection ->
ASConnection <$> traverse (traverseConnectionSelect f) relConnection
type ArrSel = ArrSelG S.SQLExp type ArraySelect = ArraySelectG S.SQLExp
type ArrSelFldsG v = Fields (ArrSelG v) type ArraySelectFieldsG v = Fields (ArraySelectG v)
data ColOp data ColumnOp
= ColOp = ColumnOp
{ _colOp :: S.SQLOp { _colOp :: S.SQLOp
, _colExp :: S.SQLExp , _colExp :: S.SQLExp
} deriving (Show, Eq) } deriving (Show, Eq)
data AnnColField data AnnColumnField
= AnnColField = AnnColumnField
{ _acfInfo :: !PGColumnInfo { _acfInfo :: !PGColumnInfo
, _acfAsText :: !Bool , _acfAsText :: !Bool
-- ^ If this field is 'True', columns are explicitly casted to @text@ when fetched, which avoids -- ^ If this field is 'True', columns are explicitly casted to @text@ when fetched, which avoids
-- an issue that occurs because we dont currently have proper support for array types. See -- an issue that occurs because we dont currently have proper support for array types. See
-- https://github.com/hasura/graphql-engine/pull/3198 for more details. -- https://github.com/hasura/graphql-engine/pull/3198 for more details.
, _acfOp :: !(Maybe ColOp) , _acfOp :: !(Maybe ColumnOp)
} deriving (Show, Eq) } deriving (Show, Eq)
data RemoteFieldArgument data RemoteFieldArgument
= RemoteFieldArgument = RemoteFieldArgument
{ _rfaName :: !G.Name { _rfaName :: !G.Name
, _rfaValue :: !(G.Value Variable) , _rfaValue :: !(G.Value Variable)
, _rfaVariable :: !(Maybe [(G.VariableDefinition,J.Value)]) , _rfaVariable :: !(Maybe [(G.VariableDefinition,J.Value)])
} deriving (Eq,Show) } deriving (Eq,Show)
@ -184,50 +196,53 @@ data RemoteSelect
, _rselRemoteSchema :: !RemoteSchemaInfo , _rselRemoteSchema :: !RemoteSchemaInfo
} deriving (Show,Eq) } deriving (Show,Eq)
data AnnFldG v data AnnFieldG v
= FCol !AnnColField = AFColumn !AnnColumnField
| FObj !(ObjSelG v) | AFObjectRelation !(ObjectRelationSelectG v)
| FArr !(ArrSelG v) | AFArrayRelation !(ArraySelectG v)
| FComputedField !(ComputedFieldSel v) | AFComputedField !(ComputedFieldSelect v)
| FExp !T.Text | AFRemote !RemoteSelect
| FRemote !RemoteSelect | AFNodeId !QualifiedTable !(NonEmpty PGColumnInfo)
deriving (Show,Eq) | AFExpression !T.Text
deriving (Show, Eq)
mkAnnColField :: PGColumnInfo -> Maybe ColOp -> AnnFldG v mkAnnColumnField :: PGColumnInfo -> Maybe ColumnOp -> AnnFieldG v
mkAnnColField ci colOpM = mkAnnColumnField ci colOpM =
FCol $ AnnColField ci False colOpM AFColumn $ AnnColumnField ci False colOpM
mkAnnColFieldAsText :: PGColumnInfo -> AnnFldG v mkAnnColumnFieldAsText :: PGColumnInfo -> AnnFieldG v
mkAnnColFieldAsText ci = mkAnnColumnFieldAsText ci =
FCol $ AnnColField ci True Nothing AFColumn $ AnnColumnField ci True Nothing
traverseAnnFld traverseAnnField
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> AnnFldG a -> f (AnnFldG b) => (a -> f b) -> AnnFieldG a -> f (AnnFieldG b)
traverseAnnFld f = \case traverseAnnField f = \case
FCol colFld -> pure $ FCol colFld AFColumn colFld -> pure $ AFColumn colFld
FObj sel -> FObj <$> traverse (traverseAnnSimpleSel f) sel AFObjectRelation sel -> AFObjectRelation <$> traverse (traverseAnnSimpleSelect f) sel
FArr sel -> FArr <$> traverseArrSel f sel AFArrayRelation sel -> AFArrayRelation <$> traverseArraySelect f sel
FComputedField sel -> FComputedField <$> traverseComputedFieldSel f sel AFComputedField sel -> AFComputedField <$> traverseComputedFieldSelect f sel
FExp t -> FExp <$> pure t AFRemote s -> pure $ AFRemote s
FRemote s -> pure $ FRemote s AFNodeId qt pKeys -> pure $ AFNodeId qt pKeys
AFExpression t -> AFExpression <$> pure t
type AnnFld = AnnFldG S.SQLExp type AnnField = AnnFieldG S.SQLExp
data TableArgsG v data SelectArgsG v
= TableArgs = SelectArgs
{ _taWhere :: !(Maybe (AnnBoolExp v)) { _saWhere :: !(Maybe (AnnBoolExp v))
, _taOrderBy :: !(Maybe (NE.NonEmpty (AnnOrderByItemG v))) , _saOrderBy :: !(Maybe (NE.NonEmpty (AnnOrderByItemG v)))
, _taLimit :: !(Maybe Int) , _saLimit :: !(Maybe Int)
, _taOffset :: !(Maybe S.SQLExp) , _saOffset :: !(Maybe S.SQLExp)
, _taDistCols :: !(Maybe (NE.NonEmpty PGCol)) , _saDistinct :: !(Maybe (NE.NonEmpty PGCol))
} deriving (Show, Eq) } deriving (Show, Eq, Generic)
instance (Hashable v) => Hashable (SelectArgsG v)
traverseTableArgs traverseSelectArgs
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> TableArgsG a -> f (TableArgsG b) => (a -> f b) -> SelectArgsG a -> f (SelectArgsG b)
traverseTableArgs f (TableArgs wh ordBy lmt ofst distCols) = traverseSelectArgs f (SelectArgs wh ordBy lmt ofst distCols) =
TableArgs SelectArgs
<$> traverse (traverseAnnBoolExp f) wh <$> traverse (traverseAnnBoolExp f) wh
-- traversing through maybe -> nonempty -> annorderbyitem -- traversing through maybe -> nonempty -> annorderbyitem
<*> traverse (traverse (traverseAnnOrderByItem f)) ordBy <*> traverse (traverse (traverseAnnOrderByItem f)) ordBy
@ -235,62 +250,103 @@ traverseTableArgs f (TableArgs wh ordBy lmt ofst distCols) =
<*> pure ofst <*> pure ofst
<*> pure distCols <*> pure distCols
type TableArgs = TableArgsG S.SQLExp type SelectArgs = SelectArgsG S.SQLExp
noTableArgs :: TableArgsG v noSelectArgs :: SelectArgsG v
noTableArgs = TableArgs Nothing Nothing Nothing Nothing Nothing noSelectArgs = SelectArgs Nothing Nothing Nothing Nothing Nothing
data PGColFld data PGColFld
= PCFCol !PGCol = PCFCol !PGCol
| PCFExp !T.Text | PCFExp !T.Text
deriving (Show, Eq) deriving (Show, Eq)
type ColFlds = Fields PGColFld type ColumnFields = Fields PGColFld
data AggOp data AggregateOp
= AggOp = AggregateOp
{ _aoOp :: !T.Text { _aoOp :: !T.Text
, _aoFlds :: !ColFlds , _aoFields :: !ColumnFields
} deriving (Show, Eq) } deriving (Show, Eq)
data AggFld data AggregateField
= AFCount !S.CountType = AFCount !S.CountType
| AFOp !AggOp | AFOp !AggregateOp
| AFExp !T.Text | AFExp !T.Text
deriving (Show, Eq) deriving (Show, Eq)
type AggFlds = Fields AggFld type AggregateFields = Fields AggregateField
type AnnFldsG v = Fields (AnnFldG v) type AnnFieldsG v = Fields (AnnFieldG v)
traverseAnnFlds traverseAnnFields
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> AnnFldsG a -> f (AnnFldsG b) => (a -> f b) -> AnnFieldsG a -> f (AnnFieldsG b)
traverseAnnFlds f = traverse (traverse (traverseAnnFld f)) traverseAnnFields f = traverse (traverse (traverseAnnField f))
type AnnFlds = AnnFldsG S.SQLExp type AnnFields = AnnFieldsG S.SQLExp
data TableAggFldG v data TableAggregateFieldG v
= TAFAgg !AggFlds = TAFAgg !AggregateFields
| TAFNodes !(AnnFldsG v) | TAFNodes !(AnnFieldsG v)
| TAFExp !T.Text | TAFExp !T.Text
deriving (Show, Eq) deriving (Show, Eq)
traverseTableAggFld data PageInfoField
= PageInfoTypename !Text
| PageInfoHasNextPage
| PageInfoHasPreviousPage
| PageInfoStartCursor
| PageInfoEndCursor
deriving (Show, Eq)
type PageInfoFields = Fields PageInfoField
data EdgeField v
= EdgeTypename !Text
| EdgeCursor
| EdgeNode !(AnnFieldsG v)
deriving (Show, Eq)
type EdgeFields v = Fields (EdgeField v)
traverseEdgeField
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> TableAggFldG a -> f (TableAggFldG b) => (a -> f b) -> EdgeField a -> f (EdgeField b)
traverseTableAggFld f = \case traverseEdgeField f = \case
EdgeTypename t -> pure $ EdgeTypename t
EdgeCursor -> pure EdgeCursor
EdgeNode fields -> EdgeNode <$> traverseAnnFields f fields
data ConnectionField v
= ConnectionTypename !Text
| ConnectionPageInfo !PageInfoFields
| ConnectionEdges !(EdgeFields v)
deriving (Show, Eq)
type ConnectionFields v = Fields (ConnectionField v)
traverseConnectionField
:: (Applicative f)
=> (a -> f b) -> ConnectionField a -> f (ConnectionField b)
traverseConnectionField f = \case
ConnectionTypename t -> pure $ ConnectionTypename t
ConnectionPageInfo fields -> pure $ ConnectionPageInfo fields
ConnectionEdges fields ->
ConnectionEdges <$> traverse (traverse (traverseEdgeField f)) fields
traverseTableAggregateField
:: (Applicative f)
=> (a -> f b) -> TableAggregateFieldG a -> f (TableAggregateFieldG b)
traverseTableAggregateField f = \case
TAFAgg aggFlds -> pure $ TAFAgg aggFlds TAFAgg aggFlds -> pure $ TAFAgg aggFlds
TAFNodes annFlds -> TAFNodes <$> traverseAnnFlds f annFlds TAFNodes annFlds -> TAFNodes <$> traverseAnnFields f annFlds
TAFExp t -> pure $ TAFExp t TAFExp t -> pure $ TAFExp t
type TableAggFld = TableAggFldG S.SQLExp type TableAggregateField = TableAggregateFieldG S.SQLExp
type TableAggFldsG v = Fields (TableAggFldG v) type TableAggregateFieldsG v = Fields (TableAggregateFieldG v)
type TableAggFlds = TableAggFldsG S.SQLExp type TableAggregateFields = TableAggregateFieldsG S.SQLExp
data ArgumentExp a data ArgumentExp a
= AETableRow !(Maybe Iden) -- ^ table row accessor = AETableRow !(Maybe Iden) -- ^ table row accessor
| AEInput !a | AEInput !a
deriving (Show, Eq, Functor, Foldable, Traversable) deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance (Hashable v) => Hashable (ArgumentExp v)
type FunctionArgsExpTableRow v = FunctionArgsExpG (ArgumentExp v) type FunctionArgsExpTableRow v = FunctionArgsExpG (ArgumentExp v)
@ -299,8 +355,10 @@ data SelectFromG v
| FromIden !Iden | FromIden !Iden
| FromFunction !QualifiedFunction | FromFunction !QualifiedFunction
!(FunctionArgsExpTableRow v) !(FunctionArgsExpTableRow v)
-- a definition list
!(Maybe [(PGCol, PGScalarType)]) !(Maybe [(PGCol, PGScalarType)])
deriving (Show, Eq, Functor, Foldable, Traversable) deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance (Hashable v) => Hashable (SelectFromG v)
type SelectFrom = SelectFromG S.SQLExp type SelectFrom = SelectFromG S.SQLExp
@ -308,7 +366,8 @@ data TablePermG v
= TablePerm = TablePerm
{ _tpFilter :: !(AnnBoolExp v) { _tpFilter :: !(AnnBoolExp v)
, _tpLimit :: !(Maybe Int) , _tpLimit :: !(Maybe Int)
} deriving (Eq, Show) } deriving (Eq, Show, Generic)
instance (Hashable v) => Hashable (TablePermG v)
traverseTablePerm traverseTablePerm
:: (Applicative f) :: (Applicative f)
@ -326,62 +385,105 @@ noTablePermissions =
type TablePerm = TablePermG S.SQLExp type TablePerm = TablePermG S.SQLExp
data AnnSelG a v data AnnSelectG a v
= AnnSelG = AnnSelectG
{ _asnFields :: !a { _asnFields :: !a
, _asnFrom :: !(SelectFromG v) , _asnFrom :: !(SelectFromG v)
, _asnPerm :: !(TablePermG v) , _asnPerm :: !(TablePermG v)
, _asnArgs :: !(TableArgsG v) , _asnArgs :: !(SelectArgsG v)
, _asnStrfyNum :: !Bool , _asnStrfyNum :: !Bool
} deriving (Show, Eq) } deriving (Show, Eq)
getPermLimit :: AnnSelG a v -> Maybe Int traverseAnnSimpleSelect
getPermLimit = _tpLimit . _asnPerm
traverseAnnSimpleSel
:: (Applicative f) :: (Applicative f)
=> (a -> f b) => (a -> f b)
-> AnnSimpleSelG a -> f (AnnSimpleSelG b) -> AnnSimpleSelG a -> f (AnnSimpleSelG b)
traverseAnnSimpleSel f = traverseAnnSel (traverseAnnFlds f) f traverseAnnSimpleSelect f = traverseAnnSelect (traverseAnnFields f) f
traverseAnnAggSel traverseAnnAggregateSelect
:: (Applicative f) :: (Applicative f)
=> (a -> f b) => (a -> f b)
-> AnnAggSelG a -> f (AnnAggSelG b) -> AnnAggregateSelectG a -> f (AnnAggregateSelectG b)
traverseAnnAggSel f = traverseAnnAggregateSelect f =
traverseAnnSel (traverse (traverse (traverseTableAggFld f))) f traverseAnnSelect (traverse (traverse (traverseTableAggregateField f))) f
traverseAnnSel traverseAnnSelect
:: (Applicative f) :: (Applicative f)
=> (a -> f b) -> (v -> f w) => (a -> f b) -> (v -> f w)
-> AnnSelG a v -> f (AnnSelG b w) -> AnnSelectG a v -> f (AnnSelectG b w)
traverseAnnSel f1 f2 (AnnSelG flds tabFrom perm args strfyNum) = traverseAnnSelect f1 f2 (AnnSelectG flds tabFrom perm args strfyNum) =
AnnSelG AnnSelectG
<$> f1 flds <$> f1 flds
<*> traverse f2 tabFrom <*> traverse f2 tabFrom
<*> traverseTablePerm f2 perm <*> traverseTablePerm f2 perm
<*> traverseTableArgs f2 args <*> traverseSelectArgs f2 args
<*> pure strfyNum <*> pure strfyNum
type AnnSimpleSelG v = AnnSelG (AnnFldsG v) v type AnnSimpleSelG v = AnnSelectG (AnnFieldsG v) v
type AnnSimpleSel = AnnSimpleSelG S.SQLExp type AnnSimpleSel = AnnSimpleSelG S.SQLExp
type AnnAggSelG v = AnnSelG (TableAggFldsG v) v type AnnAggregateSelectG v = AnnSelectG (TableAggregateFieldsG v) v
type AnnAggSel = AnnAggSelG S.SQLExp type AnnAggregateSelect = AnnAggregateSelectG S.SQLExp
data ConnectionSlice
= SliceFirst !Int
| SliceLast !Int
deriving (Show, Eq, Generic)
instance Hashable ConnectionSlice
data ConnectionSplitKind
= CSKBefore
| CSKAfter
deriving (Show, Eq, Generic)
instance Hashable ConnectionSplitKind
data ConnectionSplit v
= ConnectionSplit
{ _csKind :: !ConnectionSplitKind
, _csValue :: !v
, _csOrderBy :: !(OrderByItemG (AnnOrderByElementG ()))
} deriving (Show, Eq, Functor, Generic, Foldable, Traversable)
instance (Hashable v) => Hashable (ConnectionSplit v)
traverseConnectionSplit
:: (Applicative f)
=> (a -> f b) -> ConnectionSplit a -> f (ConnectionSplit b)
traverseConnectionSplit f (ConnectionSplit k v ob) =
ConnectionSplit k <$> f v <*> pure ob
data ConnectionSelect v
= ConnectionSelect
{ _csPrimaryKeyColumns :: !(NE.NonEmpty PGColumnInfo)
, _csSplit :: !(Maybe (NE.NonEmpty (ConnectionSplit v)))
, _csSlice :: !(Maybe ConnectionSlice)
, _csSelect :: !(AnnSelectG (ConnectionFields v) v)
} deriving (Show, Eq)
traverseConnectionSelect
:: (Applicative f)
=> (a -> f b)
-> ConnectionSelect a -> f (ConnectionSelect b)
traverseConnectionSelect f (ConnectionSelect pkCols cSplit cSlice sel) =
ConnectionSelect pkCols
<$> traverse (traverse (traverseConnectionSplit f)) cSplit
<*> pure cSlice
<*> traverseAnnSelect (traverse (traverse (traverseConnectionField f))) f sel
data FunctionArgsExpG a data FunctionArgsExpG a
= FunctionArgsExp = FunctionArgsExp
{ _faePositional :: ![a] { _faePositional :: ![a]
, _faeNamed :: !(HM.HashMap Text a) , _faeNamed :: !(HM.HashMap Text a)
} deriving (Show, Eq, Functor, Foldable, Traversable) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance (Hashable a) => Hashable (FunctionArgsExpG a)
emptyFunctionArgsExp :: FunctionArgsExpG a emptyFunctionArgsExp :: FunctionArgsExpG a
emptyFunctionArgsExp = FunctionArgsExp [] HM.empty emptyFunctionArgsExp = FunctionArgsExp [] HM.empty
type FunctionArgExp = FunctionArgsExpG S.SQLExp type FunctionArgExp = FunctionArgsExpG S.SQLExp
-- | If argument positional index is less than or equal to length of 'positional' arguments then -- | If argument positional index is less than or equal to length of
-- insert the value in 'positional' arguments else insert the value with argument name in 'named' arguments -- 'positional' arguments then insert the value in 'positional' arguments else
-- insert the value with argument name in 'named' arguments
insertFunctionArg insertFunctionArg
:: FunctionArgName :: FunctionArgName
-> Int -> Int
@ -396,113 +498,106 @@ insertFunctionArg argName index value (FunctionArgsExp positional named) =
where where
insertAt i a = toList . Seq.insertAt i a . Seq.fromList insertAt i a = toList . Seq.insertAt i a . Seq.fromList
data BaseNode data SourcePrefixes
= BaseNode = SourcePrefixes
{ _bnPrefix :: !Iden { _pfThis :: !Iden -- ^ Current source prefix
, _bnDistinct :: !(Maybe S.DistinctExpr) , _pfBase :: !Iden
, _bnFrom :: !S.FromItem -- ^ Base table source row identifier to generate
, _bnWhere :: !S.BoolExp -- the table's column identifiers for computed field
, _bnOrderBy :: !(Maybe S.OrderByExp) -- function input parameters
, _bnLimit :: !(Maybe Int) } deriving (Show, Eq, Generic)
, _bnOffset :: !(Maybe S.SQLExp) instance Hashable SourcePrefixes
, _bnExtrs :: !(HM.HashMap S.Alias S.SQLExp) data SelectSource
, _bnObjs :: !(HM.HashMap RelName ObjNode) = SelectSource
, _bnArrs :: !(HM.HashMap S.Alias ArrNode) { _ssPrefix :: !Iden
, _bnComputedFieldTables :: !(HM.HashMap FieldName CFTableNode) , _ssFrom :: !S.FromItem
, _ssDistinct :: !(Maybe S.DistinctExpr)
, _ssWhere :: !S.BoolExp
, _ssOrderBy :: !(Maybe S.OrderByExp)
, _ssLimit :: !(Maybe Int)
, _ssOffset :: !(Maybe S.SQLExp)
} deriving (Show, Eq, Generic)
instance Hashable SelectSource
data SelectNode
= SelectNode
{ _snExtractors :: !(HM.HashMap S.Alias S.SQLExp)
, _snJoinTree :: !JoinTree
} deriving (Show, Eq) } deriving (Show, Eq)
mergeBaseNodes :: BaseNode -> BaseNode -> BaseNode instance Semigroup SelectNode where
mergeBaseNodes lNodeDet rNodeDet = SelectNode lExtrs lJoinTree <> SelectNode rExtrs rJoinTree =
BaseNode pfx dExp f whr ordBy limit offset SelectNode (lExtrs <> rExtrs) (lJoinTree <> rJoinTree)
(HM.union lExtrs rExtrs)
(HM.unionWith mergeObjNodes lObjs rObjs)
(HM.unionWith mergeArrNodes lArrs rArrs)
(HM.unionWith mergeCFTableNodes lCFTables rCFTables)
where
BaseNode pfx dExp f whr ordBy limit offset lExtrs lObjs lArrs lCFTables
= lNodeDet
BaseNode _ _ _ _ _ _ _ rExtrs rObjs rArrs rCFTables
= rNodeDet
data OrderByNode data ObjectRelationSource
= OBNNothing = ObjectRelationSource
| OBNObjNode !RelName !ObjNode { _orsRelationshipName :: !RelName
| OBNArrNode !S.Alias !ArrNode , _orsRelationMapping :: !(HM.HashMap PGCol PGCol)
, _orsSelectSource :: !SelectSource
} deriving (Show, Eq, Generic)
instance Hashable ObjectRelationSource
data ArrayRelationSource
= ArrayRelationSource
{ _arsAlias :: !S.Alias
, _arsRelationMapping :: !(HM.HashMap PGCol PGCol)
, _arsSelectSource :: !SelectSource
} deriving (Show, Eq, Generic)
instance Hashable ArrayRelationSource
data ArraySelectNode
= ArraySelectNode
{ _asnTopExtractors :: ![S.Extractor]
, _asnSelectNode :: !SelectNode
} deriving (Show, Eq)
instance Semigroup ArraySelectNode where
ArraySelectNode lTopExtrs lSelNode <> ArraySelectNode rTopExtrs rSelNode =
ArraySelectNode (lTopExtrs <> rTopExtrs) (lSelNode <> rSelNode)
data ComputedFieldTableSetSource
= ComputedFieldTableSetSource
{ _cftssFieldName :: !FieldName
, _cftssSelectType :: !JsonAggSelect
, _cftssSelectSource :: !SelectSource
} deriving (Show, Eq, Generic)
instance Hashable ComputedFieldTableSetSource
data ArrayConnectionSource
= ArrayConnectionSource
{ _acsAlias :: !S.Alias
, _acsRelationMapping :: !(HM.HashMap PGCol PGCol)
, _acsSplitFilter :: !(Maybe S.BoolExp)
, _acsSlice :: !(Maybe ConnectionSlice)
, _acsSource :: !SelectSource
} deriving (Show, Eq, Generic)
instance Hashable ArrayConnectionSource
data JoinTree
= JoinTree
{ _jtObjectRelations :: !(HM.HashMap ObjectRelationSource SelectNode)
, _jtArrayRelations :: !(HM.HashMap ArrayRelationSource ArraySelectNode)
, _jtArrayConnections :: !(HM.HashMap ArrayConnectionSource ArraySelectNode)
, _jtComputedFieldTableSets :: !(HM.HashMap ComputedFieldTableSetSource SelectNode)
} deriving (Show, Eq)
instance Semigroup JoinTree where
JoinTree lObjs lArrs lArrConns lCfts <> JoinTree rObjs rArrs rArrConns rCfts =
JoinTree (HM.unionWith (<>) lObjs rObjs)
(HM.unionWith (<>) lArrs rArrs)
(HM.unionWith (<>) lArrConns rArrConns)
(HM.unionWith (<>) lCfts rCfts)
instance Monoid JoinTree where
mempty = JoinTree mempty mempty mempty mempty
data PermissionLimitSubQuery
= PLSQRequired !Int -- ^ Permission limit
| PLSQNotRequired
deriving (Show, Eq) deriving (Show, Eq)
data ArrRelCtxG v $(makeLenses ''AnnSelectG)
= ArrRelCtx $(makePrisms ''AnnFieldG)
{ aacFields :: !(ArrSelFldsG v) $(makePrisms ''AnnOrderByElementG)
, aacAggOrdBys :: ![RelName]
} deriving (Show, Eq)
type ArrRelCtx = ArrRelCtxG S.SQLExp
emptyArrRelCtx :: ArrRelCtxG a
emptyArrRelCtx = ArrRelCtx [] []
data ArrNodeItemG v
= ANIField !(FieldName, ArrSelG v)
| ANIAggOrdBy !RelName
deriving (Show, Eq)
type ArrNodeItem = ArrNodeItemG S.SQLExp
data ObjNode
= ObjNode
{ _rnRelMapping :: !(HashMap PGCol PGCol)
, _rnNodeDet :: !BaseNode
} deriving (Show, Eq)
mergeObjNodes :: ObjNode -> ObjNode -> ObjNode
mergeObjNodes lNode rNode =
ObjNode colMapping $ mergeBaseNodes lBN rBN
where
ObjNode colMapping lBN = lNode
ObjNode _ rBN = rNode
-- simple array select, aggregate select and order by
-- nodes differ in extractors
data ArrNode
= ArrNode
{ _anExtr :: ![S.Extractor]
, _anRelMapping :: !(HashMap PGCol PGCol)
, _anNodeDet :: !BaseNode
} deriving (Show, Eq)
mergeArrNodes :: ArrNode -> ArrNode -> ArrNode
mergeArrNodes lNode rNode =
ArrNode (lExtrs `union` rExtrs) colMapping $
mergeBaseNodes lBN rBN
where
ArrNode lExtrs colMapping lBN = lNode
ArrNode rExtrs _ rBN = rNode
data ArrNodeInfo
= ArrNodeInfo
{ _aniAlias :: !S.Alias
, _aniPrefix :: !Iden
, _aniSubQueryRequired :: !Bool
} deriving (Show, Eq)
-- | Node for computed field returning setof <table>
data CFTableNode
= CFTableNode
{ _ctnSelectType :: !JsonAggSelect
, _ctnNode :: !BaseNode
} deriving (Show, Eq)
mergeCFTableNodes :: CFTableNode -> CFTableNode -> CFTableNode
mergeCFTableNodes lNode rNode =
CFTableNode
(_ctnSelectType rNode)
(mergeBaseNodes (_ctnNode lNode) (_ctnNode rNode))
data Prefixes
= Prefixes
{ _pfThis :: !Iden -- Current node prefix
, _pfBase :: !Iden -- Base table row identifier for computed field function
} deriving (Show, Eq)
$(makePrisms ''AnnFldG)

View File

@ -55,9 +55,9 @@ import Hasura.RQL.DDL.Headers
import Hasura.RQL.DML.Select.Types import Hasura.RQL.DML.Select.Types
import Hasura.RQL.Types.CustomTypes import Hasura.RQL.Types.CustomTypes
import Hasura.RQL.Types.Permission import Hasura.RQL.Types.Permission
import Hasura.Session
import Hasura.SQL.Types import Hasura.SQL.Types
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Hasura.Session
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J import qualified Data.Aeson.Casing as J
@ -273,7 +273,7 @@ data AnnActionExecution v
= AnnActionExecution = AnnActionExecution
{ _aaeName :: !ActionName { _aaeName :: !ActionName
, _aaeOutputType :: !GraphQLType -- ^ output type , _aaeOutputType :: !GraphQLType -- ^ output type
, _aaeFields :: !(AnnFldsG v) -- ^ output selection , _aaeFields :: !(AnnFieldsG v) -- ^ output selection
, _aaePayload :: !J.Value -- ^ jsonified input arguments , _aaePayload :: !J.Value -- ^ jsonified input arguments
, _aaeOutputFields :: !ActionOutputFields , _aaeOutputFields :: !ActionOutputFields
-- ^ to validate the response fields from webhook -- ^ to validate the response fields from webhook
@ -292,7 +292,7 @@ data AnnActionMutationAsync
data AsyncActionQueryFieldG v data AsyncActionQueryFieldG v
= AsyncTypename !Text = AsyncTypename !Text
| AsyncOutput !(AnnFldsG v) | AsyncOutput !(AnnFieldsG v)
| AsyncId | AsyncId
| AsyncCreatedAt | AsyncCreatedAt
| AsyncErrors | AsyncErrors

View File

@ -66,6 +66,7 @@ data GExists a
instance (NFData a) => NFData (GExists a) instance (NFData a) => NFData (GExists a)
instance (Data a) => Plated (GExists a) instance (Data a) => Plated (GExists a)
instance (Cacheable a) => Cacheable (GExists a) instance (Cacheable a) => Cacheable (GExists a)
instance (Hashable a) => Hashable (GExists a)
gExistsToJSON :: (a -> (Text, Value)) -> GExists a -> Value gExistsToJSON :: (a -> (Text, Value)) -> GExists a -> Value
gExistsToJSON f (GExists qt wh) = gExistsToJSON f (GExists qt wh) =
@ -92,6 +93,7 @@ data GBoolExp a
instance (NFData a) => NFData (GBoolExp a) instance (NFData a) => NFData (GBoolExp a)
instance (Data a) => Plated (GBoolExp a) instance (Data a) => Plated (GBoolExp a)
instance (Cacheable a) => Cacheable (GBoolExp a) instance (Cacheable a) => Cacheable (GBoolExp a)
instance (Hashable a) => Hashable (GBoolExp a)
gBoolExpTrue :: GBoolExp a gBoolExpTrue :: GBoolExp a
gBoolExpTrue = BoolAnd [] gBoolExpTrue = BoolAnd []
@ -143,6 +145,7 @@ data DWithinGeomOp a =
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (DWithinGeomOp a) instance (NFData a) => NFData (DWithinGeomOp a)
instance (Cacheable a) => Cacheable (DWithinGeomOp a) instance (Cacheable a) => Cacheable (DWithinGeomOp a)
instance (Hashable a) => Hashable (DWithinGeomOp a)
$(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeomOp) $(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeomOp)
data DWithinGeogOp a = data DWithinGeogOp a =
@ -153,6 +156,7 @@ data DWithinGeogOp a =
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (DWithinGeogOp a) instance (NFData a) => NFData (DWithinGeogOp a)
instance (Cacheable a) => Cacheable (DWithinGeogOp a) instance (Cacheable a) => Cacheable (DWithinGeogOp a)
instance (Hashable a) => Hashable (DWithinGeogOp a)
$(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeogOp) $(deriveJSON (aesonDrop 6 snakeCase) ''DWithinGeogOp)
data STIntersectsNbandGeommin a = data STIntersectsNbandGeommin a =
@ -162,6 +166,7 @@ data STIntersectsNbandGeommin a =
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (STIntersectsNbandGeommin a) instance (NFData a) => NFData (STIntersectsNbandGeommin a)
instance (Cacheable a) => Cacheable (STIntersectsNbandGeommin a) instance (Cacheable a) => Cacheable (STIntersectsNbandGeommin a)
instance (Hashable a) => Hashable (STIntersectsNbandGeommin a)
$(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsNbandGeommin) $(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsNbandGeommin)
data STIntersectsGeomminNband a = data STIntersectsGeomminNband a =
@ -171,6 +176,7 @@ data STIntersectsGeomminNband a =
} deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (STIntersectsGeomminNband a) instance (NFData a) => NFData (STIntersectsGeomminNband a)
instance (Cacheable a) => Cacheable (STIntersectsGeomminNband a) instance (Cacheable a) => Cacheable (STIntersectsGeomminNband a)
instance (Hashable a) => Hashable (STIntersectsGeomminNband a)
$(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsGeomminNband) $(deriveJSON (aesonDrop 4 snakeCase) ''STIntersectsGeomminNband)
type CastExp a = M.HashMap PGScalarType [OpExpG a] type CastExp a = M.HashMap PGScalarType [OpExpG a]
@ -230,6 +236,7 @@ data OpExpG a
deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Data) deriving (Eq, Show, Functor, Foldable, Traversable, Generic, Data)
instance (NFData a) => NFData (OpExpG a) instance (NFData a) => NFData (OpExpG a)
instance (Cacheable a) => Cacheable (OpExpG a) instance (Cacheable a) => Cacheable (OpExpG a)
instance (Hashable a) => Hashable (OpExpG a)
opExpDepCol :: OpExpG a -> Maybe PGCol opExpDepCol :: OpExpG a -> Maybe PGCol
opExpDepCol = \case opExpDepCol = \case
@ -303,6 +310,7 @@ data AnnBoolExpFld a
deriving (Show, Eq, Functor, Foldable, Traversable, Generic) deriving (Show, Eq, Functor, Foldable, Traversable, Generic)
instance (NFData a) => NFData (AnnBoolExpFld a) instance (NFData a) => NFData (AnnBoolExpFld a)
instance (Cacheable a) => Cacheable (AnnBoolExpFld a) instance (Cacheable a) => Cacheable (AnnBoolExpFld a)
instance (Hashable a) => Hashable (AnnBoolExpFld a)
type AnnBoolExp a type AnnBoolExp a
= GBoolExp (AnnBoolExpFld a) = GBoolExp (AnnBoolExpFld a)

View File

@ -143,6 +143,7 @@ data RelInfo
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic)
instance NFData RelInfo instance NFData RelInfo
instance Cacheable RelInfo instance Cacheable RelInfo
instance Hashable RelInfo
$(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo) $(deriveToJSON (aesonDrop 2 snakeCase) ''RelInfo)
newtype FieldName newtype FieldName
@ -150,6 +151,7 @@ newtype FieldName
deriving ( Show, Eq, Ord, Hashable, FromJSON, ToJSON deriving ( Show, Eq, Ord, Hashable, FromJSON, ToJSON
, FromJSONKey, ToJSONKey, Lift, Data, Generic , FromJSONKey, ToJSONKey, Lift, Data, Generic
, IsString, Arbitrary, NFData, Cacheable , IsString, Arbitrary, NFData, Cacheable
, Semigroup
) )
instance IsIden FieldName where instance IsIden FieldName where
@ -212,7 +214,7 @@ data PrimaryKey a
= PrimaryKey = PrimaryKey
{ _pkConstraint :: !Constraint { _pkConstraint :: !Constraint
, _pkColumns :: !(NESeq a) , _pkColumns :: !(NESeq a)
} deriving (Show, Eq, Generic) } deriving (Show, Eq, Generic, Foldable)
instance (NFData a) => NFData (PrimaryKey a) instance (NFData a) => NFData (PrimaryKey a)
instance (Cacheable a) => Cacheable (PrimaryKey a) instance (Cacheable a) => Cacheable (PrimaryKey a)
$(makeLenses ''PrimaryKey) $(makeLenses ''PrimaryKey)

View File

@ -101,6 +101,7 @@ instance (FromJSON a) => FromJSON (DMLQuery a) where
newtype OrderType newtype OrderType
= OrderType { unOrderType :: S.OrderType } = OrderType { unOrderType :: S.OrderType }
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance Hashable OrderType
instance FromJSON OrderType where instance FromJSON OrderType where
parseJSON = parseJSON =
@ -112,6 +113,7 @@ instance FromJSON OrderType where
newtype NullsOrder newtype NullsOrder
= NullsOrder { unNullsOrder :: S.NullsOrder } = NullsOrder { unNullsOrder :: S.NullsOrder }
deriving (Show, Eq, Lift, Generic) deriving (Show, Eq, Lift, Generic)
instance Hashable NullsOrder
instance FromJSON NullsOrder where instance FromJSON NullsOrder where
parseJSON = parseJSON =
@ -176,7 +178,8 @@ data OrderByItemG a
{ obiType :: !(Maybe OrderType) { obiType :: !(Maybe OrderType)
, obiColumn :: !a , obiColumn :: !a
, obiNulls :: !(Maybe NullsOrder) , obiNulls :: !(Maybe NullsOrder)
} deriving (Show, Eq, Lift, Functor, Foldable, Traversable) } deriving (Show, Eq, Lift, Functor, Foldable, Traversable, Generic)
instance (Hashable a) => Hashable (OrderByItemG a)
type OrderByItem = OrderByItemG OrderByCol type OrderByItem = OrderByItemG OrderByCol

View File

@ -133,8 +133,8 @@ import Hasura.RQL.Types.QueryCollection
import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.SchemaCacheTypes import Hasura.RQL.Types.SchemaCacheTypes
import Hasura.RQL.Types.Table import Hasura.RQL.Types.Table
import Hasura.SQL.Types
import Hasura.Session import Hasura.Session
import Hasura.SQL.Types
import Data.Aeson import Data.Aeson
import Data.Aeson.Casing import Data.Aeson.Casing
@ -198,18 +198,18 @@ type ActionCache = M.HashMap ActionName ActionInfo -- info of all actions
data SchemaCache data SchemaCache
= SchemaCache = SchemaCache
{ scTables :: !TableCache { scTables :: !TableCache
, scActions :: !ActionCache , scActions :: !ActionCache
, scFunctions :: !FunctionCache , scFunctions :: !FunctionCache
, scRemoteSchemas :: !RemoteSchemaMap , scRemoteSchemas :: !RemoteSchemaMap
, scAllowlist :: !(HS.HashSet GQLQuery) , scAllowlist :: !(HS.HashSet GQLQuery)
, scGQLContext :: !(HashMap RoleName GQLContext) , scGQLContext :: !(HashMap RoleName GQLContext)
, scUnauthenticatedGQLContext :: !GQLContext , scUnauthenticatedGQLContext :: !GQLContext
, scRelayContext :: !(HashMap RoleName GQLContext) , scRelayContext :: !(HashMap RoleName GQLContext)
, scUnauthenticatedRelayContext :: !GQLContext , scUnauthenticatedRelayContext :: !GQLContext
-- , scCustomTypes :: !(NonObjectTypeMap, AnnotatedObjects) -- , scCustomTypes :: !(NonObjectTypeMap, AnnotatedObjects)
, scDepMap :: !DepMap , scDepMap :: !DepMap
, scInconsistentObjs :: ![InconsistentMetadata] , scInconsistentObjs :: ![InconsistentMetadata]
} }
$(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaCache) $(deriveToJSON (aesonDrop 2 snakeCase) ''SchemaCache)

View File

@ -35,6 +35,7 @@ data Select
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData Select instance NFData Select
instance Cacheable Select instance Cacheable Select
instance Hashable Select
mkSelect :: Select mkSelect :: Select
mkSelect = Select Nothing [] Nothing mkSelect = Select Nothing [] Nothing
@ -43,7 +44,7 @@ mkSelect = Select Nothing [] Nothing
newtype LimitExp newtype LimitExp
= LimitExp SQLExp = LimitExp SQLExp
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL LimitExp where instance ToSQL LimitExp where
toSQL (LimitExp se) = toSQL (LimitExp se) =
@ -51,15 +52,15 @@ instance ToSQL LimitExp where
newtype OffsetExp newtype OffsetExp
= OffsetExp SQLExp = OffsetExp SQLExp
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL OffsetExp where instance ToSQL OffsetExp where
toSQL (OffsetExp se) = toSQL (OffsetExp se) =
"OFFSET" <-> toSQL se "OFFSET" <-> toSQL se
newtype OrderByExp newtype OrderByExp
= OrderByExp [OrderByItem] = OrderByExp (NonEmpty OrderByItem)
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
data OrderByItem data OrderByItem
= OrderByItem = OrderByItem
@ -69,6 +70,7 @@ data OrderByItem
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData OrderByItem instance NFData OrderByItem
instance Cacheable OrderByItem instance Cacheable OrderByItem
instance Hashable OrderByItem
instance ToSQL OrderByItem where instance ToSQL OrderByItem where
toSQL (OrderByItem e ot no) = toSQL (OrderByItem e ot no) =
@ -78,6 +80,7 @@ data OrderType = OTAsc | OTDesc
deriving (Show, Eq, Lift, Generic, Data) deriving (Show, Eq, Lift, Generic, Data)
instance NFData OrderType instance NFData OrderType
instance Cacheable OrderType instance Cacheable OrderType
instance Hashable OrderType
instance ToSQL OrderType where instance ToSQL OrderType where
toSQL OTAsc = "ASC" toSQL OTAsc = "ASC"
@ -89,6 +92,7 @@ data NullsOrder
deriving (Show, Eq, Lift, Generic, Data) deriving (Show, Eq, Lift, Generic, Data)
instance NFData NullsOrder instance NFData NullsOrder
instance Cacheable NullsOrder instance Cacheable NullsOrder
instance Hashable NullsOrder
instance ToSQL NullsOrder where instance ToSQL NullsOrder where
toSQL NFirst = "NULLS FIRST" toSQL NFirst = "NULLS FIRST"
@ -96,11 +100,11 @@ instance ToSQL NullsOrder where
instance ToSQL OrderByExp where instance ToSQL OrderByExp where
toSQL (OrderByExp l) = toSQL (OrderByExp l) =
"ORDER BY" <-> (", " <+> l) "ORDER BY" <-> (", " <+> toList l)
newtype GroupByExp newtype GroupByExp
= GroupByExp [SQLExp] = GroupByExp [SQLExp]
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL GroupByExp where instance ToSQL GroupByExp where
toSQL (GroupByExp idens) = toSQL (GroupByExp idens) =
@ -108,7 +112,7 @@ instance ToSQL GroupByExp where
newtype FromExp newtype FromExp
= FromExp [FromItem] = FromExp [FromItem]
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL FromExp where instance ToSQL FromExp where
toSQL (FromExp items) = toSQL (FromExp items) =
@ -148,7 +152,7 @@ mkRowExp extrs = let
newtype HavingExp newtype HavingExp
= HavingExp BoolExp = HavingExp BoolExp
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL HavingExp where instance ToSQL HavingExp where
toSQL (HavingExp be) = toSQL (HavingExp be) =
@ -156,7 +160,7 @@ instance ToSQL HavingExp where
newtype WhereFrag newtype WhereFrag
= WhereFrag { getWFBoolExp :: BoolExp } = WhereFrag { getWFBoolExp :: BoolExp }
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL WhereFrag where instance ToSQL WhereFrag where
toSQL (WhereFrag be) = toSQL (WhereFrag be) =
@ -188,6 +192,7 @@ data Qual
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData Qual instance NFData Qual
instance Cacheable Qual instance Cacheable Qual
instance Hashable Qual
mkQual :: QualifiedTable -> Qual mkQual :: QualifiedTable -> Qual
mkQual = QualTable mkQual = QualTable
@ -205,6 +210,7 @@ data QIden
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData QIden instance NFData QIden
instance Cacheable QIden instance Cacheable QIden
instance Hashable QIden
instance ToSQL QIden where instance ToSQL QIden where
toSQL (QIden qual iden) = toSQL (QIden qual iden) =
@ -212,7 +218,7 @@ instance ToSQL QIden where
newtype SQLOp newtype SQLOp
= SQLOp {sqlOpTxt :: T.Text} = SQLOp {sqlOpTxt :: T.Text}
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
incOp :: SQLOp incOp :: SQLOp
incOp = SQLOp "+" incOp = SQLOp "+"
@ -234,7 +240,7 @@ jsonbDeleteAtPathOp = SQLOp "#-"
newtype TypeAnn newtype TypeAnn
= TypeAnn { unTypeAnn :: T.Text } = TypeAnn { unTypeAnn :: T.Text }
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL TypeAnn where instance ToSQL TypeAnn where
toSQL (TypeAnn ty) = "::" <> TB.text ty toSQL (TypeAnn ty) = "::" <> TB.text ty
@ -260,6 +266,9 @@ jsonTypeAnn = mkTypeAnn $ PGTypeScalar PGJSON
jsonbTypeAnn :: TypeAnn jsonbTypeAnn :: TypeAnn
jsonbTypeAnn = mkTypeAnn $ PGTypeScalar PGJSONB jsonbTypeAnn = mkTypeAnn $ PGTypeScalar PGJSONB
boolTypeAnn :: TypeAnn
boolTypeAnn = mkTypeAnn $ PGTypeScalar PGBoolean
data CountType data CountType
= CTStar = CTStar
| CTSimple ![PGCol] | CTSimple ![PGCol]
@ -267,6 +276,7 @@ data CountType
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData CountType instance NFData CountType
instance Cacheable CountType instance Cacheable CountType
instance Hashable CountType
instance ToSQL CountType where instance ToSQL CountType where
toSQL CTStar = "*" toSQL CTStar = "*"
@ -277,7 +287,7 @@ instance ToSQL CountType where
newtype TupleExp newtype TupleExp
= TupleExp [SQLExp] = TupleExp [SQLExp]
deriving (Show, Eq, NFData, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance ToSQL TupleExp where instance ToSQL TupleExp where
toSQL (TupleExp exps) = toSQL (TupleExp exps) =
@ -302,6 +312,7 @@ data SQLExp
| SEBool !BoolExp | SEBool !BoolExp
| SEExcluded !Iden | SEExcluded !Iden
| SEArray ![SQLExp] | SEArray ![SQLExp]
| SEArrayIndex !SQLExp !SQLExp
| SETuple !TupleExp | SETuple !TupleExp
| SECount !CountType | SECount !CountType
| SENamedArg !Iden !SQLExp | SENamedArg !Iden !SQLExp
@ -309,6 +320,7 @@ data SQLExp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData SQLExp instance NFData SQLExp
instance Cacheable SQLExp instance Cacheable SQLExp
instance Hashable SQLExp
withTyAnn :: PGScalarType -> SQLExp -> SQLExp withTyAnn :: PGScalarType -> SQLExp -> SQLExp
withTyAnn colTy v = SETyAnn v . mkTypeAnn $ PGTypeScalar colTy withTyAnn colTy v = SETyAnn v . mkTypeAnn $ PGTypeScalar colTy
@ -318,7 +330,7 @@ instance J.ToJSON SQLExp where
newtype Alias newtype Alias
= Alias { getAlias :: Iden } = Alias { getAlias :: Iden }
deriving (Show, Eq, NFData, Hashable, Data, Cacheable) deriving (Show, Eq, NFData, Data, Cacheable, Hashable)
instance IsIden Alias where instance IsIden Alias where
toIden (Alias iden) = iden toIden (Alias iden) = iden
@ -370,6 +382,9 @@ instance ToSQL SQLExp where
<> toSQL i <> toSQL i
toSQL (SEArray exps) = "ARRAY" <> TB.char '[' toSQL (SEArray exps) = "ARRAY" <> TB.char '['
<> (", " <+> exps) <> TB.char ']' <> (", " <+> exps) <> TB.char ']'
toSQL (SEArrayIndex arrayExp indexExp) =
paren (toSQL arrayExp)
<> TB.char '[' <> toSQL indexExp <> TB.char ']'
toSQL (SETuple tup) = toSQL tup toSQL (SETuple tup) = toSQL tup
toSQL (SECount ty) = "COUNT" <> paren (toSQL ty) toSQL (SECount ty) = "COUNT" <> paren (toSQL ty)
-- https://www.postgresql.org/docs/current/sql-syntax-calling-funcs.html -- https://www.postgresql.org/docs/current/sql-syntax-calling-funcs.html
@ -384,6 +399,7 @@ data Extractor = Extractor !SQLExp !(Maybe Alias)
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData Extractor instance NFData Extractor
instance Cacheable Extractor instance Cacheable Extractor
instance Hashable Extractor
mkSQLOpExp mkSQLOpExp
:: SQLOp :: SQLOp
@ -431,6 +447,7 @@ data DistinctExpr
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData DistinctExpr instance NFData DistinctExpr
instance Cacheable DistinctExpr instance Cacheable DistinctExpr
instance Hashable DistinctExpr
instance ToSQL DistinctExpr where instance ToSQL DistinctExpr where
toSQL DistinctSimple = "DISTINCT" toSQL DistinctSimple = "DISTINCT"
@ -444,6 +461,7 @@ data FunctionArgs
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData FunctionArgs instance NFData FunctionArgs
instance Cacheable FunctionArgs instance Cacheable FunctionArgs
instance Hashable FunctionArgs
instance ToSQL FunctionArgs where instance ToSQL FunctionArgs where
toSQL (FunctionArgs positionalArgs namedArgsMap) = toSQL (FunctionArgs positionalArgs namedArgsMap) =
@ -458,6 +476,7 @@ data DefinitionListItem
} deriving (Show, Eq, Data, Generic) } deriving (Show, Eq, Data, Generic)
instance NFData DefinitionListItem instance NFData DefinitionListItem
instance Cacheable DefinitionListItem instance Cacheable DefinitionListItem
instance Hashable DefinitionListItem
instance ToSQL DefinitionListItem where instance ToSQL DefinitionListItem where
toSQL (DefinitionListItem column columnType) = toSQL (DefinitionListItem column columnType) =
@ -470,6 +489,7 @@ data FunctionAlias
} deriving (Show, Eq, Data, Generic) } deriving (Show, Eq, Data, Generic)
instance NFData FunctionAlias instance NFData FunctionAlias
instance Cacheable FunctionAlias instance Cacheable FunctionAlias
instance Hashable FunctionAlias
mkSimpleFunctionAlias :: Iden -> FunctionAlias mkSimpleFunctionAlias :: Iden -> FunctionAlias
mkSimpleFunctionAlias identifier = mkSimpleFunctionAlias identifier =
@ -494,6 +514,7 @@ data FunctionExp
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData FunctionExp instance NFData FunctionExp
instance Cacheable FunctionExp instance Cacheable FunctionExp
instance Hashable FunctionExp
instance ToSQL FunctionExp where instance ToSQL FunctionExp where
toSQL (FunctionExp qf args alsM) = toSQL (FunctionExp qf args alsM) =
@ -505,11 +526,13 @@ data FromItem
| FIFunc !FunctionExp | FIFunc !FunctionExp
| FIUnnest ![SQLExp] !Alias ![SQLExp] | FIUnnest ![SQLExp] !Alias ![SQLExp]
| FISelect !Lateral !Select !Alias | FISelect !Lateral !Select !Alias
| FISelectWith !Lateral !(SelectWithG Select) !Alias
| FIValues !ValuesExp !Alias !(Maybe [PGCol]) | FIValues !ValuesExp !Alias !(Maybe [PGCol])
| FIJoin !JoinExpr | FIJoin !JoinExpr
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData FromItem instance NFData FromItem
instance Cacheable FromItem instance Cacheable FromItem
instance Hashable FromItem
mkSelFromItem :: Select -> Alias -> FromItem mkSelFromItem :: Select -> Alias -> FromItem
mkSelFromItem = FISelect (Lateral False) mkSelFromItem = FISelect (Lateral False)
@ -532,6 +555,8 @@ instance ToSQL FromItem where
"UNNEST" <> paren (", " <+> args) <-> toSQL als <> paren (", " <+> cols) "UNNEST" <> paren (", " <+> args) <-> toSQL als <> paren (", " <+> cols)
toSQL (FISelect mla sel al) = toSQL (FISelect mla sel al) =
toSQL mla <-> paren (toSQL sel) <-> toSQL al toSQL mla <-> paren (toSQL sel) <-> toSQL al
toSQL (FISelectWith mla selWith al) =
toSQL mla <-> paren (toSQL selWith) <-> toSQL al
toSQL (FIValues valsExp al mCols) = toSQL (FIValues valsExp al mCols) =
paren (toSQL valsExp) <-> toSQL al paren (toSQL valsExp) <-> toSQL al
<-> toSQL (toColTupExp <$> mCols) <-> toSQL (toColTupExp <$> mCols)
@ -539,7 +564,7 @@ instance ToSQL FromItem where
toSQL je toSQL je
newtype Lateral = Lateral Bool newtype Lateral = Lateral Bool
deriving (Show, Eq, Data, NFData, Cacheable) deriving (Show, Eq, Data, NFData, Cacheable, Hashable)
instance ToSQL Lateral where instance ToSQL Lateral where
toSQL (Lateral True) = "LATERAL" toSQL (Lateral True) = "LATERAL"
@ -554,6 +579,7 @@ data JoinExpr
} deriving (Show, Eq, Generic, Data) } deriving (Show, Eq, Generic, Data)
instance NFData JoinExpr instance NFData JoinExpr
instance Cacheable JoinExpr instance Cacheable JoinExpr
instance Hashable JoinExpr
instance ToSQL JoinExpr where instance ToSQL JoinExpr where
toSQL je = toSQL je =
@ -570,6 +596,7 @@ data JoinType
deriving (Eq, Show, Generic, Data) deriving (Eq, Show, Generic, Data)
instance NFData JoinType instance NFData JoinType
instance Cacheable JoinType instance Cacheable JoinType
instance Hashable JoinType
instance ToSQL JoinType where instance ToSQL JoinType where
toSQL Inner = "INNER JOIN" toSQL Inner = "INNER JOIN"
@ -583,6 +610,7 @@ data JoinCond
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData JoinCond instance NFData JoinCond
instance Cacheable JoinCond instance Cacheable JoinCond
instance Hashable JoinCond
instance ToSQL JoinCond where instance ToSQL JoinCond where
toSQL (JoinOn be) = toSQL (JoinOn be) =
@ -606,6 +634,7 @@ data BoolExp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData BoolExp instance NFData BoolExp
instance Cacheable BoolExp instance Cacheable BoolExp
instance Hashable BoolExp
-- removes extraneous 'AND true's -- removes extraneous 'AND true's
simplifyBoolExp :: BoolExp -> BoolExp simplifyBoolExp :: BoolExp -> BoolExp
@ -661,6 +690,7 @@ data BinOp = AndOp | OrOp
deriving (Show, Eq, Generic, Data) deriving (Show, Eq, Generic, Data)
instance NFData BinOp instance NFData BinOp
instance Cacheable BinOp instance Cacheable BinOp
instance Hashable BinOp
instance ToSQL BinOp where instance ToSQL BinOp where
toSQL AndOp = "AND" toSQL AndOp = "AND"
@ -689,6 +719,7 @@ data CompareOp
deriving (Eq, Generic, Data) deriving (Eq, Generic, Data)
instance NFData CompareOp instance NFData CompareOp
instance Cacheable CompareOp instance Cacheable CompareOp
instance Hashable CompareOp
instance Show CompareOp where instance Show CompareOp where
show = \case show = \case
@ -835,7 +866,7 @@ instance ToSQL SQLConflict where
newtype ValuesExp newtype ValuesExp
= ValuesExp [TupleExp] = ValuesExp [TupleExp]
deriving (Show, Eq, Data, NFData, Cacheable) deriving (Show, Eq, Data, NFData, Cacheable, Hashable)
instance ToSQL ValuesExp where instance ToSQL ValuesExp where
toSQL (ValuesExp tuples) = toSQL (ValuesExp tuples) =
@ -874,14 +905,20 @@ instance ToSQL CTE where
CTEUpdate q -> toSQL q CTEUpdate q -> toSQL q
CTEDelete q -> toSQL q CTEDelete q -> toSQL q
data SelectWith data SelectWithG v
= SelectWith = SelectWith
{ swCTEs :: [(Alias, CTE)] { swCTEs :: ![(Alias, v)]
, swSelect :: !Select , swSelect :: !Select
} deriving (Show, Eq) } deriving (Show, Eq, Generic, Data)
instance ToSQL SelectWith where instance (NFData v) => NFData (SelectWithG v)
instance (Cacheable v) => Cacheable (SelectWithG v)
instance (Hashable v) => Hashable (SelectWithG v)
instance (ToSQL v) => ToSQL (SelectWithG v) where
toSQL (SelectWith ctes sel) = toSQL (SelectWith ctes sel) =
"WITH " <> (", " <+> map f ctes) <-> toSQL sel "WITH " <> (", " <+> map f ctes) <-> toSQL sel
where where
f (Alias al, q) = toSQL al <-> "AS" <-> paren (toSQL q) f (Alias al, q) = toSQL al <-> "AS" <-> paren (toSQL q)
type SelectWith = SelectWithG CTE

View File

@ -1,5 +1,6 @@
module Hasura.SQL.Rewrite module Hasura.SQL.Rewrite
( prefixNumToAliases ( prefixNumToAliases
, prefixNumToAliasesSelectWith
) where ) where
import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict as Map
@ -20,6 +21,11 @@ prefixNumToAliases :: S.Select -> S.Select
prefixNumToAliases s = prefixNumToAliases s =
uSelect s `evalState` UniqSt 0 Map.empty uSelect s `evalState` UniqSt 0 Map.empty
prefixNumToAliasesSelectWith
:: S.SelectWithG S.Select -> S.SelectWithG S.Select
prefixNumToAliasesSelectWith s =
uSelectWith s `evalState` UniqSt 0 Map.empty
type Rewrite a = State a type Rewrite a = State a
data UniqSt data UniqSt
@ -56,6 +62,12 @@ restoringIdens action = do
modify' $ \s -> s { _uqIdens = idens } modify' $ \s -> s { _uqIdens = idens }
return res return res
uSelectWith :: S.SelectWithG S.Select -> Uniq (S.SelectWithG S.Select)
uSelectWith (S.SelectWith ctes baseSelect) =
S.SelectWith
<$> forM ctes (\(als, sel) -> (als,) <$> restoringIdens (uSelect sel))
<*> uSelect baseSelect
uSelect :: S.Select -> Uniq S.Select uSelect :: S.Select -> Uniq S.Select
uSelect sel = do uSelect sel = do
-- this has to be the first thing to process -- this has to be the first thing to process
@ -113,6 +125,10 @@ uFromItem fromItem = case fromItem of
newSel <- restoringIdens $ uSelect sel newSel <- restoringIdens $ uSelect sel
newAls <- addAlias al newAls <- addAlias al
return $ S.FISelect isLateral newSel newAls return $ S.FISelect isLateral newSel newAls
S.FISelectWith isLateral selectWith al -> do
newSelectWith <- uSelectWith selectWith
newAls <- addAlias al
return $ S.FISelectWith isLateral newSelectWith newAls
S.FIValues (S.ValuesExp tups) als mCols -> do S.FIValues (S.ValuesExp tups) als mCols -> do
newValExp <- fmap S.ValuesExp $ newValExp <- fmap S.ValuesExp $
forM tups $ \(S.TupleExp ts) -> forM tups $ \(S.TupleExp ts) ->
@ -196,8 +212,10 @@ uSqlExp = restoringIdens . \case
S.SEExcluded <$> return t S.SEExcluded <$> return t
S.SEArray l -> S.SEArray l ->
S.SEArray <$> mapM uSqlExp l S.SEArray <$> mapM uSqlExp l
S.SEArrayIndex arrayExp indexExp ->
S.SEArrayIndex <$> uSqlExp arrayExp <*> uSqlExp indexExp
S.SETuple (S.TupleExp l) -> S.SETuple (S.TupleExp l) ->
S.SEArray <$> mapM uSqlExp l S.SETuple . S.TupleExp <$> mapM uSqlExp l
S.SECount cty -> return $ S.SECount cty S.SECount cty -> return $ S.SECount cty
S.SENamedArg arg val -> S.SENamedArg arg <$> uSqlExp val S.SENamedArg arg val -> S.SENamedArg arg <$> uSqlExp val
S.SEFunction funcExp -> S.SEFunction <$> uFunctionExp funcExp S.SEFunction funcExp -> S.SEFunction <$> uFunctionExp funcExp

View File

@ -3,68 +3,68 @@
module Hasura.Server.App where module Hasura.Server.App where
import Control.Concurrent.MVar.Lifted import Control.Concurrent.MVar.Lifted
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import Control.Lens (view, _2) import Control.Lens (view, _2)
import Control.Monad.Stateless import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson hiding (json) import Data.Aeson hiding (json)
import Data.Either (isRight) import Data.Either (isRight)
import Data.Int (Int64) import Data.Int (Int64)
import Data.IORef import Data.IORef
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.Mime (defaultMimeLookup) import Network.Mime (defaultMimeLookup)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.FilePath (joinPath, takeFileName) import System.FilePath (joinPath, takeFileName)
import Web.Spock.Core ((<//>)) import Web.Spock.Core ((<//>))
import qualified Control.Concurrent.Async.Lifted.Safe as LA import qualified Control.Concurrent.Async.Lifted.Safe as LA
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S import qualified Data.HashSet as S
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.WebSockets as WS import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified System.Metrics as EKG import qualified System.Metrics as EKG
import qualified System.Metrics.Json as EKG import qualified System.Metrics.Json as EKG
import qualified Text.Mustache as M import qualified Text.Mustache as M
import qualified Web.Spock.Core as Spock import qualified Web.Spock.Core as Spock
import Hasura.EncJSON import Hasura.EncJSON
-- import Hasura.GraphQL.Resolve.Action -- import Hasura.GraphQL.Resolve.Action
import Hasura.GraphQL.Logging (MonadQueryLog (..)) import Hasura.GraphQL.Logging (MonadQueryLog (..))
import Hasura.HTTP import Hasura.HTTP
import Hasura.Prelude hiding (get, put) import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.RQL.Types.Run import Hasura.RQL.Types.Run
import Hasura.Server.API.Config (runGetConfig) import Hasura.Server.API.Config (runGetConfig)
import Hasura.Server.API.Query import Hasura.Server.API.Query
import Hasura.Server.Auth (AuthMode (..), UserAuthentication (..)) import Hasura.Server.Auth (AuthMode (..), UserAuthentication (..))
import Hasura.Server.Compression import Hasura.Server.Compression
import Hasura.Server.Cors import Hasura.Server.Cors
import Hasura.Server.Init import Hasura.Server.Init
import Hasura.Server.Logging import Hasura.Server.Logging
import Hasura.Server.Middleware (corsMiddleware) import Hasura.Server.Middleware (corsMiddleware)
import Hasura.Server.Utils import Hasura.Server.Utils
import Hasura.Server.Version import Hasura.Server.Version
import Hasura.SQL.Types
import Hasura.Session import Hasura.Session
import Hasura.SQL.Types
import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Execute.LiveQuery as EL import qualified Hasura.GraphQL.Execute.LiveQuery as EL
-- import qualified Hasura.GraphQL.Explain as GE -- import qualified Hasura.GraphQL.Explain as GE
import qualified Hasura.GraphQL.Transport.HTTP as GH import qualified Hasura.GraphQL.Transport.HTTP as GH
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Transport.WebSocket as WS import qualified Hasura.GraphQL.Transport.WebSocket as WS
import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
import qualified Hasura.Logging as L import qualified Hasura.Logging as L
import qualified Hasura.Server.API.PGDump as PGD import qualified Hasura.Server.API.PGDump as PGD
import qualified Network.Wai.Handler.WebSockets.Custom as WSC import qualified Network.Wai.Handler.WebSockets.Custom as WSC
@ -350,7 +350,8 @@ v1Alpha1GQHandler queryType query = do
v1GQHandler v1GQHandler
:: (HasVersion, MonadIO m) :: (HasVersion, MonadIO m)
=> GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON) => GH.GQLBatchedReqs GH.GQLQueryText
-> Handler m (HttpResponse EncJSON)
v1GQHandler = v1Alpha1GQHandler E.QueryHasura v1GQHandler = v1Alpha1GQHandler E.QueryHasura
v1GQRelayHandler v1GQRelayHandler

View File

@ -0,0 +1,49 @@
description: Get last page of articles with 3 items
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
last: 3
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiA0fQ==
endCursor: eyJpZCIgOiA2fQ==
hasPreviousPage: true
hasNextPage: false
edges:
- cursor: eyJpZCIgOiA0fQ==
node:
title: Article 4
content: Sample article content 4
author_id: 2
- cursor: eyJpZCIgOiA1fQ==
node:
title: Article 5
content: Sample article content 5
author_id: 2
- cursor: eyJpZCIgOiA2fQ==
node:
title: Article 6
content: Sample article content 6
author_id: 3

View File

@ -0,0 +1,45 @@
description: Get last page of articles with 2 items before 'Article 4'
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
last: 2
before: "eyJpZCIgOiA0fQ=="
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiAyfQ==
endCursor: eyJpZCIgOiAzfQ==
hasPreviousPage: true
hasNextPage: true
edges:
- cursor: eyJpZCIgOiAyfQ==
node:
title: Article 2
content: Sample article content 2
author_id: 1
- cursor: eyJpZCIgOiAzfQ==
node:
title: Article 3
content: Sample article content 3
author_id: 1

View File

@ -0,0 +1,40 @@
description: Get last page of articles before 'Article 2'
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
last: 2
before: "eyJpZCIgOiAyfQ=="
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiAxfQ==
endCursor: eyJpZCIgOiAxfQ==
hasPreviousPage: false
hasNextPage: true
edges:
- cursor: eyJpZCIgOiAxfQ==
node:
title: Article 1
content: Sample article content 1
author_id: 1

View File

@ -0,0 +1,49 @@
description: Get 1st page of articles with 3 items
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
first: 3
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiAxfQ==
endCursor: eyJpZCIgOiAzfQ==
hasPreviousPage: false
hasNextPage: true
edges:
- cursor: eyJpZCIgOiAxfQ==
node:
title: Article 1
content: Sample article content 1
author_id: 1
- cursor: eyJpZCIgOiAyfQ==
node:
title: Article 2
content: Sample article content 2
author_id: 1
- cursor: eyJpZCIgOiAzfQ==
node:
title: Article 3
content: Sample article content 3
author_id: 1

View File

@ -0,0 +1,45 @@
description: Get 2nd page of articles with 2 items
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
first: 2
after: "eyJpZCIgOiAzfQ=="
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiA0fQ==
endCursor: eyJpZCIgOiA1fQ==
hasPreviousPage: true
hasNextPage: true
edges:
- cursor: eyJpZCIgOiA0fQ==
node:
title: Article 4
content: Sample article content 4
author_id: 2
- cursor: eyJpZCIgOiA1fQ==
node:
title: Article 5
content: Sample article content 5
author_id: 2

View File

@ -0,0 +1,40 @@
description: Get 3rd page of articles
url: /v1/relay
status: 200
query:
query: |
query {
article_connection(
first: 3
after: "eyJpZCIgOiA1fQ=="
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
title
content
author_id
}
}
}
}
response:
data:
article_connection:
pageInfo:
startCursor: eyJpZCIgOiA2fQ==
endCursor: eyJpZCIgOiA2fQ==
hasPreviousPage: true
hasNextPage: false
edges:
- cursor: eyJpZCIgOiA2fQ==
node:
title: Article 6
content: Sample article content 6
author_id: 3

View File

@ -0,0 +1,44 @@
description: Fetch 1st page from last of articles ordered by their article count
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
last: 1
order_by: {articles_aggregate: {count: asc}}
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
name
articles_aggregate{
aggregate{
count
}
}
}
}
}
}
response:
data:
author_connection:
pageInfo:
startCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9
endCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9
hasPreviousPage: true
hasNextPage: false
edges:
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9
node:
name: Author 1
articles_aggregate:
aggregate:
count: 3

View File

@ -0,0 +1,51 @@
description: Fetch 2nd page from last of articles ordered by their article count
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
last: 2
order_by: {articles_aggregate: {count: asc}}
before: "eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9"
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
name
articles_aggregate{
aggregate{
count
}
}
}
}
}
}
response:
data:
author_connection:
pageInfo:
startCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9
endCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAyfSwgImlkIiA6IDJ9
hasPreviousPage: true
hasNextPage: true
edges:
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9
node:
name: Author 3
articles_aggregate:
aggregate:
count: 1
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAyfSwgImlkIiA6IDJ9
node:
name: Author 2
articles_aggregate:
aggregate:
count: 2

View File

@ -0,0 +1,45 @@
description: Fetch 3rd page from last of articles ordered by their article count
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
last: 1
order_by: {articles_aggregate: {count: asc}}
before: "eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9"
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
name
articles_aggregate{
aggregate{
count
}
}
}
}
}
}
response:
data:
author_connection:
pageInfo:
startCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAwfSwgImlkIiA6IDR9
endCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAwfSwgImlkIiA6IDR9
hasPreviousPage: false
hasNextPage: true
edges:
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAwfSwgImlkIiA6IDR9
node:
name: Author 4
articles_aggregate:
aggregate:
count: 0

View File

@ -0,0 +1,50 @@
description: Fetch 1st page of articles ordered by their article count
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
first: 2
order_by: {articles_aggregate: {count: asc}}
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
name
articles_aggregate{
aggregate{
count
}
}
}
}
}
}
response:
data:
author_connection:
pageInfo:
startCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAwfSwgImlkIiA6IDR9
endCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9
hasPreviousPage: false
hasNextPage: true
edges:
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAwfSwgImlkIiA6IDR9
node:
name: Author 4
articles_aggregate:
aggregate:
count: 0
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9
node:
name: Author 3
articles_aggregate:
aggregate:
count: 1

View File

@ -0,0 +1,51 @@
description: Fetch 2nd page of articles ordered by their article count
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
first: 2
order_by: {articles_aggregate: {count: asc}}
after: "eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAxfSwgImlkIiA6IDN9"
){
pageInfo{
startCursor
endCursor
hasPreviousPage
hasNextPage
}
edges{
cursor
node{
name
articles_aggregate{
aggregate{
count
}
}
}
}
}
}
response:
data:
author_connection:
pageInfo:
startCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAyfSwgImlkIiA6IDJ9
endCursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9
hasPreviousPage: true
hasNextPage: false
edges:
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAyfSwgImlkIiA6IDJ9
node:
name: Author 2
articles_aggregate:
aggregate:
count: 2
- cursor: eyJhcnRpY2xlc19hZ2dyZWdhdGUiIDogeyJjb3VudCIgOiAzfSwgImlkIiA6IDF9
node:
name: Author 1
articles_aggregate:
aggregate:
count: 3

View File

@ -0,0 +1,19 @@
description: Query node interface with invalid node id
url: /v1/relay
status: 200
query:
query: |
query {
node(id: "eyJpZCIgOiA0fQ=="){
__typename
... on author{
name
}
}
}
response:
errors:
- extensions:
path: "$.selectionSet.node"
code: validation-failed
message: the node id is invalid

View File

@ -0,0 +1,21 @@
description: Use after and before arguments in the same query
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
after: "eyJpZCIgOiAyfQ=="
before: "eyJpZCIgOiA0fQ=="
){
edges{
cursor
}
}
}
response:
errors:
- extensions:
path: "$.selectionSet.author_connection"
code: validation-failed
message: '"after" and "before" are not allowed at once'

View File

@ -0,0 +1,21 @@
description: Use first and last arguments in the same query
url: /v1/relay
status: 200
query:
query: |
query {
author_connection(
first: 1
last: 2
){
edges{
cursor
}
}
}
response:
errors:
- extensions:
path: "$.selectionSet.author_connection"
code: validation-failed
message: '"first" and "last" are not allowed at once'

View File

@ -0,0 +1,79 @@
type: bulk
args:
- type: run_sql
args:
sql: |
CREATE TABLE author(
id SERIAL PRIMARY KEY,
name TEXT UNIQUE NOT NULL
);
INSERT INTO author (name)
VALUES ('Author 1'), ('Author 2'), ('Author 3'), ('Author 4');
CREATE TABLE article (
id SERIAL PRIMARY KEY,
title TEXT,
content TEXT,
author_id INTEGER REFERENCES author(id)
);
INSERT INTO article (title, content, author_id)
VALUES
(
'Article 1',
'Sample article content 1',
1
),
(
'Article 2',
'Sample article content 2',
1
),
(
'Article 3',
'Sample article content 3',
1
),
(
'Article 4',
'Sample article content 4',
2
),
(
'Article 5',
'Sample article content 5',
2
),
(
'Article 6',
'Sample article content 6',
3
);
# Track tables and define relationships
- type: track_table
args:
name: author
schema: public
- type: track_table
args:
name: article
schema: public
- type: create_object_relationship
args:
table: article
name: author
using:
foreign_key_constraint_on: author_id
- type: create_array_relationship
args:
table: author
name: articles
using:
foreign_key_constraint_on:
table: article
column: author_id

View File

@ -0,0 +1,8 @@
type: bulk
args:
- type: run_sql
args:
cascade: true
sql: |
DROP TABLE article;
DROP TABLE author;