1
Fork 0
mirror of https://github.com/Airsequel/AirGQL.git synced 2025-07-27 21:51:11 +03:00

Make introspection work with new graphiql verison

This commit is contained in:
prescientmoon 2024-10-08 05:40:53 +02:00
parent 41a459fe09
commit ccf518c9eb
3 changed files with 216 additions and 213 deletions
source/AirGQL

View file

@ -12,7 +12,6 @@ import Protolude (
Monoid (mempty),
Semigroup ((<>)),
Text,
fromMaybe,
($),
(&),
(<&>),
@ -58,7 +57,10 @@ typeNameResolver =
columnTypeName :: ColumnEntry -> Text
columnTypeName entry = fromMaybe "String" (columnType entry).name
columnTypeName entry =
case entry.datatype_gql of
Nothing -> "String"
Just type_ -> type_.full
columnType :: ColumnEntry -> IntrospectionType
@ -284,7 +286,7 @@ tableUpdateField accessMode table = do
& Type.withArguments
[ Type.inputValue
"set"
(Type.nonNull $ Type.nonNull updateRow)
(Type.nonNull updateRow)
& Type.inputValueWithDescription "Fields to be updated"
, Type.inputValue
"filter"

View file

@ -1,4 +1,4 @@
module AirGQL.Introspection.Resolver (makeType, makeConstField, makeChildField) where
module AirGQL.Introspection.Resolver (makeType, makeConstField) where
import Protolude (
Either (Left),
@ -8,8 +8,8 @@ import Protolude (
Text,
fromMaybe,
mempty,
note,
pure,
show,
($),
(+),
(<$>),
@ -29,150 +29,144 @@ import Language.GraphQL.Type.Out qualified as Out
type Result = Either Text
maxDepth :: Int
maxDepth = 9
makeType :: IType.IntrospectionType -> Result (Out.Type IO)
makeType = makeTypeWithDepth 0
makeType =
let
-- This is the same as `makeTypeWithDepth`, except the outputs
-- for `__Type` are memoized.
--
-- This turns the memory usage from O(C^n) to O(n), where n is the depth.
-- This greatly speeds up introspection from the playground, which requires
-- a depth of around 10 (from what I can recall).
makeTypeWithDepthMemo :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
makeTypeWithDepthMemo depth ty = case ty.kind of
IType.Object "__Type" _ ->
P.join $ P.note "(impossible)" $ P.atMay typeCache depth
_ -> makeTypeWithDepth depth ty
-- The memoization is done using a haskell lazy array.
typeCache = [makeTypeWithDepth i IType.typeIntrospectionType | i <- [0 ..]]
makeTypeWithDepth :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
makeTypeWithDepth depth ty = do
case ty.kind of
IType.Scalar -> do
name <- note "No `name` found for scalar" ty.name
pure $ Out.NamedScalarType $ Type.ScalarType name ty.description
IType.List -> do
ofType <- note "No `ofType` found for list" ty.ofType
Out.ListType <$> makeTypeWithDepth depth ofType
IType.Enum -> do
name <- note "No `name` found for enum" ty.name
enumValues <- note "No `enumValues` found for enum" ty.enumValues
let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
pure $
Out.NamedEnumType $
Type.EnumType name ty.description $
HashMap.fromList variants
IType.NonNull -> do
ofType <- note "No `ofType` found for nonnull" ty.ofType
inner <- makeTypeWithDepth depth ofType
pure $ case inner of
Out.EnumBaseType enumType -> Out.NonNullEnumType enumType
Out.UnionBaseType unionType -> Out.NonNullUnionType unionType
Out.ScalarBaseType scalarType -> Out.NonNullScalarType scalarType
Out.ObjectBaseType objectType -> Out.NonNullObjectType objectType
Out.ListBaseType listType -> Out.NonNullListType listType
Out.InterfaceBaseType interfaceType -> Out.NonNullInterfaceType interfaceType
IType.InputObject -> do
Left "input object in out position"
IType.Object -> do
name <- note "No `name` found for object" ty.name
fields <- note "No `fields` found for object" ty.fields
resolvers <-
if depth >= maxDepth
then pure []
else P.for fields $ \field -> do
resolver <- makeChildFieldWithDepth (depth + 1) field
makeTypeWithDepth :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
makeTypeWithDepth depth ty =
case ty.kind of
IType.Scalar name -> do
pure $ Out.NamedScalarType $ Type.ScalarType name ty.description
IType.List ofType -> do
Out.ListType <$> makeTypeWithDepthMemo depth ofType
IType.Enum name enumValues -> do
let variants =
enumValues
<&> \variant -> (variant.name, Type.EnumValue variant.description)
pure $
Out.NamedEnumType $
Type.EnumType name ty.description $
HashMap.fromList variants
IType.NonNull ofType -> do
inner <- makeTypeWithDepthMemo depth ofType
pure $ case inner of
Out.EnumBaseType enumType -> Out.NonNullEnumType enumType
Out.UnionBaseType unionType -> Out.NonNullUnionType unionType
Out.ScalarBaseType scalarType -> Out.NonNullScalarType scalarType
Out.ObjectBaseType objectType -> Out.NonNullObjectType objectType
Out.ListBaseType listType -> Out.NonNullListType listType
Out.InterfaceBaseType interfaceType -> Out.NonNullInterfaceType interfaceType
IType.Object name fields -> do
resolvers <- P.for fields $ \field -> do
resolver <-
if depth >= 30
then
makeConstField
(IType.field field.name IType.typeString)
(Type.String "Maximum depth exceeded")
else makeChildField (depth + 1) field
pure (field.name, resolver)
typenameResolver <-
makeConstFieldWithDepth
depth
(IType.field "__typename" $ IType.nonNull IType.typeString)
(Type.String name)
typenameResolver <-
makeConstField
(IType.field "__typename" $ IType.nonNull IType.typeString)
(Type.String name)
pure
$ Out.NamedObjectType
$ Type.ObjectType
name
ty.description
[]
$ HashMap.fromList
$ ("__typename", typenameResolver) : resolvers
pure
$ Out.NamedObjectType
$ Type.ObjectType
name
-- ty.description
P.Nothing
[]
$ HashMap.fromList
$ ("__typename", typenameResolver) : resolvers
_ -> do
Left $ "invalid type in out position: " <> show ty.kind
-- Creates a field which looks up it's value in the object returned by the
-- parent resolver.
makeChildField :: Int -> IType.Field -> Result (Out.Resolver IO)
makeChildField depth field = do
args <- P.for field.args $ \arg -> do
ty <- makeInType arg.type_
pure (arg.name, In.Argument arg.description ty arg.defaultValue)
ty <- makeTypeWithDepthMemo depth field.type_
let gqlField = Out.Field field.description ty $ HashMap.fromList args
pure $ Out.ValueResolver gqlField $ do
context <- ask
let defaultValue =
if Out.isNonNullType ty
then
Type.String $
"Error: field '"
<> field.name
<> "' not found "
else Type.Null
case context.values of
Type.Object obj ->
pure $
fromMaybe defaultValue $
HashMap.lookup field.name obj
_ -> pure defaultValue
in
makeTypeWithDepth 0
makeConstField :: IType.Field -> Type.Value -> Result (Out.Resolver IO)
makeConstField = makeConstFieldWithDepth 0
makeConstFieldWithDepth :: Int -> IType.Field -> Type.Value -> Result (Out.Resolver IO)
makeConstFieldWithDepth depth field value = do
ty <- makeTypeWithDepth depth field.type_
makeConstField field value = do
ty <- makeType field.type_
let gqlField = Out.Field field.description ty mempty
pure $ Out.ValueResolver gqlField $ pure value
makeChildField :: IType.Field -> Result (Out.Resolver IO)
makeChildField = makeChildFieldWithDepth 0
makeChildFieldWithDepth :: Int -> IType.Field -> Result (Out.Resolver IO)
makeChildFieldWithDepth depth field = do
args <- P.for field.args $ \arg -> do
ty <- makeInTypeWithDepth depth arg.type_
pure (arg.name, In.Argument arg.description ty arg.defaultValue)
ty <- makeTypeWithDepth depth field.type_
let gqlField = Out.Field field.description ty $ HashMap.fromList args
pure $ Out.ValueResolver gqlField $ do
context <- ask
let defaultValue =
if Out.isNonNullType ty
then
Type.String $
"Error: field '"
<> field.name
<> "' not found "
else Type.Null
case context.values of
Type.Object obj ->
pure $
fromMaybe defaultValue $
HashMap.lookup field.name obj
_ -> pure defaultValue
makeInTypeWithDepth :: Int -> IType.IntrospectionType -> Result In.Type
makeInTypeWithDepth depth ty = do
makeInType :: IType.IntrospectionType -> Result In.Type
makeInType ty = do
case ty.kind of
IType.Scalar -> do
name <- note "No `name` found for scalar" ty.name
IType.Scalar name -> do
pure $ In.NamedScalarType $ Type.ScalarType name ty.description
IType.List -> do
ofType <- note "No `ofType` found for list" ty.ofType
In.ListType <$> makeInTypeWithDepth depth ofType
IType.Enum -> do
name <- note "No `name` found for enum" ty.name
enumValues <- note "No `enumValues` found for enum" ty.enumValues
IType.List ofType -> do
In.ListType <$> makeInType ofType
IType.Enum name enumValues -> do
let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
pure $
In.NamedEnumType $
Type.EnumType name ty.description $
HashMap.fromList variants
IType.NonNull -> do
ofType <- note "No `ofType` found for nonnull" ty.ofType
inner <- makeInTypeWithDepth depth ofType
IType.NonNull ofType -> do
inner <- makeInType ofType
pure $ case inner of
In.EnumBaseType enumType -> In.NonNullEnumType enumType
In.ScalarBaseType scalarType -> In.NonNullScalarType scalarType
In.InputObjectBaseType objectType -> In.NonNullInputObjectType objectType
In.ListBaseType listType -> In.NonNullListType listType
IType.Object -> do
Left "out object in input position"
IType.InputObject -> do
name <- note "No `name` found for object" ty.name
fields <- note "No `inputFields` found for object" ty.inputFields
gqlFields <-
if depth >= maxDepth
then pure []
else P.for fields $ \field -> do
inner <- makeInTypeWithDepth (depth + 1) field.type_
let inputField =
In.InputField
field.description
inner
field.defaultValue
pure (field.name, inputField)
IType.InputObject name fields -> do
gqlFields <- P.for fields $ \field -> do
inner <- makeInType field.type_
let inputField =
In.InputField
field.description
inner
field.defaultValue
pure (field.name, inputField)
pure
$ In.NamedInputObjectType
@ -180,3 +174,5 @@ makeInTypeWithDepth depth ty = do
name
ty.description
$ HashMap.fromList gqlFields
_ -> do
Left $ "invalid type in input position: " <> show ty.kind

View file

@ -1,5 +1,6 @@
module AirGQL.Introspection.Types (
Schema (..),
Name,
IntrospectionType (..),
TypeKind (..),
Field (..),
@ -11,7 +12,6 @@ module AirGQL.Introspection.Types (
withArguments,
inputValue,
inputValueWithDescription,
withName,
withDescription,
fieldWithDescription,
scalar,
@ -46,6 +46,7 @@ import Protolude (
execState,
for_,
not,
pure,
show,
when,
($),
@ -126,47 +127,83 @@ typeDirectiveLocation =
]
data TypeKind = Scalar | Object | Enum | InputObject | List | NonNull
-- | The name of a graphql type.
type Name = Text
data TypeKind
= Scalar Name
| Object Name [Field]
| Enum Name [EnumValue]
| InputObject Name [InputValue]
| List IntrospectionType
| NonNull IntrospectionType
deriving (Show, Generic)
-- $(deriveToGraphQL ''TypeKind)
instance ToGraphQL TypeKind where
toGraphQL Scalar = Value.Enum "SCALAR"
toGraphQL Object = Value.Enum "OBJECT"
toGraphQL Enum = Value.Enum "ENUM"
toGraphQL InputObject = Value.Enum "INPUT_OBJECT"
toGraphQL List = Value.Enum "LIST"
toGraphQL NonNull = Value.Enum "NON_NULL"
data IntrospectionType = IType
{ kind :: TypeKind
, name :: Maybe Text
, description :: Maybe Text
, interfaces :: Maybe [IntrospectionType]
, possibleTypes :: Maybe [IntrospectionType]
, fields :: Maybe [Field]
, inputFields :: Maybe [InputValue]
, enumValues :: Maybe [EnumValue]
, ofType :: Maybe IntrospectionType
}
deriving (Show, Generic)
instance ToGraphQL IntrospectionType where
toGraphQL ty =
toGraphQL ty = do
Value.Object $
HashMap.fromList
[ ("kind", toGraphQL ty.kind)
, ("name", toGraphQL ty.name)
[
( "kind"
, case ty.kind of
Scalar _ -> Value.Enum "SCALAR"
Object _ _ -> Value.Enum "OBJECT"
Enum _ _ -> Value.Enum "ENUM"
InputObject _ _ -> Value.Enum "INPUT_OBJECT"
List _ -> Value.Enum "LIST"
NonNull _ -> Value.Enum "NON_NULL"
)
,
( "name"
, case ty.kind of
Scalar name -> Value.String name
Object name _ -> Value.String name
Enum name _ -> Value.String name
InputObject name _ -> Value.String name
_ -> Value.Null
)
, ("description", toGraphQL ty.description)
, ("interfaces", toGraphQL ty.interfaces)
, ("possibleTypes", toGraphQL ty.possibleTypes)
, ("fields", toGraphQL ty.fields)
, ("enumValues", toGraphQL ty.enumValues)
, ("inputFields", toGraphQL ty.inputFields)
, ("ofType", toGraphQL ty.ofType)
,
( "interfaces"
, case ty.kind of
Object _ _ -> Value.List []
_ -> Value.Null
)
, ("possibleTypes", Value.Null)
,
( "fields"
, case ty.kind of
Object _ fields -> toGraphQL fields
_ -> Value.Null
)
,
( "enumValues"
, case ty.kind of
Enum _ variants -> toGraphQL variants
_ -> Value.Null
)
,
( "inputFields"
, case ty.kind of
InputObject _ fields -> toGraphQL fields
_ -> Value.Null
)
,
( "ofType"
, case ty.kind of
NonNull inner -> toGraphQL inner
List inner -> toGraphQL inner
_ -> Value.Null
)
]
@ -199,67 +236,32 @@ typeIntrospectionType =
]
emptyType :: TypeKind -> IntrospectionType
emptyType kind =
mkType :: TypeKind -> IntrospectionType
mkType kind =
IType
{ kind
, name = Nothing
, description = Nothing
, interfaces = Nothing
, possibleTypes = Nothing
, fields = Nothing
, enumValues = Nothing
, inputFields = Nothing
, ofType = Nothing
}
nonNull :: IntrospectionType -> IntrospectionType
nonNull ty =
(emptyType NonNull)
{ ofType = Just ty
}
nonNull ty = mkType $ NonNull ty
list :: IntrospectionType -> IntrospectionType
list ty =
(emptyType List)
{ ofType = Just ty
}
list ty = mkType $ List ty
object :: Text -> [Field] -> IntrospectionType
object name fields =
(emptyType Object)
{ fields = Just fields
, name = Just name
, interfaces = Just []
}
object name fields = mkType $ Object name fields
inputObject :: Text -> [InputValue] -> IntrospectionType
inputObject name fields =
(emptyType InputObject)
{ inputFields = Just fields
, name = Just name
, interfaces = Just []
}
inputObject name fields = mkType $ InputObject name fields
enum :: Text -> [EnumValue] -> IntrospectionType
enum name variants =
(emptyType Enum)
{ enumValues = Just variants
, name = Just name
}
withName :: Text -> IntrospectionType -> IntrospectionType
withName newName (IType{..}) =
IType
{ name = Just newName
, ..
}
enum name variants = mkType $ Enum name variants
withDescription :: Text -> IntrospectionType -> IntrospectionType
@ -271,9 +273,7 @@ withDescription newDesc (IType{..}) =
scalar :: Text -> IntrospectionType
scalar tyName =
emptyType Scalar
& withName tyName
scalar tyName = mkType $ Scalar tyName
data Field = Field
@ -463,19 +463,24 @@ collectSchemaTypes schema = do
-- | Collect a map of all the named types occurring inside a type
collectTypes :: IntrospectionType -> State (HashMap Text IntrospectionType) ()
collectTypes ty = do
for_ ty.ofType collectTypes
for_ ty.name $ \name -> do
current <- get
when (not $ HashMap.member name current) $ do
put $ HashMap.insert name ty current
for_ ty.interfaces $ \interfaces -> do
for_ interfaces collectTypes
for_ ty.possibleTypes $ \possibleTypes -> do
for_ possibleTypes collectTypes
for_ ty.inputFields $ \inputFields -> do
for_ inputFields $ \thisField -> collectTypes thisField.type_
for_ ty.fields $ \fields -> do
for_ fields $ \thisField -> do
collectTypes thisField.type_
for_ thisField.args $ \arg ->
collectTypes arg.type_
-- Gives a name to the current type, and saves it.
--
-- If the type hadn't been found already, runs a custom continuation.
let insertType name continue = do
current <- get
when (not $ HashMap.member name current) $ do
put $ HashMap.insert name ty current
continue
case ty.kind of
NonNull inner -> collectTypes inner
List inner -> collectTypes inner
Enum name _ -> insertType name $ pure ()
Scalar name -> insertType name $ pure ()
Object name fields -> insertType name $ do
for_ fields $ \thisField -> do
collectTypes thisField.type_
for_ thisField.args $ \arg ->
collectTypes arg.type_
InputObject name fields -> insertType name $ do
for_ fields $ \thisField -> collectTypes thisField.type_