mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 01:12:56 +03:00
server: metadata separation: cleanup schema generation (#6116)
https://github.com/hasura/graphql-engine/pull/6116
This commit is contained in:
Auke Booij
GitHub
parent
f7fcbd50fc
commit
fd8d51a37a
@ -64,59 +64,30 @@ buildGQLContext
|
||||
buildGQLContext =
|
||||
proc (queryType, allTables, allFunctions, allRemoteSchemas, allActions, nonObjectCustomTypes) -> do
|
||||
|
||||
-- Scroll down a few pages for the actual body...
|
||||
SQLGenCtx{ stringifyNum } <- bindA -< askSQLGenCtx
|
||||
|
||||
let allRoles = Set.insert adminRoleName $
|
||||
(allTables ^.. folded.tiRolePermInfoMap.to Map.keys.folded)
|
||||
<> (allActionInfos ^.. folded.aiPermissions.to Map.keys.folded)
|
||||
|
||||
tableFilter = not . isSystemDefined . _tciSystemDefined
|
||||
functionFilter = not . isSystemDefined . fiSystemDefined
|
||||
|
||||
graphQLTableFilter tableName tableInfo =
|
||||
-- either the table name should be GraphQL compliant
|
||||
-- or it should have a GraphQL custom name set with it
|
||||
isGraphQLCompliantTableName tableName
|
||||
|| (isJust . _tcCustomName . _tciCustomConfig . _tiCoreInfo $ tableInfo)
|
||||
|
||||
validTables = Map.filter (tableFilter . _tiCoreInfo) allTables
|
||||
-- Only tables that have GraphQL compliant names will be added to the schema.
|
||||
-- We allow tables which don't have GraphQL compliant names, so that RQL CRUD
|
||||
-- operations can be performed on them
|
||||
graphQLTables = Map.filterWithKey graphQLTableFilter validTables
|
||||
validFunctions = Map.elems $ Map.filter functionFilter allFunctions
|
||||
|
||||
allActionInfos = Map.elems allActions
|
||||
queryRemotesMap =
|
||||
fmap (map fDefinition . piQuery . rscParsed . fst) allRemoteSchemas
|
||||
buildFullestDBSchema
|
||||
:: m ( Parser 'Output (P.ParseT Identity) (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue))
|
||||
, Maybe (Parser 'Output (P.ParseT Identity) (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue)))
|
||||
)
|
||||
buildFullestDBSchema = do
|
||||
SQLGenCtx{ stringifyNum } <- askSQLGenCtx
|
||||
let gqlContext =
|
||||
(,)
|
||||
<$> queryWithIntrospection (Set.fromMap $ graphQLTables $> ())
|
||||
validFunctions mempty mempty
|
||||
allActionInfos nonObjectCustomTypes
|
||||
<*> mutation (Set.fromMap $ graphQLTables $> ()) mempty
|
||||
allActionInfos nonObjectCustomTypes
|
||||
flip runReaderT (adminRoleName, graphQLTables, Frontend, QueryContext stringifyNum queryType queryRemotesMap) $
|
||||
P.runSchemaT gqlContext
|
||||
queryContext = QueryContext stringifyNum queryType queryRemotesMap
|
||||
|
||||
-- build the admin context so that we can check against name clashes with remotes
|
||||
adminHasuraContext <- bindA -< buildFullestDBSchema
|
||||
-- build the admin DB-only context so that we can check against name clashes with remotes
|
||||
-- TODO: Is there a better way to check for conflicts without actually building the admin schema?
|
||||
adminHasuraDBContext <- bindA -<
|
||||
buildFullestDBSchema queryContext allTables allFunctions allActionInfos nonObjectCustomTypes
|
||||
|
||||
queryFieldNames :: [G.Name] <- bindA -<
|
||||
case P.discardNullability $ P.parserType $ fst adminHasuraContext of
|
||||
case P.discardNullability $ P.parserType $ fst adminHasuraDBContext of
|
||||
-- It really ought to be this case; anything else is a programming error.
|
||||
P.TNamed (P.Definition _ _ _ (P.TIObject (P.ObjectInfo rootFields _interfaces))) ->
|
||||
pure $ fmap P.dName rootFields
|
||||
_ -> throw500 "We encountered an root query of unexpected GraphQL type. It should be an object type."
|
||||
let mutationFieldNames :: [G.Name]
|
||||
mutationFieldNames =
|
||||
case P.discardNullability . P.parserType <$> snd adminHasuraContext of
|
||||
case P.discardNullability . P.parserType <$> snd adminHasuraDBContext of
|
||||
Just (P.TNamed def) ->
|
||||
case P.dInfo def of
|
||||
-- It really ought to be this case; anything else is a programming error.
|
||||
@ -125,90 +96,219 @@ buildGQLContext =
|
||||
_ -> []
|
||||
|
||||
-- This block of code checks that there are no conflicting root field names between remotes.
|
||||
remotes ::
|
||||
[ ( RemoteSchemaName
|
||||
, ParsedIntrospection
|
||||
)
|
||||
] <- (| foldlA' (\okSchemas (newSchemaName, (newSchemaContext, newMetadataObject)) -> do
|
||||
checkedDuplicates <- (| withRecordInconsistency (do
|
||||
let (queryOld, mutationOld) =
|
||||
unzip $ fmap ((\case ParsedIntrospection q m _ -> (q,m)) . snd) okSchemas
|
||||
let ParsedIntrospection queryNew mutationNew _subscriptionNew
|
||||
= rscParsed newSchemaContext
|
||||
-- Check for conflicts between remotes
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) (queryNew ++ concat queryOld))) $
|
||||
\name -> throw400 Unexpected $ "Duplicate remote field " <> squote name
|
||||
-- Check for conflicts between this remote and the tables
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) queryNew ++ queryFieldNames)) $
|
||||
\name -> throw400 RemoteSchemaConflicts $ "Field cannot be overwritten by remote field " <> squote name
|
||||
-- Ditto, but for mutations
|
||||
case mutationNew of
|
||||
Nothing -> returnA -< ()
|
||||
Just ms -> do
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) (ms ++ concat (catMaybes mutationOld)))) $
|
||||
\name -> throw400 Unexpected $ "Duplicate remote field " <> squote name
|
||||
-- Ditto, but for mutations
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) ms ++ mutationFieldNames)) $
|
||||
\name -> throw400 Unexpected $ "Field cannot be overwritten by remote field " <> squote name
|
||||
-- No need to check subscriptions as these are not supported
|
||||
returnA -< ())
|
||||
|) newMetadataObject
|
||||
case checkedDuplicates of
|
||||
Nothing -> returnA -< okSchemas
|
||||
Just _ -> returnA -< (newSchemaName, rscParsed newSchemaContext):okSchemas
|
||||
) |) [] (Map.toList allRemoteSchemas)
|
||||
remotes <- remoteSchemaFields -< (queryFieldNames, mutationFieldNames, allRemoteSchemas)
|
||||
|
||||
let unauthenticatedContext :: m GQLContext
|
||||
unauthenticatedContext = P.runSchemaT do
|
||||
ucQueries <- finalizeParser <$> unauthenticatedQueryWithIntrospection queryRemotes mutationRemotes
|
||||
ucMutations <- fmap finalizeParser <$> unauthenticatedMutation mutationRemotes
|
||||
pure $ GQLContext ucQueries ucMutations
|
||||
|
||||
-- | The 'query' type of the remotes. TODO: also expose mutation
|
||||
-- remotes. NOT TODO: subscriptions, as we do not yet aim to support
|
||||
-- these.
|
||||
queryRemotes = concatMap (piQuery . snd) remotes
|
||||
let queryRemotes = concatMap (piQuery . snd) remotes
|
||||
mutationRemotes = concatMap (concat . piMutation . snd) remotes
|
||||
queryHasuraOrRelay = case queryType of
|
||||
QueryHasura -> queryWithIntrospection (Set.fromMap $ graphQLTables $> ())
|
||||
validFunctions queryRemotes mutationRemotes
|
||||
allActionInfos nonObjectCustomTypes
|
||||
QueryRelay -> relayWithIntrospection (Set.fromMap $ graphQLTables $> ()) validFunctions
|
||||
|
||||
buildContextForRoleAndScenario :: RoleName -> Scenario -> m GQLContext
|
||||
buildContextForRoleAndScenario roleName scenario = do
|
||||
SQLGenCtx{ stringifyNum } <- askSQLGenCtx
|
||||
let gqlContext = GQLContext
|
||||
<$> (finalizeParser <$> queryHasuraOrRelay)
|
||||
<*> (fmap finalizeParser <$> mutation (Set.fromList $ Map.keys graphQLTables) mutationRemotes
|
||||
allActionInfos nonObjectCustomTypes)
|
||||
flip runReaderT (roleName, graphQLTables, scenario, QueryContext stringifyNum queryType queryRemotesMap) $
|
||||
P.runSchemaT gqlContext
|
||||
|
||||
buildContextForRole :: RoleName -> m (RoleContext GQLContext)
|
||||
buildContextForRole roleName = do
|
||||
frontend <- buildContextForRoleAndScenario roleName Frontend
|
||||
backend <- buildContextForRoleAndScenario roleName Backend
|
||||
return $ RoleContext frontend $ Just backend
|
||||
|
||||
finalizeParser :: Parser 'Output (P.ParseT Identity) a -> ParserFn a
|
||||
finalizeParser parser = runIdentity . P.runParseT . P.runParser parser
|
||||
|
||||
-- Here, finally the body starts.
|
||||
|
||||
roleContexts <- bindA -< (Set.toMap allRoles & Map.traverseWithKey \roleName () ->
|
||||
buildContextForRole roleName)
|
||||
unauthenticated <- bindA -< unauthenticatedContext
|
||||
roleContexts <- bindA -<
|
||||
( Set.toMap allRoles & Map.traverseWithKey \roleName () ->
|
||||
case queryType of
|
||||
QueryHasura ->
|
||||
buildRoleContext queryContext allTables allFunctions allActionInfos
|
||||
nonObjectCustomTypes queryRemotes mutationRemotes roleName
|
||||
QueryRelay ->
|
||||
buildRelayRoleContext queryContext allTables allFunctions allActionInfos
|
||||
nonObjectCustomTypes mutationRemotes roleName
|
||||
)
|
||||
unauthenticated <- bindA -< unauthenticatedContext queryRemotes mutationRemotes
|
||||
returnA -< (roleContexts, unauthenticated)
|
||||
|
||||
-- | Generate all the field parsers for query-type GraphQL requests. We don't
|
||||
-- actually collect these into a @Parser@ using @selectionSet@ so that we can
|
||||
-- insert the introspection before doing so.
|
||||
query'
|
||||
runMonadSchema
|
||||
:: (Monad m)
|
||||
=> RoleName
|
||||
-> QueryContext
|
||||
-> Map.HashMap QualifiedTable (TableInfo 'Postgres)
|
||||
-> P.SchemaT (P.ParseT Identity) (ReaderT (RoleName, Map.HashMap QualifiedTable (TableInfo 'Postgres), QueryContext) m) a -> m a
|
||||
runMonadSchema roleName queryContext tableCache m =
|
||||
flip runReaderT (roleName, tableCache, queryContext) $ P.runSchemaT m
|
||||
|
||||
-- TODO: Integrate relay schema
|
||||
buildRoleContext
|
||||
:: (MonadError QErr m, MonadIO m, MonadUnique m)
|
||||
=> QueryContext -> TableCache -> FunctionCache -> [ActionInfo 'Postgres] -> NonObjectTypeMap
|
||||
-> [P.FieldParser (P.ParseT Identity) RemoteField]
|
||||
-> [P.FieldParser (P.ParseT Identity) RemoteField]
|
||||
-> RoleName
|
||||
-> m (RoleContext GQLContext)
|
||||
buildRoleContext queryContext allTables allFunctions allActionInfos
|
||||
nonObjectCustomTypes queryRemotes mutationRemotes roleName =
|
||||
|
||||
runMonadSchema roleName queryContext validTables $ do
|
||||
mutationParserFrontend <-
|
||||
buildPGMutationFields Frontend validTableNames >>=
|
||||
buildMutationParser mutationRemotes allActionInfos nonObjectCustomTypes
|
||||
|
||||
mutationParserBackend <-
|
||||
buildPGMutationFields Backend validTableNames >>=
|
||||
buildMutationParser mutationRemotes allActionInfos nonObjectCustomTypes
|
||||
|
||||
queryPGFields <- buildPostgresQueryFields validTableNames validFunctions
|
||||
subscriptionParser <- buildSubscriptionParser queryPGFields allActionInfos
|
||||
|
||||
queryParserFrontend <- buildQueryParser queryPGFields queryRemotes
|
||||
allActionInfos nonObjectCustomTypes mutationParserFrontend subscriptionParser
|
||||
queryParserBackend <- buildQueryParser queryPGFields queryRemotes
|
||||
allActionInfos nonObjectCustomTypes mutationParserBackend subscriptionParser
|
||||
|
||||
let frontendContext = GQLContext (finalizeParser queryParserFrontend)
|
||||
(finalizeParser <$> mutationParserFrontend)
|
||||
let backendContext = GQLContext (finalizeParser queryParserBackend)
|
||||
(finalizeParser <$> mutationParserBackend)
|
||||
pure $ RoleContext frontendContext $ Just backendContext
|
||||
|
||||
where
|
||||
|
||||
tableFilter = not . isSystemDefined . _tciSystemDefined
|
||||
functionFilter = not . isSystemDefined . fiSystemDefined
|
||||
|
||||
validTables = Map.filter (tableFilter . _tiCoreInfo) allTables
|
||||
validTableNames = Map.keysSet validTables
|
||||
validFunctions = Map.elems $ Map.filter functionFilter allFunctions
|
||||
|
||||
buildFullestDBSchema
|
||||
:: (MonadError QErr m, MonadIO m, MonadUnique m)
|
||||
=> QueryContext -> TableCache -> FunctionCache -> [ActionInfo 'Postgres] -> NonObjectTypeMap
|
||||
-> m ( Parser 'Output (P.ParseT Identity) (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue))
|
||||
, Maybe (Parser 'Output (P.ParseT Identity) (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue)))
|
||||
)
|
||||
buildFullestDBSchema queryContext allTables allFunctions allActionInfos
|
||||
nonObjectCustomTypes = do
|
||||
runMonadSchema adminRoleName queryContext validTables $ do
|
||||
mutationParserFrontend <-
|
||||
buildPGMutationFields Frontend validTableNames >>=
|
||||
buildMutationParser mempty allActionInfos nonObjectCustomTypes
|
||||
|
||||
queryPGFields <- buildPostgresQueryFields validTableNames validFunctions
|
||||
subscriptionParser <- buildSubscriptionParser queryPGFields allActionInfos
|
||||
|
||||
queryParserFrontend <- buildQueryParser queryPGFields mempty
|
||||
allActionInfos nonObjectCustomTypes mutationParserFrontend subscriptionParser
|
||||
|
||||
pure (queryParserFrontend, mutationParserFrontend)
|
||||
|
||||
where
|
||||
|
||||
tableFilter = not . isSystemDefined . _tciSystemDefined
|
||||
functionFilter = not . isSystemDefined . fiSystemDefined
|
||||
|
||||
validTables = Map.filter (tableFilter . _tiCoreInfo) allTables
|
||||
validTableNames = Map.keysSet validTables
|
||||
validFunctions = Map.elems $ Map.filter functionFilter allFunctions
|
||||
|
||||
buildRelayRoleContext
|
||||
:: (MonadError QErr m, MonadIO m, MonadUnique m)
|
||||
=> QueryContext -> TableCache -> FunctionCache -> [ActionInfo 'Postgres] -> NonObjectTypeMap
|
||||
-> [P.FieldParser (P.ParseT Identity) RemoteField]
|
||||
-> RoleName
|
||||
-> m (RoleContext GQLContext)
|
||||
buildRelayRoleContext queryContext allTables allFunctions allActionInfos
|
||||
nonObjectCustomTypes mutationRemotes roleName =
|
||||
|
||||
runMonadSchema roleName queryContext validTables $ do
|
||||
mutationParserFrontend <-
|
||||
buildPGMutationFields Frontend validTableNames >>=
|
||||
buildMutationParser mutationRemotes allActionInfos nonObjectCustomTypes
|
||||
|
||||
mutationParserBackend <-
|
||||
buildPGMutationFields Backend validTableNames >>=
|
||||
buildMutationParser mutationRemotes allActionInfos nonObjectCustomTypes
|
||||
|
||||
queryPGFields <- buildRelayPostgresQueryFields validTableNames validFunctions
|
||||
subscriptionParser <- P.safeSelectionSet subscriptionRoot Nothing queryPGFields
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String. G.unName)))
|
||||
queryParserFrontend <- queryWithIntrospectionHelper queryPGFields
|
||||
mutationParserFrontend subscriptionParser
|
||||
queryParserBackend <- queryWithIntrospectionHelper queryPGFields
|
||||
mutationParserBackend subscriptionParser
|
||||
|
||||
let frontendContext = GQLContext (finalizeParser queryParserFrontend)
|
||||
(finalizeParser <$> mutationParserFrontend)
|
||||
let backendContext = GQLContext (finalizeParser queryParserBackend)
|
||||
(finalizeParser <$> mutationParserBackend)
|
||||
pure $ RoleContext frontendContext $ Just backendContext
|
||||
|
||||
where
|
||||
|
||||
tableFilter = not . isSystemDefined . _tciSystemDefined
|
||||
functionFilter = not . isSystemDefined . fiSystemDefined
|
||||
|
||||
validTables = Map.filter (tableFilter . _tiCoreInfo) allTables
|
||||
validTableNames = Map.keysSet validTables
|
||||
validFunctions = Map.elems $ Map.filter functionFilter allFunctions
|
||||
|
||||
unauthenticatedContext
|
||||
:: forall m
|
||||
. ( MonadError QErr m
|
||||
, MonadIO m
|
||||
, MonadUnique m
|
||||
)
|
||||
=> [P.FieldParser (P.ParseT Identity) RemoteField]
|
||||
-> [P.FieldParser (P.ParseT Identity) RemoteField]
|
||||
-> m GQLContext
|
||||
unauthenticatedContext queryRemotes mutationRemotes = P.runSchemaT $ do
|
||||
let queryFields = fmap (fmap RFRemote) queryRemotes
|
||||
mutationParser <-
|
||||
if null mutationRemotes
|
||||
then pure Nothing
|
||||
else P.safeSelectionSet mutationRoot Nothing (fmap (fmap RFRemote) mutationRemotes)
|
||||
<&> Just . fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
subscriptionParser <-
|
||||
P.safeSelectionSet subscriptionRoot Nothing []
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
queryParser <- queryWithIntrospectionHelper queryFields mutationParser subscriptionParser
|
||||
pure $ GQLContext (finalizeParser queryParser) (finalizeParser <$> mutationParser)
|
||||
|
||||
finalizeParser :: Parser 'Output (P.ParseT Identity) a -> ParserFn a
|
||||
finalizeParser parser = runIdentity . P.runParseT . P.runParser parser
|
||||
|
||||
-- checks that there are no conflicting root field names between remotes and
|
||||
-- hasura fields
|
||||
remoteSchemaFields
|
||||
:: forall arr m
|
||||
. ( ArrowChoice arr
|
||||
, ArrowWriter (Seq InconsistentMetadata) arr
|
||||
, ArrowKleisli m arr
|
||||
, MonadError QErr m
|
||||
)
|
||||
=> ([G.Name], [G.Name], HashMap RemoteSchemaName (RemoteSchemaCtx, MetadataObject))
|
||||
`arr`
|
||||
[( RemoteSchemaName , ParsedIntrospection)]
|
||||
remoteSchemaFields = proc (queryFieldNames, mutationFieldNames, allRemoteSchemas) -> do
|
||||
(| foldlA' (\okSchemas (newSchemaName, (newSchemaContext, newMetadataObject)) -> do
|
||||
checkedDuplicates <- (| withRecordInconsistency (do
|
||||
let (queryOld, mutationOld) =
|
||||
unzip $ fmap ((\case ParsedIntrospection q m _ -> (q,m)) . snd) okSchemas
|
||||
let ParsedIntrospection queryNew mutationNew _subscriptionNew
|
||||
= rscParsed newSchemaContext
|
||||
-- Check for conflicts between remotes
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) (queryNew ++ concat queryOld))) $
|
||||
\name -> throw400 Unexpected $ "Duplicate remote field " <> squote name
|
||||
-- Check for conflicts between this remote and the tables
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) queryNew ++ queryFieldNames)) $
|
||||
\name -> throw400 RemoteSchemaConflicts $ "Field cannot be overwritten by remote field " <> squote name
|
||||
-- Ditto, but for mutations
|
||||
case mutationNew of
|
||||
Nothing -> returnA -< ()
|
||||
Just ms -> do
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) (ms ++ concat (catMaybes mutationOld)))) $
|
||||
\name -> throw400 Unexpected $ "Duplicate remote field " <> squote name
|
||||
-- Ditto, but for mutations
|
||||
bindErrorA -<
|
||||
for_ (duplicates (fmap (P.getName . fDefinition) ms ++ mutationFieldNames)) $
|
||||
\name -> throw400 Unexpected $ "Field cannot be overwritten by remote field " <> squote name
|
||||
-- No need to check subscriptions as these are not supported
|
||||
returnA -< ()
|
||||
) |) newMetadataObject
|
||||
case checkedDuplicates of
|
||||
Nothing -> returnA -< okSchemas
|
||||
Just _ -> returnA -< (newSchemaName, rscParsed newSchemaContext):okSchemas
|
||||
) |) [] (Map.toList allRemoteSchemas)
|
||||
|
||||
buildPostgresQueryFields
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
@ -217,11 +317,8 @@ query'
|
||||
)
|
||||
=> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> [P.FieldParser n RemoteField]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> m [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
query' allTables allFunctions allRemotes allActions nonObjectCustomTypes = do
|
||||
buildPostgresQueryFields allTables allFunctions = do
|
||||
tableSelectExpParsers <- for (toList allTables) \table -> do
|
||||
selectPerms <- tableSelectPermissions table
|
||||
customRootFields <- _tcCustomRootFields . _tciCustomConfig . _tiCoreInfo <$> askTableInfo table
|
||||
@ -234,31 +331,23 @@ query' allTables allFunctions allRemotes allActions nonObjectCustomTypes = do
|
||||
pkDesc = G.Description $ "fetch data from the table: " <> table <<> " using primary key columns"
|
||||
catMaybes <$> sequenceA
|
||||
[ requiredFieldParser (RFDB . QDBSimple) $ selectTable table (fromMaybe tableGQLName $ _tcrfSelect customRootFields) (Just fieldsDesc) perms
|
||||
, mapMaybeFieldParser (RFDB . QDBPrimaryKey) $ selectTableByPk table (fromMaybe pkName $ _tcrfSelectByPk customRootFields) (Just pkDesc) perms
|
||||
, mapMaybeFieldParser (RFDB . QDBAggregation) $ selectTableAggregate table (fromMaybe aggName $ _tcrfSelectAggregate customRootFields) (Just aggDesc) perms
|
||||
, mapMaybeFieldParser (RFDB . QDBPrimaryKey) $ selectTableByPk table (fromMaybe pkName $ _tcrfSelectByPk customRootFields) (Just pkDesc) perms
|
||||
, mapMaybeFieldParser (RFDB . QDBAggregation) $ selectTableAggregate table (fromMaybe aggName $ _tcrfSelectAggregate customRootFields) (Just aggDesc) perms
|
||||
]
|
||||
functionSelectExpParsers <- for allFunctions \function -> do
|
||||
let targetTable = fiReturnType function
|
||||
functionName = fiName function
|
||||
selectPerms <- tableSelectPermissions targetTable
|
||||
for selectPerms \perms -> do
|
||||
tableGQLName <- qualifiedObjectToName functionName
|
||||
displayName <- qualifiedObjectToName functionName
|
||||
let functionDesc = G.Description $ "execute function " <> functionName <<> " which returns " <>> targetTable
|
||||
aggName = tableGQLName <> $$(G.litName "_aggregate")
|
||||
aggName = displayName <> $$(G.litName "_aggregate")
|
||||
aggDesc = G.Description $ "execute function " <> functionName <<> " and query aggregates on result of table type " <>> targetTable
|
||||
catMaybes <$> sequenceA
|
||||
[ requiredFieldParser (RFDB . QDBSimple) $ selectFunction function tableGQLName (Just functionDesc) perms
|
||||
[ requiredFieldParser (RFDB . QDBSimple) $ selectFunction function displayName (Just functionDesc) perms
|
||||
, mapMaybeFieldParser (RFDB . QDBAggregation) $ selectFunctionAggregate function aggName (Just aggDesc) perms
|
||||
]
|
||||
actionParsers <- for allActions $ \actionInfo ->
|
||||
case _adType (_aiDefinition actionInfo) of
|
||||
ActionMutation ActionSynchronous -> pure Nothing
|
||||
ActionMutation ActionAsynchronous ->
|
||||
fmap (fmap (RFAction . AQAsync)) <$> actionAsyncQuery actionInfo
|
||||
ActionQuery ->
|
||||
fmap (fmap (RFAction . AQQuery)) <$> actionExecute nonObjectCustomTypes actionInfo
|
||||
pure $ (concat . catMaybes) (tableSelectExpParsers <> functionSelectExpParsers <> toRemoteFieldParser allRemotes)
|
||||
<> catMaybes actionParsers
|
||||
pure $ (concat . catMaybes) (tableSelectExpParsers <> functionSelectExpParsers)
|
||||
where
|
||||
requiredFieldParser :: (a -> b) -> m (P.FieldParser n a) -> m (Maybe (P.FieldParser n b))
|
||||
requiredFieldParser f = fmap $ Just . fmap f
|
||||
@ -266,10 +355,46 @@ query' allTables allFunctions allRemotes allActions nonObjectCustomTypes = do
|
||||
mapMaybeFieldParser :: (a -> b) -> m (Maybe (P.FieldParser n a)) -> m (Maybe (P.FieldParser n b))
|
||||
mapMaybeFieldParser f = fmap $ fmap $ fmap f
|
||||
|
||||
toRemoteFieldParser p = [Just $ fmap (fmap RFRemote) p]
|
||||
-- | Includes remote schema fields and actions
|
||||
buildActionQueryFields
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
, MonadRole r m
|
||||
, Has QueryContext r
|
||||
)
|
||||
=> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> m [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
buildActionQueryFields allActions nonObjectCustomTypes = do
|
||||
actionParsers <- for allActions $ \actionInfo ->
|
||||
case _adType (_aiDefinition actionInfo) of
|
||||
ActionMutation ActionSynchronous -> pure Nothing
|
||||
ActionMutation ActionAsynchronous ->
|
||||
fmap (fmap (RFAction . AQAsync)) <$> actionAsyncQuery actionInfo
|
||||
ActionQuery ->
|
||||
fmap (fmap (RFAction . AQQuery)) <$> actionExecute nonObjectCustomTypes actionInfo
|
||||
pure $ catMaybes actionParsers
|
||||
|
||||
-- | Similar to @query'@ but for Relay.
|
||||
relayQuery'
|
||||
buildActionSubscriptionFields
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
, MonadRole r m
|
||||
, Has QueryContext r
|
||||
)
|
||||
=> [ActionInfo 'Postgres]
|
||||
-> m [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
buildActionSubscriptionFields allActions = do
|
||||
actionParsers <- for allActions $ \actionInfo ->
|
||||
case _adType (_aiDefinition actionInfo) of
|
||||
ActionMutation ActionAsynchronous ->
|
||||
fmap (fmap (RFAction . AQAsync)) <$> actionAsyncQuery actionInfo
|
||||
ActionMutation ActionSynchronous -> pure Nothing
|
||||
ActionQuery -> pure Nothing
|
||||
pure $ catMaybes actionParsers
|
||||
|
||||
buildRelayPostgresQueryFields
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
@ -279,58 +404,31 @@ relayQuery'
|
||||
=> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> m [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
relayQuery' allTables allFunctions = do
|
||||
tableConnectionSelectParsers <-
|
||||
for (toList allTables) $ \table -> runMaybeT do
|
||||
pkeyColumns <- MaybeT $ (^? tiCoreInfo.tciPrimaryKey._Just.pkColumns)
|
||||
<$> askTableInfo table
|
||||
selectPerms <- MaybeT $ tableSelectPermissions table
|
||||
tableGQLName <- getTableGQLName table
|
||||
let fieldName = tableGQLName <> $$(G.litName "_connection")
|
||||
fieldDesc = Just $ G.Description $ "fetch data from the table: " <>> table
|
||||
lift $ selectTableConnection table fieldName fieldDesc pkeyColumns selectPerms
|
||||
buildRelayPostgresQueryFields allTables allFunctions = do
|
||||
tableConnectionFields <- for (toList allTables) $ \table -> runMaybeT do
|
||||
pkeyColumns <- MaybeT $ (^? tiCoreInfo.tciPrimaryKey._Just.pkColumns)
|
||||
<$> askTableInfo table
|
||||
selectPerms <- MaybeT $ tableSelectPermissions table
|
||||
tableGQLName <- getTableGQLName table
|
||||
let fieldName = tableGQLName <> $$(G.litName "_connection")
|
||||
fieldDesc = Just $ G.Description $ "fetch data from the table: " <>> table
|
||||
lift $ selectTableConnection table fieldName fieldDesc pkeyColumns selectPerms
|
||||
|
||||
functionConnectionSelectParsers <-
|
||||
for allFunctions $ \function -> runMaybeT do
|
||||
let returnTable = fiReturnType function
|
||||
functionName = fiName function
|
||||
pkeyColumns <- MaybeT $ (^? tiCoreInfo.tciPrimaryKey._Just.pkColumns)
|
||||
<$> askTableInfo returnTable
|
||||
selectPerms <- MaybeT $ tableSelectPermissions returnTable
|
||||
tableGQLName <- qualifiedObjectToName functionName
|
||||
let fieldName = tableGQLName <> $$(G.litName "_connection")
|
||||
fieldDesc = Just $ G.Description $ "execute function " <> functionName
|
||||
<<> " which returns " <>> returnTable
|
||||
lift $ selectFunctionConnection function fieldName fieldDesc pkeyColumns selectPerms
|
||||
functionConnectionFields <- for allFunctions $ \function -> runMaybeT do
|
||||
let returnTable = fiReturnType function
|
||||
functionName = fiName function
|
||||
pkeyColumns <- MaybeT $ (^? tiCoreInfo.tciPrimaryKey._Just.pkColumns)
|
||||
<$> askTableInfo returnTable
|
||||
selectPerms <- MaybeT $ tableSelectPermissions returnTable
|
||||
displayName <- qualifiedObjectToName functionName
|
||||
let fieldName = displayName <> $$(G.litName "_connection")
|
||||
fieldDesc = Just $ G.Description $ "execute function " <> functionName
|
||||
<<> " which returns " <>> returnTable
|
||||
lift $ selectFunctionConnection function fieldName fieldDesc pkeyColumns selectPerms
|
||||
|
||||
pure $ map ((RFDB . QDBConnection) <$>) $ catMaybes $
|
||||
tableConnectionSelectParsers <> functionConnectionSelectParsers
|
||||
|
||||
-- | Parse query-type GraphQL requests without introspection
|
||||
query
|
||||
:: forall m n r
|
||||
. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r)
|
||||
=> G.Name
|
||||
-> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> [P.FieldParser n RemoteField]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
query name allTables allFunctions allRemotes allActions nonObjectCustomTypes = do
|
||||
queryFieldsParser <- query' allTables allFunctions allRemotes allActions nonObjectCustomTypes
|
||||
P.safeSelectionSet name Nothing queryFieldsParser
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
subscription
|
||||
:: forall m n r
|
||||
. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r)
|
||||
=> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
subscription allTables allFunctions asyncActions =
|
||||
query $$(G.litName "subscription_root") allTables allFunctions [] asyncActions mempty
|
||||
nodeField_ <- fmap (RFDB . QDBPrimaryKey) <$> nodeField
|
||||
pure $ (:) nodeField_ $ map (fmap (RFDB . QDBConnection)) $ catMaybes $
|
||||
tableConnectionFields <> functionConnectionFields
|
||||
|
||||
queryRootFromFields
|
||||
:: forall n m
|
||||
@ -338,7 +436,7 @@ queryRootFromFields
|
||||
=> [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
queryRootFromFields fps =
|
||||
P.safeSelectionSet $$(G.litName "query_root") Nothing fps
|
||||
P.safeSelectionSet queryRoot Nothing fps
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
emptyIntrospection
|
||||
@ -386,7 +484,7 @@ queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP = do
|
||||
allIntrospectionTypes <- collectTypes . P.parserType =<< queryRootFromFields emptyIntro
|
||||
let allTypes = Map.unions
|
||||
[ allBasicTypes
|
||||
, Map.filterWithKey (\name _info -> name /= $$(G.litName "query_root")) allIntrospectionTypes
|
||||
, Map.filterWithKey (\name _info -> name /= queryRoot) allIntrospectionTypes
|
||||
]
|
||||
partialSchema = Schema
|
||||
{ sDescription = Nothing
|
||||
@ -398,158 +496,141 @@ queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP = do
|
||||
}
|
||||
let partialQueryFields =
|
||||
basicQueryFP ++ (fmap RFRaw <$> [schema partialSchema, typeIntrospection partialSchema])
|
||||
P.safeSelectionSet $$(G.litName "query_root") Nothing partialQueryFields
|
||||
P.safeSelectionSet queryRoot Nothing partialQueryFields
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
-- | Prepare the parser for query-type GraphQL requests, but with introspection
|
||||
-- for queries, mutations and subscriptions built in.
|
||||
queryWithIntrospection
|
||||
buildQueryParser
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
, MonadRole r m
|
||||
, Has QueryContext r
|
||||
, Has Scenario r
|
||||
)
|
||||
=> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> [P.FieldParser n RemoteField]
|
||||
=> [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
-> [P.FieldParser n RemoteField]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> Maybe (Parser 'Output n (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue)))
|
||||
-> Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue))
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
queryWithIntrospection allTables allFunctions queryRemotes mutationRemotes allActions nonObjectCustomTypes = do
|
||||
basicQueryFP <- query' allTables allFunctions queryRemotes allActions nonObjectCustomTypes
|
||||
mutationP <- mutation allTables mutationRemotes allActions nonObjectCustomTypes
|
||||
subscriptionP <- subscription allTables allFunctions $
|
||||
filter (has (aiDefinition.adType._ActionMutation._ActionAsynchronous)) allActions
|
||||
queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP
|
||||
buildQueryParser pgQueryFields remoteFields allActions nonObjectCustomTypes mutationParser subscriptionParser = do
|
||||
actionQueryFields <- buildActionQueryFields allActions nonObjectCustomTypes
|
||||
let allQueryFields = pgQueryFields <> actionQueryFields <> map (fmap RFRemote) remoteFields
|
||||
queryWithIntrospectionHelper allQueryFields mutationParser subscriptionParser
|
||||
|
||||
relayWithIntrospection
|
||||
-- | Prepare the parser for subscriptions. Every postgres query field is
|
||||
-- exposed as a subscription along with fields to get the status of
|
||||
-- asynchronous actions.
|
||||
buildSubscriptionParser
|
||||
:: forall m n r
|
||||
. ( MonadSchema n m
|
||||
, MonadTableInfo r m
|
||||
, MonadRole r m
|
||||
, Has QueryContext r
|
||||
, Has Scenario r
|
||||
)
|
||||
=> HashSet QualifiedTable
|
||||
-> [FunctionInfo]
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
relayWithIntrospection allTables allFunctions = do
|
||||
nodeFP <- fmap (RFDB . QDBPrimaryKey) <$> nodeField
|
||||
basicQueryFP <- relayQuery' allTables allFunctions
|
||||
mutationP <- mutation allTables [] [] mempty
|
||||
emptyIntro <- emptyIntrospection
|
||||
let relayQueryFP = nodeFP:basicQueryFP
|
||||
basicQueryP <- queryRootFromFields relayQueryFP
|
||||
subscriptionP <- P.safeSelectionSet $$(G.litName "subscription_root") Nothing relayQueryFP
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String. G.unName)))
|
||||
allBasicTypes <- collectTypes $
|
||||
[ P.parserType basicQueryP
|
||||
, P.parserType subscriptionP
|
||||
]
|
||||
++ maybeToList (P.parserType <$> mutationP)
|
||||
allIntrospectionTypes <- collectTypes . P.parserType =<< queryRootFromFields emptyIntro
|
||||
let allTypes = Map.unions
|
||||
[ allBasicTypes
|
||||
, Map.filterWithKey (\name _info -> name /= $$(G.litName "query_root")) allIntrospectionTypes
|
||||
]
|
||||
partialSchema = Schema
|
||||
{ sDescription = Nothing
|
||||
, sTypes = allTypes
|
||||
, sQueryType = P.parserType basicQueryP
|
||||
, sMutationType = P.parserType <$> mutationP
|
||||
, sSubscriptionType = Just $ P.parserType subscriptionP
|
||||
, sDirectives = defaultDirectives
|
||||
}
|
||||
let partialQueryFields =
|
||||
nodeFP : basicQueryFP ++ (fmap RFRaw <$> [schema partialSchema, typeIntrospection partialSchema])
|
||||
P.safeSelectionSet $$(G.litName "query_root") Nothing partialQueryFields
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
-- | Prepare the parser for query-type GraphQL requests, but with introspection
|
||||
-- for queries, mutations and subscriptions built in.
|
||||
unauthenticatedQueryWithIntrospection
|
||||
:: forall m n
|
||||
. ( MonadSchema n m
|
||||
, MonadError QErr m
|
||||
)
|
||||
=> [P.FieldParser n RemoteField]
|
||||
-> [P.FieldParser n RemoteField]
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
unauthenticatedQueryWithIntrospection queryRemotes mutationRemotes = do
|
||||
let basicQueryFP = fmap (fmap RFRemote) queryRemotes
|
||||
mutationP <- unauthenticatedMutation mutationRemotes
|
||||
subscriptionP <- unauthenticatedSubscription @n
|
||||
queryWithIntrospectionHelper basicQueryFP mutationP subscriptionP
|
||||
|
||||
mutation
|
||||
:: forall m n r
|
||||
. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r, Has Scenario r)
|
||||
=> HashSet QualifiedTable
|
||||
-> [P.FieldParser n RemoteField]
|
||||
=> [P.FieldParser n (QueryRootField UnpreparedValue)]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> m (Maybe (Parser 'Output n (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue))))
|
||||
mutation allTables allRemotes allActions nonObjectCustomTypes = do
|
||||
mutationParsers <- for (toList allTables) \table -> do
|
||||
-> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
buildSubscriptionParser pgQueryFields allActions = do
|
||||
actionSubscriptionFields <- buildActionSubscriptionFields allActions
|
||||
let subscriptionFields = pgQueryFields <> actionSubscriptionFields
|
||||
P.safeSelectionSet subscriptionRoot Nothing subscriptionFields
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
buildPGMutationFields
|
||||
:: forall m n r
|
||||
. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r)
|
||||
=> Scenario -> HashSet QualifiedTable
|
||||
-> m [P.FieldParser n (MutationRootField UnpreparedValue)]
|
||||
buildPGMutationFields scenario allTables = do
|
||||
concat . catMaybes <$> for (toList allTables) \table -> do
|
||||
tableCoreInfo <- _tiCoreInfo <$> askTableInfo table
|
||||
tableGQLName <- getTableGQLName table
|
||||
tablePerms <- tablePermissions table
|
||||
for tablePerms \permissions -> do
|
||||
for tablePerms \RolePermInfo{..} -> do
|
||||
let customRootFields = _tcCustomRootFields $ _tciCustomConfig tableCoreInfo
|
||||
viewInfo = _tciViewInfo tableCoreInfo
|
||||
selectPerms = _permSel permissions
|
||||
|
||||
-- If we're in a frontend scenario, we should not include backend_only inserts
|
||||
scenario <- asks getter
|
||||
let scenarioInsertPermissionM = do
|
||||
insertPermission <- _permIns permissions
|
||||
insertPermission <- _permIns
|
||||
if scenario == Frontend && ipiBackendOnly insertPermission
|
||||
then Nothing
|
||||
else return insertPermission
|
||||
|
||||
inserts <- fmap join $ whenMaybe (isMutable viIsInsertable viewInfo) $ for scenarioInsertPermissionM \insertPerms -> do
|
||||
let insertName = $$(G.litName "insert_") <> tableGQLName
|
||||
insertDesc = G.Description $ "insert data into the table: " <>> table
|
||||
insertOneName = $$(G.litName "insert_") <> tableGQLName <> $$(G.litName "_one")
|
||||
insertOneDesc = G.Description $ "insert a single row into the table: " <>> table
|
||||
insert <- insertIntoTable table (fromMaybe insertName $ _tcrfInsert customRootFields) (Just insertDesc) insertPerms selectPerms (_permUpd permissions)
|
||||
insert <- insertIntoTable table (fromMaybe insertName $ _tcrfInsert customRootFields) (Just insertDesc) insertPerms _permSel _permUpd
|
||||
-- select permissions are required for InsertOne: the
|
||||
-- selection set is the same as a select on that table, and it
|
||||
-- therefore can't be populated if the user doesn't have
|
||||
-- select permissions
|
||||
insertOne <- for selectPerms \selPerms ->
|
||||
insertOneIntoTable table (fromMaybe insertOneName $ _tcrfInsertOne customRootFields) (Just insertOneDesc) insertPerms selPerms (_permUpd permissions)
|
||||
pure $ fmap (RFDB . MDBInsert) insert : maybe [] (pure . fmap (RFDB . MDBInsert)) insertOne
|
||||
insertOne <- for _permSel \selPerms ->
|
||||
insertOneIntoTable table (fromMaybe insertOneName $ _tcrfInsertOne customRootFields) (Just insertOneDesc) insertPerms selPerms _permUpd
|
||||
pure $ fmap (RFDB . MDBInsert) <$> insert : maybeToList insertOne
|
||||
|
||||
updates <- fmap join $ whenMaybe (isMutable viIsUpdatable viewInfo) $ for (_permUpd permissions) \updatePerms -> do
|
||||
updates <- fmap join $ whenMaybe (isMutable viIsUpdatable viewInfo) $ for _permUpd \updatePerms -> do
|
||||
let updateName = $$(G.litName "update_") <> tableGQLName
|
||||
updateDesc = G.Description $ "update data of the table: " <>> table
|
||||
updateByPkName = $$(G.litName "update_") <> tableGQLName <> $$(G.litName "_by_pk")
|
||||
updateByPkDesc = G.Description $ "update single row of the table: " <>> table
|
||||
update <- updateTable table (fromMaybe updateName $ _tcrfUpdate customRootFields) (Just updateDesc) updatePerms selectPerms
|
||||
update <- updateTable table (fromMaybe updateName $ _tcrfUpdate customRootFields) (Just updateDesc) updatePerms _permSel
|
||||
-- likewise; furthermore, primary keys can only be tested in
|
||||
-- the `where` clause if the user has select permissions for
|
||||
-- them, which at the very least requires select permissions
|
||||
updateByPk <- join <$> for selectPerms
|
||||
updateByPk <- join <$> for _permSel
|
||||
(updateTableByPk table (fromMaybe updateByPkName $ _tcrfUpdateByPk customRootFields) (Just updateByPkDesc) updatePerms)
|
||||
pure $ fmap (RFDB . MDBUpdate) <$> catMaybes [update, updateByPk]
|
||||
|
||||
deletes <- fmap join $ whenMaybe (isMutable viIsDeletable viewInfo) $ for (_permDel permissions) \deletePerms -> do
|
||||
let deleteName = $$(G.litName "delete_") <> tableGQLName
|
||||
deleteDesc = G.Description $ "delete data from the table: " <>> table
|
||||
deleteByPkName = $$(G.litName "delete_") <> tableGQLName <> $$(G.litName "_by_pk")
|
||||
deleteByPkDesc = G.Description $ "delete single row from the table: " <>> table
|
||||
delete <- deleteFromTable table (fromMaybe deleteName $ _tcrfDelete customRootFields) (Just deleteDesc) deletePerms selectPerms
|
||||
-- when the table/view is mutable and there exists a delete permission
|
||||
deletes <- fmap join $ whenMaybe (isMutable viIsDeletable viewInfo) $
|
||||
for _permDel $ \deletePermission -> do
|
||||
delete <- buildDeleteField table tableGQLName (_tcrfDelete customRootFields)
|
||||
deletePermission _permSel
|
||||
-- select permission is needed for deleteByPk field so that a return type
|
||||
-- for the field can be generated
|
||||
deleteByPk <- fmap join $ for _permSel $
|
||||
buildDeleteByPkField table tableGQLName (_tcrfDeleteByPk customRootFields) deletePermission
|
||||
|
||||
-- ditto
|
||||
deleteByPk <- join <$> for selectPerms
|
||||
(deleteFromTableByPk table (fromMaybe deleteByPkName $ _tcrfDeleteByPk customRootFields) (Just deleteByPkDesc) deletePerms)
|
||||
pure $ fmap (RFDB . MDBDelete) delete : maybe [] (pure . fmap (RFDB . MDBDelete)) deleteByPk
|
||||
pure $ fmap (RFDB . MDBDelete) <$> delete : maybeToList deleteByPk
|
||||
|
||||
pure $ concat $ catMaybes [inserts, updates, deletes]
|
||||
|
||||
where
|
||||
buildDeleteField table tableGQLName customName deletePermission selectPermission = do
|
||||
let deleteName = $$(G.litName "delete_") <> tableGQLName
|
||||
deleteDesc = G.Description $ "delete data from the table: " <>> table
|
||||
deleteFromTable table (fromMaybe deleteName customName) (Just deleteDesc)
|
||||
deletePermission selectPermission
|
||||
|
||||
buildDeleteByPkField table tableGQLName customName deletePermission = do
|
||||
let fieldName = $$(G.litName "delete_") <> tableGQLName <> $$(G.litName "_by_pk")
|
||||
fieldDescription = G.Description $ "delete single row from the table: " <>> table
|
||||
deleteFromTableByPk table (fromMaybe fieldName customName) (Just fieldDescription) deletePermission
|
||||
|
||||
subscriptionRoot :: G.Name
|
||||
subscriptionRoot = $$(G.litName "subscription_root")
|
||||
|
||||
mutationRoot :: G.Name
|
||||
mutationRoot = $$(G.litName "mutation_root")
|
||||
|
||||
queryRoot :: G.Name
|
||||
queryRoot = $$(G.litName "query_root")
|
||||
|
||||
buildMutationParser
|
||||
:: forall m n r
|
||||
. (MonadSchema n m, MonadTableInfo r m, MonadRole r m, Has QueryContext r)
|
||||
=> [P.FieldParser n RemoteField]
|
||||
-> [ActionInfo 'Postgres]
|
||||
-> NonObjectTypeMap
|
||||
-> [P.FieldParser n (MutationRootField UnpreparedValue)]
|
||||
-> m (Maybe (Parser 'Output n (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue))))
|
||||
buildMutationParser allRemotes allActions nonObjectCustomTypes pgMutationFields = do
|
||||
actionParsers <- for allActions $ \actionInfo ->
|
||||
case _adType (_aiDefinition actionInfo) of
|
||||
ActionMutation ActionSynchronous ->
|
||||
@ -557,28 +638,8 @@ mutation allTables allRemotes allActions nonObjectCustomTypes = do
|
||||
ActionMutation ActionAsynchronous ->
|
||||
fmap (fmap (RFAction . AMAsync)) <$> actionAsyncMutation nonObjectCustomTypes actionInfo
|
||||
ActionQuery -> pure Nothing
|
||||
|
||||
let mutationFieldsParser = concat (catMaybes mutationParsers) <> catMaybes actionParsers <> fmap (fmap RFRemote) allRemotes
|
||||
let mutationFieldsParser = pgMutationFields <> catMaybes actionParsers <> fmap (fmap RFRemote) allRemotes
|
||||
if null mutationFieldsParser
|
||||
then pure Nothing
|
||||
else fmap Just $ P.safeSelectionSet $$(G.litName "mutation_root") (Just $ G.Description "mutation root") mutationFieldsParser
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
unauthenticatedMutation
|
||||
:: forall n m
|
||||
. (MonadError QErr m, MonadParse n)
|
||||
=> [P.FieldParser n RemoteField]
|
||||
-> m (Maybe (Parser 'Output n (OMap.InsOrdHashMap G.Name (MutationRootField UnpreparedValue))))
|
||||
unauthenticatedMutation allRemotes =
|
||||
let mutationFieldsParser = fmap (fmap RFRemote) allRemotes
|
||||
in if null mutationFieldsParser
|
||||
then pure Nothing
|
||||
else fmap Just $ P.safeSelectionSet $$(G.litName "mutation_root") Nothing mutationFieldsParser
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
unauthenticatedSubscription
|
||||
:: forall n m. (MonadParse n, MonadError QErr m)
|
||||
=> m (Parser 'Output n (OMap.InsOrdHashMap G.Name (QueryRootField UnpreparedValue)))
|
||||
unauthenticatedSubscription =
|
||||
P.safeSelectionSet $$(G.litName "subscription_root") Nothing []
|
||||
<&> fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
else P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser
|
||||
<&> Just . fmap (fmap (P.handleTypename (RFRaw . J.String . G.unName)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user