From ccf518c9eb33438a871295c616dd9352c59c9fab Mon Sep 17 00:00:00 2001
From: prescientmoon <git@moonythm.dev>
Date: Tue, 8 Oct 2024 05:40:53 +0200
Subject: [PATCH] Make introspection work with new graphiql verison
---
source/AirGQL/Introspection.hs | 8 +-
source/AirGQL/Introspection/Resolver.hs | 238 ++++++++++++------------
source/AirGQL/Introspection/Types.hs | 183 +++++++++---------
3 files changed, 216 insertions(+), 213 deletions(-)
diff --git a/source/AirGQL/Introspection.hs b/source/AirGQL/Introspection.hs
index 280a275..5def2ba 100644
--- a/source/AirGQL/Introspection.hs
+++ b/source/AirGQL/Introspection.hs
@@ -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"
diff --git a/source/AirGQL/Introspection/Resolver.hs b/source/AirGQL/Introspection/Resolver.hs
index f030c65..ff90ac5 100644
--- a/source/AirGQL/Introspection/Resolver.hs
+++ b/source/AirGQL/Introspection/Resolver.hs
@@ -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
diff --git a/source/AirGQL/Introspection/Types.hs b/source/AirGQL/Introspection/Types.hs
index ed8ecc4..d011505 100644
--- a/source/AirGQL/Introspection/Types.hs
+++ b/source/AirGQL/Introspection/Types.hs
@@ -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_