mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 17:31:56 +03:00
Refactor type name customization
Source typename customization (hasura/graphql-engine@aac64f2c81) introduced a mechanism to change certain names in the GraphQL schema that is exposed. In particular it allows last-minute modification of: 1. the names of some types, and 2. the names of some root fields. The above two items are assigned distinct customization algorithms, and at times both algorithms are in scope. So a need to distinguish them is needed. In the original design, this was addressed by introducing a newtype wrapper `Typename` around GraphQL `Name`s, dedicated to the names of types. However, in the majority of the codebase, type names are also represented by `Name`. For this reason, it was unavoidable to allow for easy conversion. This was supported by a `HasName Typename` instance, as well as by publishing the constructors of `Typename`. This means that the type safety that newtypes can add is lost. In particular, it is now very easy to confuse type name customization with root field name customization. This refactors the above design by instead introducing newtypes around the customization operations: ```haskell newtype MkTypename = MkTypename {runMkTypename :: Name -> Name} deriving (Semigroup, Monoid) via (Endo Name) newtype MkRootFieldName = MkRootFieldName {runMkRootFieldName :: Name -> Name} deriving (Semigroup, Monoid) via (Endo Name) ``` The `Monoid` instance allows easy composition of customization operations, piggybacking off of the type of `Endo`maps. This design allows safe co-existence of the two customization algorithms, while avoiding the syntactic overhead of packing and unpacking newtypes. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/2989 GitOrigin-RevId: da3a353a9b003ee40c8d0a1e02872e99d2edd3ca
This commit is contained in:
Auke Booij
hasura-bot
parent
5bfce057c6
commit
29158900d8
@ -208,7 +208,7 @@ bqColumnParser columnType (G.Nullability isNullable) =
|
||||
BigQuery.DatetimeScalarType -> pure $ possiblyNullable scalarType $ BigQuery.DatetimeValue . BigQuery.Datetime <$> P.string
|
||||
BigQuery.GeographyScalarType -> pure $ possiblyNullable scalarType $ BigQuery.GeographyValue . BigQuery.Geography <$> P.string
|
||||
BigQuery.TimestampScalarType -> do
|
||||
let schemaType = P.Nullable . P.TNamed $ P.mkDefinition (P.Typename stringScalar) Nothing P.TIScalar
|
||||
let schemaType = P.Nullable . P.TNamed $ P.mkDefinition stringScalar Nothing P.TIScalar
|
||||
pure $
|
||||
possiblyNullable scalarType $
|
||||
Parser
|
||||
@ -291,7 +291,7 @@ bqComparisonExps = P.memoize 'comparisonExps $ \columnType -> do
|
||||
typedParser <- columnParser columnType (G.Nullability False)
|
||||
nullableTextParser <- columnParser (ColumnScalar @'BigQuery BigQuery.StringScalarType) (G.Nullability True)
|
||||
-- textParser <- columnParser (ColumnScalar @'BigQuery BigQuery.StringScalarType) (G.Nullability False)
|
||||
let name = P.Typename $ P.getName typedParser <> $$(G.litName "_BigQuery_comparison_exp")
|
||||
let name = P.getName typedParser <> $$(G.litName "_BigQuery_comparison_exp")
|
||||
desc =
|
||||
G.Description $
|
||||
"Boolean expression to compare columns of type "
|
||||
|
||||
@ -275,7 +275,7 @@ msColumnParser columnType (G.Nullability isNullable) =
|
||||
MSSQL.BitType -> pure $ ODBC.BoolValue <$> P.boolean
|
||||
_ -> do
|
||||
name <- MSSQL.mkMSSQLScalarTypeName scalarType
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition (P.Typename name) Nothing P.TIScalar
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
||||
pure $
|
||||
Parser
|
||||
{ pType = schemaType,
|
||||
@ -358,7 +358,7 @@ msComparisonExps = P.memoize 'comparisonExps \columnType -> do
|
||||
textListParser = fmap openValueOrigin <$> P.list textParser
|
||||
|
||||
-- field info
|
||||
let name = P.Typename $ P.getName typedParser <> $$(G.litName "_MSSQL_comparison_exp")
|
||||
let name = P.getName typedParser <> $$(G.litName "_MSSQL_comparison_exp")
|
||||
desc =
|
||||
G.Description $
|
||||
"Boolean expression to compare columns of type "
|
||||
|
||||
@ -185,7 +185,7 @@ columnParser' columnType (G.Nullability isNullable) =
|
||||
MySQL.Timestamp -> pure $ possiblyNullable scalarType $ MySQL.TimestampValue <$> P.string
|
||||
_ -> do
|
||||
name <- MySQL.mkMySQLScalarTypeName scalarType
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition (P.Typename name) Nothing P.TIScalar
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
||||
pure $
|
||||
Parser
|
||||
{ pType = schemaType,
|
||||
@ -261,7 +261,7 @@ comparisonExps' = P.memoize 'comparisonExps $ \columnType -> do
|
||||
typedParser <- columnParser columnType (G.Nullability False)
|
||||
nullableTextParser <- columnParser (ColumnScalar @'MySQL MySQL.VarChar) (G.Nullability True)
|
||||
textParser <- columnParser (ColumnScalar @'MySQL MySQL.VarChar) (G.Nullability False)
|
||||
let name = P.Typename $ P.getName typedParser <> $$(G.litName "_MySQL_comparison_exp")
|
||||
let name = P.getName typedParser <> $$(G.litName "_MySQL_comparison_exp")
|
||||
desc =
|
||||
G.Description $
|
||||
"Boolean expression to compare columns of type "
|
||||
|
||||
@ -213,7 +213,7 @@ columnParser columnType (G.Nullability isNullable) =
|
||||
-- not accept strings.
|
||||
--
|
||||
-- TODO: introduce new dedicated scalars for Postgres column types.
|
||||
name <- P.Typename <$> mkScalarTypeName scalarType
|
||||
name <- mkScalarTypeName scalarType
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
||||
pure $
|
||||
Parser
|
||||
@ -313,7 +313,7 @@ comparisonExps = P.memoize 'comparisonExps \columnType -> do
|
||||
-- `ltxtquery` represents a full-text-search-like pattern for matching `ltree` values.
|
||||
ltxtqueryParser <- columnParser (ColumnScalar PGLtxtquery) (G.Nullability False)
|
||||
maybeCastParser <- castExp columnType
|
||||
let name = P.Typename $ P.getName typedParser <> $$(G.litName "_comparison_exp")
|
||||
let name = P.getName typedParser <> $$(G.litName "_comparison_exp")
|
||||
desc =
|
||||
G.Description $
|
||||
"Boolean expression to compare columns of type "
|
||||
@ -564,7 +564,7 @@ comparisonExps = P.memoize 'comparisonExps \columnType -> do
|
||||
targetName <- mkScalarTypeName targetScalar
|
||||
targetOpExps <- comparisonExps $ ColumnScalar targetScalar
|
||||
let field = P.fieldOptional targetName Nothing $ (targetScalar,) <$> targetOpExps
|
||||
pure $ P.object (P.Typename sourceName) Nothing $ M.fromList . maybeToList <$> field
|
||||
pure $ P.object sourceName Nothing $ M.fromList . maybeToList <$> field
|
||||
|
||||
geographyWithinDistanceInput ::
|
||||
forall pgKind m n r.
|
||||
@ -581,7 +581,7 @@ geographyWithinDistanceInput = do
|
||||
booleanParser <- columnParser (ColumnScalar PGBoolean) (G.Nullability True)
|
||||
floatParser <- columnParser (ColumnScalar PGFloat) (G.Nullability False)
|
||||
pure $
|
||||
P.object (P.Typename $$(G.litName "st_d_within_geography_input")) Nothing $
|
||||
P.object $$(G.litName "st_d_within_geography_input") Nothing $
|
||||
DWithinGeogOp <$> (mkParameter <$> P.field $$(G.litName "distance") Nothing floatParser)
|
||||
<*> (mkParameter <$> P.field $$(G.litName "from") Nothing geographyParser)
|
||||
<*> (mkParameter <$> P.fieldWithDefault $$(G.litName "use_spheroid") Nothing (G.VBoolean True) booleanParser)
|
||||
@ -594,7 +594,7 @@ geometryWithinDistanceInput = do
|
||||
geometryParser <- columnParser (ColumnScalar PGGeometry) (G.Nullability False)
|
||||
floatParser <- columnParser (ColumnScalar PGFloat) (G.Nullability False)
|
||||
pure $
|
||||
P.object (P.Typename $$(G.litName "st_d_within_input")) Nothing $
|
||||
P.object $$(G.litName "st_d_within_input") Nothing $
|
||||
DWithinGeomOp <$> (mkParameter <$> P.field $$(G.litName "distance") Nothing floatParser)
|
||||
<*> (mkParameter <$> P.field $$(G.litName "from") Nothing geometryParser)
|
||||
|
||||
@ -606,7 +606,7 @@ intersectsNbandGeomInput = do
|
||||
geometryParser <- columnParser (ColumnScalar PGGeometry) (G.Nullability False)
|
||||
integerParser <- columnParser (ColumnScalar PGInteger) (G.Nullability False)
|
||||
pure $
|
||||
P.object (P.Typename $$(G.litName "st_intersects_nband_geom_input")) Nothing $
|
||||
P.object $$(G.litName "st_intersects_nband_geom_input") Nothing $
|
||||
STIntersectsNbandGeommin <$> (mkParameter <$> P.field $$(G.litName "nband") Nothing integerParser)
|
||||
<*> (mkParameter <$> P.field $$(G.litName "geommin") Nothing geometryParser)
|
||||
|
||||
@ -618,7 +618,7 @@ intersectsGeomNbandInput = do
|
||||
geometryParser <- columnParser (ColumnScalar PGGeometry) (G.Nullability False)
|
||||
integerParser <- columnParser (ColumnScalar PGInteger) (G.Nullability False)
|
||||
pure $
|
||||
P.object (P.Typename $$(G.litName "st_intersects_geom_nband_input")) Nothing $
|
||||
P.object $$(G.litName "st_intersects_geom_nband_input") Nothing $
|
||||
STIntersectsGeomminNband
|
||||
<$> (mkParameter <$> P.field $$(G.litName "geommin") Nothing geometryParser)
|
||||
<*> (fmap mkParameter <$> P.fieldOptional $$(G.litName "nband") Nothing integerParser)
|
||||
|
||||
@ -97,7 +97,7 @@ customizeNamespace (Just namespace) fromParsedSelection mkNamespaceTypename fiel
|
||||
parser :: Parser 'Output n (NamespacedField a)
|
||||
parser =
|
||||
Namespaced . OMap.mapWithKey fromParsedSelection
|
||||
<$> P.selectionSet (mkNamespaceTypename namespace) Nothing fieldParsers
|
||||
<$> P.selectionSet (runMkTypename mkNamespaceTypename namespace) Nothing fieldParsers
|
||||
customizeNamespace Nothing _ _ fieldParsers =
|
||||
-- No namespace so just wrap the field parser results in @NotNamespaced@.
|
||||
fmap NotNamespaced <$> fieldParsers
|
||||
|
||||
@ -255,7 +255,7 @@ fieldWithDefault name description defaultValue parser =
|
||||
|
||||
enum ::
|
||||
MonadParse m =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
NonEmpty (Definition EnumValueInfo, a) ->
|
||||
Parser 'Both m a
|
||||
@ -289,7 +289,7 @@ enum name description values =
|
||||
-- the spec.
|
||||
object ::
|
||||
MonadParse m =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
InputFieldsParser m a ->
|
||||
Parser 'Input m a
|
||||
|
||||
@ -122,7 +122,7 @@ multiple parser = parser {pType = Nullable $ TList $ pType parser}
|
||||
-- | A variant of 'selectionSetObject' which doesn't implement any interfaces
|
||||
selectionSet ::
|
||||
MonadParse m =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
[FieldParser m a] ->
|
||||
Parser 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a))
|
||||
@ -130,7 +130,7 @@ selectionSet name desc fields = selectionSetObject name desc fields []
|
||||
|
||||
safeSelectionSet ::
|
||||
(MonadError QErr n, MonadParse m) =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
[FieldParser m a] ->
|
||||
n (Parser 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a)))
|
||||
@ -147,7 +147,7 @@ safeSelectionSet name desc fields
|
||||
-- See also Note [Selectability of tables].
|
||||
selectionSetObject ::
|
||||
MonadParse m =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
-- | Fields of this object, including any fields that are required from the
|
||||
-- interfaces that it implements. Note that we can't derive those fields from
|
||||
@ -208,7 +208,7 @@ selectionSetObject name description parsers implementsInterfaces =
|
||||
|
||||
selectionSetInterface ::
|
||||
(MonadParse n, Traversable t) =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
-- | Fields defined in this interface
|
||||
[FieldParser n a] ->
|
||||
@ -239,7 +239,7 @@ selectionSetInterface name description fields objectImplementations =
|
||||
|
||||
selectionSetUnion ::
|
||||
(MonadParse n, Traversable t) =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
-- | The member object types.
|
||||
t (Parser 'Output n b) ->
|
||||
|
||||
@ -87,8 +87,8 @@ uuid = mkScalar name Nothing \case
|
||||
name = $$(litName "uuid")
|
||||
|
||||
json, jsonb :: MonadParse m => Parser 'Both m A.Value
|
||||
json = jsonScalar (Typename $$(litName "json")) Nothing
|
||||
jsonb = jsonScalar (Typename $$(litName "jsonb")) Nothing
|
||||
json = jsonScalar $$(litName "json") Nothing
|
||||
jsonb = jsonScalar $$(litName "jsonb") Nothing
|
||||
|
||||
-- | Additional validation on integers. We do keep the same type name in the schema for backwards
|
||||
-- compatibility.
|
||||
@ -130,7 +130,7 @@ bigInt = mkScalar intScalar Nothing \case
|
||||
-- explicit use of the Parser constructor.
|
||||
unsafeRawScalar ::
|
||||
MonadParse n =>
|
||||
Typename ->
|
||||
Name ->
|
||||
Maybe Description ->
|
||||
Parser 'Both n (InputValue Variable)
|
||||
unsafeRawScalar name description =
|
||||
@ -141,7 +141,7 @@ unsafeRawScalar name description =
|
||||
|
||||
-- | Creates a parser that transforms its input into a JSON value. 'valueToJSON'
|
||||
-- does properly unpack variables.
|
||||
jsonScalar :: MonadParse m => Typename -> Maybe Description -> Parser 'Both m A.Value
|
||||
jsonScalar :: MonadParse m => Name -> Maybe Description -> Parser 'Both m A.Value
|
||||
jsonScalar name description =
|
||||
Parser
|
||||
{ pType = schemaType,
|
||||
@ -165,7 +165,7 @@ mkScalar name description parser =
|
||||
pParser = peelVariable (toGraphQLType schemaType) >=> parser
|
||||
}
|
||||
where
|
||||
schemaType = NonNullable $ TNamed $ mkDefinition (Typename name) description TIScalar
|
||||
schemaType = NonNullable $ TNamed $ mkDefinition name description TIScalar
|
||||
|
||||
convertWith ::
|
||||
MonadParse m =>
|
||||
|
||||
@ -6,8 +6,7 @@ module Hasura.GraphQL.Parser.Schema
|
||||
type (<:) (..),
|
||||
|
||||
-- * Types
|
||||
Typename (..),
|
||||
MkTypename,
|
||||
MkTypename (..),
|
||||
mkTypename,
|
||||
withTypenameCustomization,
|
||||
Type (..),
|
||||
@ -32,7 +31,6 @@ module Hasura.GraphQL.Parser.Schema
|
||||
UnionInfo (..),
|
||||
|
||||
-- * Definitions
|
||||
DefinitionName,
|
||||
Definition (..),
|
||||
mkDefinition,
|
||||
addDefinitionUnique,
|
||||
@ -63,6 +61,7 @@ import Data.HashMap.Strict.Extended qualified as Map
|
||||
import Data.HashSet qualified as Set
|
||||
import Data.Hashable (Hashable (..))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Monoid
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Extended
|
||||
import Hasura.Incremental (Cacheable)
|
||||
@ -82,25 +81,20 @@ class HasName a where
|
||||
instance HasName Name where
|
||||
getName = id
|
||||
|
||||
-- | newtype wrapper to allow us to distinguish type names from other GraphQL names.
|
||||
newtype Typename = Typename {unTypename :: Name} deriving (Eq, Ord, Show, HasName, J.ToJSON)
|
||||
-- | Type name customization
|
||||
newtype MkTypename = MkTypename {runMkTypename :: Name -> Name}
|
||||
deriving (Semigroup, Monoid) via (Endo Name)
|
||||
|
||||
instance ToTxt Typename where
|
||||
toTxt = toTxt . getName
|
||||
|
||||
-- | Function to turn a @Name@ into a @Typename@ while possibly applying some customizations.
|
||||
type MkTypename = Name -> Typename
|
||||
|
||||
-- | Inject a new @Typename@ customization function into the environment.
|
||||
-- | Inject a new @MkTypename@ customization function into the environment.
|
||||
-- This can be used by schema-building code (with @MonadBuildSchema@ constraint) to ensure
|
||||
-- the correct typename customizations are applied.
|
||||
-- the correct type name customizations are applied.
|
||||
withTypenameCustomization :: forall m r a. (MonadReader r m, Has MkTypename r) => MkTypename -> m a -> m a
|
||||
withTypenameCustomization = local . set hasLens
|
||||
|
||||
-- | Apply the typename customization function from the current environment.
|
||||
mkTypename :: (MonadReader r m, Has MkTypename r) => Name -> m Typename
|
||||
-- | Apply the type name customization function from the current environment.
|
||||
mkTypename :: (MonadReader r m, Has MkTypename r) => Name -> m Name
|
||||
mkTypename name =
|
||||
($ name) <$> asks getter
|
||||
($ name) . runMkTypename <$> asks getter
|
||||
|
||||
-- | GraphQL types are divided into two classes: input types and output types.
|
||||
-- The GraphQL spec does not use the word “kind” to describe these classes, but
|
||||
@ -566,15 +560,6 @@ data SomeTypeInfo = forall k. SomeTypeInfo (TypeInfo k)
|
||||
instance Eq SomeTypeInfo where
|
||||
SomeTypeInfo a == SomeTypeInfo b = eqTypeInfo a b
|
||||
|
||||
type family DefinitionName a where
|
||||
DefinitionName (TypeInfo k) = Typename
|
||||
DefinitionName SomeTypeInfo = Typename
|
||||
DefinitionName InterfaceInfo = Typename
|
||||
DefinitionName ObjectInfo = Typename
|
||||
DefinitionName InputFieldInfo = Name
|
||||
DefinitionName FieldInfo = Name
|
||||
DefinitionName EnumValueInfo = Name
|
||||
|
||||
data Definition a = Definition
|
||||
{ dName :: Name,
|
||||
-- | A unique identifier used to break cycles in mutually-recursive type
|
||||
@ -594,8 +579,8 @@ instance Hashable a => Hashable (Definition a) where
|
||||
hashWithSalt salt Definition {..} =
|
||||
salt `hashWithSalt` dName `hashWithSalt` dInfo
|
||||
|
||||
mkDefinition :: HasName (DefinitionName a) => DefinitionName a -> Maybe Description -> a -> Definition a
|
||||
mkDefinition name description info = Definition (getName name) Nothing description info
|
||||
mkDefinition :: Name -> Maybe Description -> a -> Definition a
|
||||
mkDefinition name description info = Definition name Nothing description info
|
||||
|
||||
instance Eq a => Eq (Definition a) where
|
||||
(==) = eq1
|
||||
|
||||
@ -81,8 +81,8 @@ validateSchemaCustomizationsConsistent remoteSchemaCustomizer (RemoteSchemaIntro
|
||||
G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} ->
|
||||
for_ _itdPossibleTypes $ \typeName ->
|
||||
for_ _itdFieldsDefinition $ \G.FieldDefinition {..} -> do
|
||||
let interfaceCustomizedFieldName = customizeFieldName _itdName _fldName
|
||||
typeCustomizedFieldName = customizeFieldName typeName _fldName
|
||||
let interfaceCustomizedFieldName = runCustomizeRemoteFieldName customizeFieldName _itdName _fldName
|
||||
typeCustomizedFieldName = runCustomizeRemoteFieldName customizeFieldName typeName _fldName
|
||||
when (interfaceCustomizedFieldName /= typeCustomizedFieldName) $
|
||||
throwRemoteSchema $
|
||||
"Remote schema customization inconsistency: field name mapping for field "
|
||||
@ -109,11 +109,11 @@ validateSchemaCustomizationsDistinct remoteSchemaCustomizer (RemoteSchemaIntrosp
|
||||
traverse_ validateFieldMappingsAreDistinct typeDefinitions
|
||||
where
|
||||
customizeTypeName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer
|
||||
customizeFieldName = remoteSchemaCustomizeFieldName remoteSchemaCustomizer
|
||||
customizeFieldName = runCustomizeRemoteFieldName (remoteSchemaCustomizeFieldName remoteSchemaCustomizer)
|
||||
|
||||
validateTypeMappingsAreDistinct :: m ()
|
||||
validateTypeMappingsAreDistinct = do
|
||||
let dups = duplicates $ (customizeTypeName . typeDefinitionName) <$> typeDefinitions
|
||||
let dups = duplicates $ (runMkTypename customizeTypeName . typeDefinitionName) <$> typeDefinitions
|
||||
unless (Set.null dups) $
|
||||
throwRemoteSchema $
|
||||
"Type name mappings are not distinct; the following types appear more than once: "
|
||||
|
||||
@ -246,15 +246,15 @@ buildRoleContext
|
||||
(,,)
|
||||
<$> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_query")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_query")))
|
||||
(buildQueryFields sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
<*> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_mutation_frontend")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_mutation_frontend")))
|
||||
(buildMutationFields Frontend sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
<*> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_mutation_backend")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_mutation_backend")))
|
||||
(buildMutationFields Backend sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
|
||||
buildRelayRoleContext ::
|
||||
@ -331,15 +331,15 @@ buildRelayRoleContext
|
||||
(,,)
|
||||
<$> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_query")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_query")))
|
||||
(buildRelayQueryFields sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
<*> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_mutation_frontend")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_mutation_frontend")))
|
||||
(buildMutationFields Frontend sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
<*> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_mutation_backend")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_mutation_backend")))
|
||||
(buildMutationFields Backend sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
|
||||
buildFullestDBSchema ::
|
||||
@ -387,11 +387,11 @@ buildFullestDBSchema queryContext sources allActionInfos nonObjectCustomTypes =
|
||||
(,)
|
||||
<$> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_query")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_query")))
|
||||
(buildQueryFields sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
<*> customizeFields
|
||||
sourceCustomization
|
||||
(mkTypename . (<> $$(G.litName "_mutation_frontend")))
|
||||
(mkTypename <> P.MkTypename (<> $$(G.litName "_mutation_frontend")))
|
||||
(buildMutationFields Frontend sourceName sourceConfig validTables validFunctions queryTagsConfig)
|
||||
|
||||
-- The `unauthenticatedContext` is used when the user queries the graphql-engine
|
||||
@ -785,14 +785,14 @@ mkRootField sourceName sourceConfig queryTagsConfig inj =
|
||||
takeExposedAs :: FunctionExposedAs -> FunctionCache b -> FunctionCache b
|
||||
takeExposedAs x = Map.filter ((== x) . _fiExposedAs)
|
||||
|
||||
subscriptionRoot :: P.Typename
|
||||
subscriptionRoot = P.Typename $$(G.litName "subscription_root")
|
||||
subscriptionRoot :: G.Name
|
||||
subscriptionRoot = $$(G.litName "subscription_root")
|
||||
|
||||
mutationRoot :: P.Typename
|
||||
mutationRoot = P.Typename $$(G.litName "mutation_root")
|
||||
mutationRoot :: G.Name
|
||||
mutationRoot = $$(G.litName "mutation_root")
|
||||
|
||||
queryRoot :: P.Typename
|
||||
queryRoot = P.Typename $$(G.litName "query_root")
|
||||
queryRoot :: G.Name
|
||||
queryRoot = $$(G.litName "query_root")
|
||||
|
||||
finalizeParser :: Parser 'Output (P.ParseT Identity) a -> ParserFn a
|
||||
finalizeParser parser = runIdentity . P.runParseT . P.runParser parser
|
||||
@ -821,7 +821,7 @@ runMonadSchema ::
|
||||
ConcreteSchemaT m a ->
|
||||
m a
|
||||
runMonadSchema roleName queryContext pgSources m =
|
||||
P.runSchemaT m `runReaderT` (roleName, pgSources, queryContext, P.Typename, id, const id)
|
||||
P.runSchemaT m `runReaderT` (roleName, pgSources, queryContext, mempty, mempty, mempty)
|
||||
|
||||
-- | Whether the request is sent with `x-hasura-use-backend-only-permissions` set to `true`.
|
||||
data Scenario = Backend | Frontend deriving (Enum, Show, Eq)
|
||||
|
||||
@ -318,7 +318,7 @@ actionInputArguments nonObjectTypeMap arguments = do
|
||||
`onNothing` throw500 "object type for a field found in custom input object type"
|
||||
(fieldName,) <$> argumentParser fieldName fieldDesc fieldType nonObjectFieldType
|
||||
pure $
|
||||
P.object (P.Typename objectName) objectDesc $
|
||||
P.object objectName objectDesc $
|
||||
J.Object <$> inputFieldsToObject inputFieldsParsers
|
||||
|
||||
mkArgumentInputFieldParser ::
|
||||
@ -358,9 +358,9 @@ customScalarParser = \case
|
||||
| _stdName == floatScalar -> J.toJSON <$> P.float
|
||||
| _stdName == stringScalar -> J.toJSON <$> P.string
|
||||
| _stdName == boolScalar -> J.toJSON <$> P.boolean
|
||||
| otherwise -> P.jsonScalar (P.Typename _stdName) _stdDescription
|
||||
| otherwise -> P.jsonScalar _stdName _stdDescription
|
||||
ASTReusedScalar name pgScalarType ->
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition (P.Typename name) Nothing P.TIScalar
|
||||
let schemaType = P.NonNullable $ P.TNamed $ P.mkDefinition name Nothing P.TIScalar
|
||||
in P.Parser
|
||||
{ pType = schemaType,
|
||||
pParser =
|
||||
@ -385,4 +385,4 @@ customEnumParser (EnumTypeDefinition typeName description enumValues) =
|
||||
valueName
|
||||
(_evdDescription enumValue)
|
||||
P.EnumValueInfo
|
||||
in P.enum (P.Typename enumName) description enumValueDefinitions
|
||||
in P.enum enumName description enumValueDefinitions
|
||||
|
||||
@ -312,7 +312,7 @@ typeField =
|
||||
_ -> J.Null
|
||||
in applyPrinter
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__Type"))
|
||||
$$(G.litName "__Type")
|
||||
Nothing
|
||||
[ kind,
|
||||
name,
|
||||
@ -360,7 +360,7 @@ inputValue =
|
||||
_ -> J.Null
|
||||
in applyPrinter
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__InputValue"))
|
||||
$$(G.litName "__InputValue")
|
||||
Nothing
|
||||
[ name,
|
||||
description,
|
||||
@ -400,7 +400,7 @@ enumValue =
|
||||
$> const J.Null
|
||||
in applyPrinter
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__EnumValue"))
|
||||
$$(G.litName "__EnumValue")
|
||||
Nothing
|
||||
[ name,
|
||||
description,
|
||||
@ -426,7 +426,7 @@ typeKind ::
|
||||
Parser 'Both n ()
|
||||
typeKind =
|
||||
P.enum
|
||||
(P.Typename $$(G.litName "__TypeKind"))
|
||||
$$(G.litName "__TypeKind")
|
||||
Nothing
|
||||
( NE.fromList
|
||||
[ mkDefinition $$(G.litName "ENUM"),
|
||||
@ -486,7 +486,7 @@ fieldField =
|
||||
$> const J.Null
|
||||
in applyPrinter
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__Field"))
|
||||
$$(G.litName "__Field")
|
||||
Nothing
|
||||
[ name,
|
||||
description,
|
||||
@ -533,7 +533,7 @@ directiveSet =
|
||||
$> const J.Null
|
||||
in applyPrinter
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__Directive"))
|
||||
$$(G.litName "__Directive")
|
||||
Nothing
|
||||
[ name,
|
||||
description,
|
||||
@ -605,7 +605,7 @@ schemaSet fakeSchema =
|
||||
return $ J.array $ map printer $ sDirectives fakeSchema
|
||||
in selectionSetToJSON . fmap (P.handleTypename nameAsJSON)
|
||||
<$> P.selectionSet
|
||||
(P.Typename $$(G.litName "__Schema"))
|
||||
$$(G.litName "__Schema")
|
||||
Nothing
|
||||
[ description,
|
||||
types,
|
||||
|
||||
@ -15,7 +15,6 @@ import Hasura.GraphQL.Parser
|
||||
)
|
||||
import Hasura.GraphQL.Parser qualified as P
|
||||
import Hasura.GraphQL.Parser.Class
|
||||
import Hasura.GraphQL.Parser.Schema (Typename (..))
|
||||
import Hasura.GraphQL.Schema.Backend
|
||||
import Hasura.GraphQL.Schema.Common
|
||||
import Hasura.GraphQL.Schema.Table
|
||||
@ -176,7 +175,7 @@ orderByAggregation sourceName tableInfo selectPermissions = memoizeOn 'orderByAg
|
||||
InputFieldsParser n (Maybe [IR.OrderByItemG b (IR.AnnotatedAggregateOrderBy b)])
|
||||
parseOperator mkTypename operator tableGQLName columns =
|
||||
let opText = G.unName operator
|
||||
objectName = mkTypename $ tableGQLName <> $$(G.litName "_") <> operator <> $$(G.litName "_order_by")
|
||||
objectName = P.runMkTypename mkTypename $ tableGQLName <> $$(G.litName "_") <> operator <> $$(G.litName "_order_by")
|
||||
objectDesc = Just $ G.Description $ "order by " <> opText <> "() on columns of table " <>> tableName
|
||||
in P.fieldOptional operator Nothing (P.object objectName objectDesc columns)
|
||||
`mapField` map (\(col, info) -> mkOrderByItemG (IR.AAOOp opText col) info)
|
||||
@ -186,7 +185,7 @@ orderByOperator ::
|
||||
(BackendSchema b, MonadParse n) =>
|
||||
Parser 'Both n (Maybe (BasicOrderType b, NullsOrderType b))
|
||||
orderByOperator =
|
||||
P.nullable $ P.enum (Typename $$(G.litName "order_by")) (Just "column ordering options") $ orderByOperators @b
|
||||
P.nullable $ P.enum $$(G.litName "order_by") (Just "column ordering options") $ orderByOperators @b
|
||||
|
||||
mkOrderByItemG :: forall b a. a -> (BasicOrderType b, NullsOrderType b) -> IR.OrderByItemG b a
|
||||
mkOrderByItemG column (orderType, nullsOrder) =
|
||||
|
||||
@ -349,7 +349,7 @@ remoteFieldScalarParser customizeTypename (G.ScalarTypeDefinition description na
|
||||
_ -> pure (Altered False, QueryVariable <$> v)
|
||||
}
|
||||
where
|
||||
customizedTypename = customizeTypename name
|
||||
customizedTypename = runMkTypename customizeTypename name
|
||||
schemaType = NonNullable $ TNamed $ mkDefinition customizedTypename description TIScalar
|
||||
gType = toGraphQLType schemaType
|
||||
|
||||
@ -368,7 +368,7 @@ remoteFieldEnumParser customizeTypename (G.EnumTypeDefinition desc name _directi
|
||||
( mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo,
|
||||
G.VEnum enumName
|
||||
)
|
||||
in fmap (Altered False,) $ P.enum (customizeTypename name) desc $ NE.fromList enumValDefns
|
||||
in fmap (Altered False,) $ P.enum (runMkTypename customizeTypename name) desc $ NE.fromList enumValDefns
|
||||
|
||||
-- | remoteInputObjectParser returns an input parser for a given 'G.InputObjectTypeDefinition'
|
||||
--
|
||||
@ -897,7 +897,7 @@ remoteField sdoc parentTypeName fieldName description argsDefn typeDefn = do
|
||||
argsParser <- argumentsParser argsDefn sdoc
|
||||
customizeTypename <- asks getter
|
||||
customizeFieldName <- asks getter
|
||||
let customizedFieldName = customizeFieldName parentTypeName fieldName
|
||||
let customizedFieldName = runCustomizeRemoteFieldName customizeFieldName parentTypeName fieldName
|
||||
case typeDefn of
|
||||
G.TypeDefinitionObject objTypeDefn -> do
|
||||
remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn
|
||||
@ -975,15 +975,12 @@ customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fie
|
||||
-- In P.selectionSet we lose the resultCustomizer from __typename fields so we need to put it back
|
||||
let resultCustomizer = modifyFieldByName alias $ customizeTypeNameString $ _rscCustomizeTypeName rsCustomizer
|
||||
in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty
|
||||
mkNamespaceTypename = Typename . const (remoteSchemaCustomizeTypeName rsCustomizer rootTypeName)
|
||||
mkNamespaceTypename = MkTypename $ const $ runMkTypename (remoteSchemaCustomizeTypeName rsCustomizer) rootTypeName
|
||||
|
||||
type MonadBuildRemoteSchema r m n = (MonadSchema n m, MonadError QErr m, MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r)
|
||||
|
||||
runMonadBuildRemoteSchema :: Monad m => SchemaT n (ReaderT (MkTypename, CustomizeRemoteFieldName) m) a -> m a
|
||||
runMonadBuildRemoteSchema m = flip runReaderT (Typename, idFieldCustomizer) $ runSchemaT m
|
||||
where
|
||||
idFieldCustomizer :: CustomizeRemoteFieldName
|
||||
idFieldCustomizer = const id
|
||||
runMonadBuildRemoteSchema m = flip runReaderT (mempty, mempty) $ runSchemaT m
|
||||
|
||||
withRemoteSchemaCustomization ::
|
||||
forall m r a.
|
||||
@ -992,5 +989,5 @@ withRemoteSchemaCustomization ::
|
||||
m a ->
|
||||
m a
|
||||
withRemoteSchemaCustomization remoteSchemaCustomizer =
|
||||
withTypenameCustomization (Typename . remoteSchemaCustomizeTypeName remoteSchemaCustomizer)
|
||||
withTypenameCustomization (remoteSchemaCustomizeTypeName remoteSchemaCustomizer)
|
||||
. withRemoteFieldNameCustomization (remoteSchemaCustomizeFieldName remoteSchemaCustomizer)
|
||||
|
||||
@ -504,7 +504,7 @@ tableConnectionSelectionSet sourceName tableInfo selectPermissions = memoizeOn '
|
||||
hasPreviousPageField
|
||||
]
|
||||
in P.nonNullableParser $
|
||||
P.selectionSet (P.Typename $$(G.litName "PageInfo")) Nothing allFields
|
||||
P.selectionSet $$(G.litName "PageInfo") Nothing allFields
|
||||
<&> parsedSelectionsToFields IR.PageInfoTypename
|
||||
|
||||
tableEdgesSelectionSet ::
|
||||
@ -1037,7 +1037,7 @@ tableAggregationFields sourceName tableInfo selectPermissions = memoizeOn 'table
|
||||
FieldParser n (IR.AggregateField b)
|
||||
parseAggOperator mkTypename operator tableGQLName columns =
|
||||
let opText = G.unName operator
|
||||
setName = mkTypename $ tableGQLName <> $$(G.litName "_") <> operator <> $$(G.litName "_fields")
|
||||
setName = P.runMkTypename mkTypename $ tableGQLName <> $$(G.litName "_") <> operator <> $$(G.litName "_fields")
|
||||
setDesc = Just $ G.Description $ "aggregate " <> opText <> " on columns"
|
||||
subselectionParser =
|
||||
P.selectionSet setName setDesc columns
|
||||
@ -1674,7 +1674,7 @@ nodePG = memoizeOn 'nodePG () do
|
||||
pure $ (source,sourceConfig,selectPermissions,tablePkeyColumns,) <$> annotatedFieldsParser
|
||||
pure $
|
||||
P.selectionSetInterface
|
||||
(P.Typename $$(G.litName "Node"))
|
||||
$$(G.litName "Node")
|
||||
(Just nodeInterfaceDescription)
|
||||
[idField]
|
||||
tables
|
||||
|
||||
@ -55,12 +55,13 @@ import Data.Text.Extended
|
||||
import Data.Text.NonEmpty
|
||||
import Database.PG.Query qualified as Q
|
||||
import Hasura.Base.Error
|
||||
import Hasura.GraphQL.Parser.Schema (Variable)
|
||||
import Hasura.GraphQL.Parser.Schema
|
||||
import Hasura.Incremental (Cacheable)
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DDL.Headers (HeaderConf (..))
|
||||
import Hasura.RQL.Types.Common
|
||||
import Hasura.RQL.Types.ResultCustomization
|
||||
import Hasura.RQL.Types.SourceCustomization
|
||||
import Hasura.Session
|
||||
import Language.GraphQL.Draft.Printer qualified as G
|
||||
import Language.GraphQL.Draft.Syntax qualified as G
|
||||
@ -191,12 +192,12 @@ instance Hashable RemoteSchemaCustomizer
|
||||
|
||||
$(J.deriveJSON hasuraJSON ''RemoteSchemaCustomizer)
|
||||
|
||||
remoteSchemaCustomizeTypeName :: RemoteSchemaCustomizer -> G.Name -> G.Name
|
||||
remoteSchemaCustomizeTypeName RemoteSchemaCustomizer {..} typeName =
|
||||
remoteSchemaCustomizeTypeName :: RemoteSchemaCustomizer -> MkTypename
|
||||
remoteSchemaCustomizeTypeName RemoteSchemaCustomizer {..} = MkTypename $ \typeName ->
|
||||
Map.lookupDefault typeName typeName _rscCustomizeTypeName
|
||||
|
||||
remoteSchemaCustomizeFieldName :: RemoteSchemaCustomizer -> G.Name -> G.Name -> G.Name
|
||||
remoteSchemaCustomizeFieldName RemoteSchemaCustomizer {..} typeName fieldName =
|
||||
remoteSchemaCustomizeFieldName :: RemoteSchemaCustomizer -> CustomizeRemoteFieldName
|
||||
remoteSchemaCustomizeFieldName RemoteSchemaCustomizer {..} = CustomizeRemoteFieldName $ \typeName fieldName ->
|
||||
Map.lookup typeName _rscCustomizeFieldName >>= Map.lookup fieldName & fromMaybe fieldName
|
||||
|
||||
hasTypeOrFieldCustomizations :: RemoteSchemaCustomizer -> Bool
|
||||
|
||||
@ -18,43 +18,41 @@ import Language.GraphQL.Draft.Syntax qualified as G
|
||||
-- | Mapping that can be provided to a ResultCustomizer
|
||||
-- to map top-level field aliases that were not available at field parse time.
|
||||
-- E.g. for aliases created in the remote server query for remote joins.
|
||||
newtype AliasMapping = AliasMapping {unAliasMapping :: Endo G.Name}
|
||||
deriving (Semigroup, Monoid)
|
||||
newtype AliasMapping = AliasMapping {unAliasMapping :: G.Name -> G.Name}
|
||||
deriving (Semigroup, Monoid) via (Endo G.Name)
|
||||
|
||||
-- | AliasMapping that maps a single field name to an alias
|
||||
singletonAliasMapping :: G.Name -> G.Name -> AliasMapping
|
||||
singletonAliasMapping fieldName alias = AliasMapping $
|
||||
Endo $ \fieldName' ->
|
||||
if fieldName == fieldName' then alias else fieldName'
|
||||
singletonAliasMapping fieldName alias = AliasMapping $ \fieldName' ->
|
||||
if fieldName == fieldName'
|
||||
then alias
|
||||
else fieldName'
|
||||
|
||||
-- | Function to modify JSON values returned from the remote server
|
||||
-- e.g. to map values of __typename fields to customized type names.
|
||||
-- The customizer uses Maybe to allow short-circuiting subtrees
|
||||
-- where no customizations are needed.
|
||||
newtype ResultCustomizer = ResultCustomizer {unResultCustomizer :: Maybe (AliasMapping -> Endo JO.Value)}
|
||||
deriving (Semigroup, Monoid)
|
||||
newtype ResultCustomizer = ResultCustomizer {unResultCustomizer :: AliasMapping -> JO.Value -> JO.Value}
|
||||
deriving (Semigroup, Monoid) via (AliasMapping -> Endo JO.Value)
|
||||
|
||||
-- | Apply a ResultCustomizer to a JSON value
|
||||
applyResultCustomizer :: ResultCustomizer -> JO.Value -> JO.Value
|
||||
applyResultCustomizer = maybe id (appEndo . ($ mempty)) . unResultCustomizer
|
||||
applyResultCustomizer = ($ mempty) . unResultCustomizer
|
||||
|
||||
-- | Apply an AliasMapping to a ResultCustomizer.
|
||||
applyAliasMapping :: AliasMapping -> ResultCustomizer -> ResultCustomizer
|
||||
applyAliasMapping aliasMapping (ResultCustomizer m) =
|
||||
ResultCustomizer $
|
||||
m <&> \g aliasMapping' -> g $ aliasMapping' <> aliasMapping
|
||||
ResultCustomizer $ m . (<> aliasMapping)
|
||||
|
||||
-- | Take a ResultCustomizer for a JSON subtree, and a fieldName,
|
||||
-- and produce a ResultCustomizer for a parent object or array of objects
|
||||
-- that applies the subtree customizer to the subtree at the given fieldName.
|
||||
modifyFieldByName :: G.Name -> ResultCustomizer -> ResultCustomizer
|
||||
modifyFieldByName fieldName (ResultCustomizer m) =
|
||||
ResultCustomizer $
|
||||
m <&> \g aliasMapping ->
|
||||
Endo $
|
||||
let Endo f = g mempty -- AliasMapping is only applied to the top level so use mempty for nested customizers
|
||||
modifyFieldByName fieldName ResultCustomizer {..} =
|
||||
ResultCustomizer $ \AliasMapping {..} ->
|
||||
let applyCustomizer = unResultCustomizer mempty
|
||||
modifyFieldByName' = \case
|
||||
JO.Object o -> JO.Object $ JO.adjust f (G.unName $ (appEndo $ unAliasMapping aliasMapping) fieldName) o
|
||||
JO.Object o -> JO.Object $ JO.adjust applyCustomizer (G.unName $ unAliasMapping fieldName) o
|
||||
JO.Array a -> JO.Array $ modifyFieldByName' <$> a
|
||||
v -> v
|
||||
in modifyFieldByName'
|
||||
@ -62,15 +60,11 @@ modifyFieldByName fieldName (ResultCustomizer m) =
|
||||
-- | Create a RemoteResultCustomizer that applies the typeNameMap
|
||||
-- to a JSON string value, e.g. for use in customizing a __typename field value.
|
||||
customizeTypeNameString :: HashMap G.Name G.Name -> ResultCustomizer
|
||||
customizeTypeNameString typeNameMap | Map.null typeNameMap = mempty
|
||||
customizeTypeNameString typeNameMap =
|
||||
if Map.null typeNameMap
|
||||
then mempty
|
||||
else ResultCustomizer $
|
||||
Just $
|
||||
const $
|
||||
Endo $ \case
|
||||
ResultCustomizer $ \_aliasMapping -> \case
|
||||
JO.String t -> JO.String $ G.unName $ customizeTypeName $ G.unsafeMkName t
|
||||
v -> v
|
||||
where
|
||||
customizeTypeName :: G.Name -> G.Name
|
||||
customizeTypeName typeName = Map.lookupDefault typeName typeName typeNameMap
|
||||
v -> v
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Hasura.RQL.Types.SourceCustomization
|
||||
( SourceTypeCustomization,
|
||||
( MkTypename (..),
|
||||
SourceTypeCustomization,
|
||||
RootFieldsCustomization (..),
|
||||
mkCustomizedTypename,
|
||||
emptySourceCustomization,
|
||||
@ -11,7 +12,7 @@ module Hasura.RQL.Types.SourceCustomization
|
||||
SourceCustomization (..),
|
||||
withSourceCustomization,
|
||||
MkRootFieldName,
|
||||
CustomizeRemoteFieldName,
|
||||
CustomizeRemoteFieldName (..),
|
||||
withRemoteFieldNameCustomization,
|
||||
)
|
||||
where
|
||||
@ -19,6 +20,7 @@ where
|
||||
import Control.Lens
|
||||
import Data.Aeson.Extended
|
||||
import Data.Has
|
||||
import Data.Monoid
|
||||
import Hasura.GraphQL.Parser.Schema
|
||||
import Hasura.Incremental.Internal.Dependency (Cacheable)
|
||||
import Hasura.Prelude
|
||||
@ -60,15 +62,15 @@ instance FromJSON SourceTypeCustomization where
|
||||
emptySourceTypeCustomization :: SourceTypeCustomization
|
||||
emptySourceTypeCustomization = SourceTypeCustomization Nothing Nothing
|
||||
|
||||
mkCustomizedTypename :: Maybe SourceTypeCustomization -> G.Name -> Typename
|
||||
mkCustomizedTypename Nothing = Typename
|
||||
mkCustomizedTypename :: Maybe SourceTypeCustomization -> MkTypename
|
||||
mkCustomizedTypename Nothing = mempty
|
||||
mkCustomizedTypename (Just SourceTypeCustomization {..}) =
|
||||
Typename . applyPrefixSuffix _stcPrefix _stcSuffix
|
||||
MkTypename (applyPrefixSuffix _stcPrefix _stcSuffix)
|
||||
|
||||
mkCustomizedFieldName :: Maybe RootFieldsCustomization -> G.Name -> G.Name
|
||||
mkCustomizedFieldName Nothing = id
|
||||
mkCustomizedFieldName :: Maybe RootFieldsCustomization -> MkRootFieldName
|
||||
mkCustomizedFieldName Nothing = mempty
|
||||
mkCustomizedFieldName (Just RootFieldsCustomization {..}) =
|
||||
applyPrefixSuffix _rootfcPrefix _rootfcSuffix
|
||||
MkRootFieldName (applyPrefixSuffix _rootfcPrefix _rootfcSuffix)
|
||||
|
||||
applyPrefixSuffix :: Maybe G.Name -> Maybe G.Name -> G.Name -> G.Name
|
||||
applyPrefixSuffix Nothing Nothing name = name
|
||||
@ -100,7 +102,8 @@ getSourceTypeCustomization :: SourceCustomization -> SourceTypeCustomization
|
||||
getSourceTypeCustomization = fromMaybe emptySourceTypeCustomization . _scTypeNames
|
||||
|
||||
-- | Function to apply root field name customizations.
|
||||
type MkRootFieldName = G.Name -> G.Name
|
||||
newtype MkRootFieldName = MkRootFieldName {runMkRootFieldName :: G.Name -> G.Name}
|
||||
deriving (Semigroup, Monoid) via (Endo G.Name)
|
||||
|
||||
-- | Inject a new root field name customization function into the environment.
|
||||
-- This can be used by schema-building code (with @MonadBuildSchema@ constraint) to ensure
|
||||
@ -111,7 +114,7 @@ withRootFieldNameCustomization = local . set hasLens
|
||||
-- | Apply the root field name customization function from the current environment.
|
||||
mkRootFieldName :: (MonadReader r m, Has MkRootFieldName r) => G.Name -> m G.Name
|
||||
mkRootFieldName name =
|
||||
($ name) <$> asks getter
|
||||
($ name) . runMkRootFieldName <$> asks getter
|
||||
|
||||
-- | Inject typename and root field name customizations from @SourceCustomization@ into
|
||||
-- the environment.
|
||||
@ -125,7 +128,10 @@ withSourceCustomization SourceCustomization {..} =
|
||||
withTypenameCustomization (mkCustomizedTypename _scTypeNames)
|
||||
. withRootFieldNameCustomization (mkCustomizedFieldName _scRootFields)
|
||||
|
||||
type CustomizeRemoteFieldName = G.Name -> G.Name -> G.Name
|
||||
newtype CustomizeRemoteFieldName = CustomizeRemoteFieldName
|
||||
{ runCustomizeRemoteFieldName :: G.Name -> G.Name -> G.Name
|
||||
}
|
||||
deriving (Semigroup, Monoid) via (G.Name -> Endo G.Name)
|
||||
|
||||
withRemoteFieldNameCustomization :: forall m r a. (MonadReader r m, Has CustomizeRemoteFieldName r) => CustomizeRemoteFieldName -> m a -> m a
|
||||
withRemoteFieldNameCustomization = local . set hasLens
|
||||
|
||||
Loading…
Reference in New Issue
Block a user