hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-17 20:41:49 +03:00
Code Issues Projects Releases Wiki Activity
92026b769f
graphql-engine/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs

603 lines
22 KiB
Haskell
Raw Blame History

module Hasura.GraphQL.Schema.Introspect where
import Hasura.Prelude
-- import qualified Hasura.RQL.Types
import qualified Data.Aeson as J
import qualified Data.HashMap.Strict as Map
import qualified Data.HashMap.Strict.InsOrd as OMap
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Language.GraphQL.Draft.Printer as GP
import qualified Language.GraphQL.Draft.Syntax as G
import qualified Text.Builder as T
import qualified Hasura.GraphQL.Parser as P
import Hasura.GraphQL.Parser (FieldParser, Kind (..), Parser, Schema (..))
import Hasura.GraphQL.Parser.Class
{-
Note [Basics of introspection schema generation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We generate the introspection schema from the existing schema for queries,
mutations and subscriptions. In other words, we generate one @Parser@ from some
other @Parser@s. In this way, we avoid having to remember what types we have to
expose through introspection explicitly, as we did in a previous version of
graphql-engine.
However the schema information is obtained, the @Schema@ type stores it. From a
@Schema@ object we then produce one @FieldParser@ that reads a `__schema` field,
and one that reads a `__type` field. The idea is that these parsers simply
output a JSON value directly, and so indeed the type of @schema@, for instance,
is @FieldParser n J.Value@.
The idea of "just output the JSON object directly" breaks down when we want to
output a list of things, however, such as in the `types` field of `__schema`.
In the case of `types`, the JSON object to be generated is influenced by the
underlying selection set, so that, for instance,
```
query {
__schema {
types {
name
}
}
}
```
means that we only output the _name_ of every type in our schema. One naive
approach one might consider here would be to have a parser
```
typeField :: P.Type k -> Parser n J.Value
```
that takes a type, and is able to produce a JSON value for it, and then to apply
this parser to all the types in our schema.
However, we only have *one* selection set to parse: so which of the parsers we
obtained should we use to parse it? And what should we do in the theoretical
case that we have a schema without any types? (The latter is actually not
possible since we always have `query_root`, but it illustrates the problem that
there is no canonical choice of type to use to parse the selection set.)
Additionally, this would allow us to get the JSON output for *one* type, rather
than for our list of types. After all, @Parser n@ is *not* a @Monad@ (it's not
even an @Applicative@), so we don't have a map @(a -> Parser n b) -> [a] -> m
[b]@.
In order to resolve this conundrum, let's consider what the ordinary Postgres
schema generates for a query such as follows.
```
query {
author {
articles {
title
}
}
}
```
Now the @Parser@ for an article's title does not directly give the desired
output data: indeed, there would be many different titles, rather than any
single one we can return. Instead, it returns a value that can, after parsing,
be used to build an output, along the lines of:
```
articleTitle :: FieldParser n SQLArticleTitle
```
(This is a heavily simplified representation of reality.)
These values can be thought of as an intermediate representation that can then
be used to generate and run SQL that gives the desired JSON output at a later
stage. In other words, in the above example, @SQLArticleTitle@ can be thought
of as a function @Article -> Title@ that, given an article, gives back its
title.
Such an approach could help us as well, as, from instructions on how to generate
a JSON return for a given `__Type`, surely we can later simply apply this
construction to all types desired.
However, we don't _need_ to build an intermediate AST to do this: we can simply
output the conversion functions directly. So the type of @typeField@ is closer
to:
```
typeField :: Parser n (P.Type k -> J.Value)
```
This says that we are always able to parse a selection set for a `__Type`, and
once we do, we obtain a map, which we refer to as `printer` in this module,
which can output a JSON object for a given GraphQL type from our schema.
To use `typeField` as part of another selection set, we build up a corresponding
`FieldParser`, thus obtaining a printer, then apply this printer to all desired
types, and output the final JSON object as a J.Array of the printed results,
like so (again, heavily simplified):
```
types :: FieldParser n J.Value
types = do
printer <- P.subselection_ $$(G.litName "types") Nothing typeField
return $ J.Array $ map printer $ allSchemaTypes
```
Upon reading this you may be bewildered how we are able to use do notation for
@FieldParser@, which does not have a @Monad@ instance, or even an @Applicative@
instance. It just so happens that, as long as we write our do blocks carefully,
so that we only use the functoriality of @FieldParser@, the simplification rules
of GHC kick in just in time to avoid any application of @(>>=)@ or @return@.
Arguably the above notation is prettier than equivalent code that explicitly
reduces this to applications of @fmap@. If you, dear reader, feel like the do
notation adds more confusion than value, you should feel free to change this, as
there is no deeper meaning to the application of do notation than ease of
reading.
-}
-- | Generate a __type introspection parser
typeIntrospection
:: forall n
. MonadParse n
=> Schema
-> FieldParser n J.Value
typeIntrospection fakeSchema = do
let nameArg :: P.InputFieldsParser n G.Name
nameArg = G.unsafeMkName <$> P.field $$(G.litName "name") Nothing P.string
name'printer <- P.subselection $$(G.litName "__type") Nothing nameArg typeField
return $ case Map.lookup (fst name'printer) (sTypes fakeSchema) of
Nothing -> J.Null
Just (P.Definition n u d (P.SomeTypeInfo i)) ->
snd name'printer (SomeType (P.Nullable (P.TNamed (P.Definition n u d i))))
-- | Generate a __schema introspection parser.
schema
:: forall n
. MonadParse n
=> Schema
-> FieldParser n J.Value
schema fakeSchema =
let schemaSetParser = schemaSet fakeSchema
in P.subselection_ $$(G.litName "__schema") Nothing schemaSetParser
{-
type __Type {
kind: __TypeKind!
name: String
description: String
# should be non-null for OBJECT and INTERFACE only, must be null for the others
fields(includeDeprecated: Boolean = false): [__Field!]
# should be non-null for OBJECT and INTERFACE only, must be null for the others
interfaces: [__Type!]
# should be non-null for INTERFACE and UNION only, always null for the others
possibleTypes: [__Type!]
# should be non-null for ENUM only, must be null for the others
enumValues(includeDeprecated: Boolean = false): [__EnumValue!]
# should be non-null for INPUT_OBJECT only, must be null for the others
inputFields: [__InputValue!]
# should be non-null for NON_NULL and LIST only, must be null for the others
ofType: __Type
}
-}
data SomeType = forall k . SomeType (P.Type k)
typeField
:: forall n
. MonadParse n
=> Parser 'Output n (SomeType -> J.Value)
typeField =
let
includeDeprecated :: P.InputFieldsParser n Bool
includeDeprecated =
P.fieldWithDefault $$(G.litName "includeDeprecated") Nothing (G.VBoolean False) (P.nullable P.boolean)
<&> fromMaybe False
kind :: FieldParser n (SomeType -> J.Value)
kind = P.selection_ $$(G.litName "kind") Nothing typeKind $>
\case SomeType tp ->
case tp of
P.NonNullable _ ->
J.String "NON_NULL"
P.Nullable (P.TList _) ->
J.String "LIST"
P.Nullable (P.TNamed (P.Definition _ _ _ P.TIScalar)) ->
J.String "SCALAR"
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIEnum _))) ->
J.String "ENUM"
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIInputObject _))) ->
J.String "INPUT_OBJECT"
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIObject _))) ->
J.String "OBJECT"
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIInterface _))) ->
J.String "INTERFACE"
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIUnion _))) ->
J.String "UNION"
name :: FieldParser n (SomeType -> J.Value)
name = P.selection_ $$(G.litName "name") Nothing P.string $>
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition name' _ _ _)) ->
nameAsJSON name'
_ -> J.Null
description :: FieldParser n (SomeType -> J.Value)
description = P.selection_ $$(G.litName "description") Nothing P.string $>
\case SomeType tp ->
case P.discardNullability tp of
P.TNamed (P.Definition _ _ (Just desc) _) ->
J.String (G.unDescription desc)
_ -> J.Null
fields :: FieldParser n (SomeType -> J.Value)
fields = do
-- TODO handle the value of includeDeprecated
includeDeprecated'printer <- P.subselection $$(G.litName "fields") Nothing includeDeprecated fieldField
return $
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIObject (P.ObjectInfo fields' _interfaces')))) ->
J.Array $ V.fromList $ snd includeDeprecated'printer <$> sortOn P.dName fields'
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIInterface (P.InterfaceInfo fields' _objects')))) ->
J.Array $ V.fromList $ snd includeDeprecated'printer <$> sortOn P.dName fields'
_ -> J.Null
interfaces :: FieldParser n (SomeType -> J.Value)
interfaces = do
printer <- P.subselection_ $$(G.litName "interfaces") Nothing typeField
return $
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIObject (P.ObjectInfo _fields' interfaces')))) ->
J.Array $ V.fromList $ printer . SomeType . P.Nullable . P.TNamed . fmap P.TIInterface <$> sortOn P.dName interfaces'
_ -> J.Null
possibleTypes :: FieldParser n (SomeType -> J.Value)
possibleTypes = do
printer <- P.subselection_ $$(G.litName "possibleTypes") Nothing typeField
return $
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIInterface (P.InterfaceInfo _fields' objects')))) ->
J.Array $ V.fromList $ printer . SomeType . P.Nullable . P.TNamed . fmap P.TIObject <$> sortOn P.dName objects'
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIUnion (P.UnionInfo objects')))) ->
J.Array $ V.fromList $ printer . SomeType . P.Nullable . P.TNamed . fmap P.TIObject <$> sortOn P.dName objects'
_ -> J.Null
enumValues :: FieldParser n (SomeType -> J.Value)
enumValues = do
-- TODO handle the value of includeDeprecated
includeDeprecated'printer <- P.subselection $$(G.litName "enumValues") Nothing includeDeprecated enumValue
return $
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIEnum vals))) ->
J.Array $ V.fromList $ fmap (snd includeDeprecated'printer) $ sortOn P.dName $ toList vals
_ -> J.Null
inputFields :: FieldParser n (SomeType -> J.Value)
inputFields = do
printer <- P.subselection_ $$(G.litName "inputFields") Nothing inputValue
return $
\case SomeType tp ->
case tp of
P.Nullable (P.TNamed (P.Definition _ _ _ (P.TIInputObject (P.InputObjectInfo fieldDefs)))) ->
J.Array $ V.fromList $ map printer $ sortOn P.dName fieldDefs
_ -> J.Null
ofType :: FieldParser n (SomeType -> J.Value)
ofType = do
printer <- P.subselection_ $$(G.litName "ofType") Nothing typeField
return $ \case
SomeType (P.NonNullable x) ->
printer $ SomeType $ P.Nullable x
SomeType (P.Nullable (P.TList x)) ->
printer $ SomeType x
_ -> J.Null
in
applyPrinter <$>
P.selectionSet
$$(G.litName "__Type")
Nothing
[ kind
, name
, description
, fields
, interfaces
, possibleTypes
, enumValues
, inputFields
, ofType
]
{-
type __InputValue {
name: String!
description: String
type: __Type!
defaultValue: String
}
-}
inputValue
:: forall n
. MonadParse n
=> Parser 'Output n (P.Definition P.InputFieldInfo -> J.Value)
inputValue =
let
name :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
name = P.selection_ $$(G.litName "name") Nothing P.string $>
nameAsJSON . P.dName
description :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
description = P.selection_ $$(G.litName "description") Nothing P.string $>
maybe J.Null (J.String . G.unDescription) . P.dDescription
typeF :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
typeF = do
printer <- P.subselection_ $$(G.litName "type") Nothing typeField
return $ \defInfo -> case P.dInfo defInfo of
P.IFRequired tp -> printer $ SomeType $ P.NonNullable tp
P.IFOptional tp _ -> printer $ SomeType tp
defaultValue :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
defaultValue = P.selection_ $$(G.litName "defaultValue") Nothing P.string $>
\defInfo -> case P.dInfo defInfo of
P.IFOptional _ (Just val) -> J.String $ T.run $ GP.value val
_ -> J.Null
in
applyPrinter <$>
P.selectionSet
$$(G.litName "__InputValue")
Nothing
[ name
, description
, typeF
, defaultValue
]
{-
type __EnumValue {
name: String!
description: String
isDeprecated: Boolean!
deprecationReason: String
}
-}
enumValue
:: forall n
. MonadParse n
=> Parser 'Output n (P.Definition P.EnumValueInfo -> J.Value)
enumValue =
let
name :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
name = P.selection_ $$(G.litName "name") Nothing P.string $>
nameAsJSON . P.dName
description :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
description = P.selection_ $$(G.litName "description") Nothing P.string $>
maybe J.Null (J.String . G.unDescription) . P.dDescription
-- TODO We don't seem to support enum value deprecation
isDeprecated :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
isDeprecated = P.selection_ $$(G.litName "isDeprecated") Nothing P.string $>
const (J.Bool False)
deprecationReason :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
deprecationReason = P.selection_ $$(G.litName "deprecationReason") Nothing P.string $>
const J.Null
in
applyPrinter <$>
P.selectionSet
$$(G.litName "__EnumValue")
Nothing
[ name
, description
, isDeprecated
, deprecationReason
]
{-
enum __TypeKind {
ENUM
INPUT_OBJECT
INTERFACE
LIST
NON_NULL
OBJECT
SCALAR
UNION
}
-}
typeKind
:: forall n
. MonadParse n
=> Parser 'Both n ()
typeKind = P.enum
$$(G.litName "__TypeKind")
Nothing
(NE.fromList
[ mkDefinition $$(G.litName "ENUM")
, mkDefinition $$(G.litName "INPUT_OBJECT")
, mkDefinition $$(G.litName "INTERFACE")
, mkDefinition $$(G.litName "LIST")
, mkDefinition $$(G.litName "NON_NULL")
, mkDefinition $$(G.litName "OBJECT")
, mkDefinition $$(G.litName "SCALAR")
, mkDefinition $$(G.litName "UNION")
])
where
mkDefinition name = (P.Definition name Nothing Nothing P.EnumValueInfo, ())
{-
type __Field {
name: String!
description: String
args: [__InputValue!]!
type: __Type!
isDeprecated: Boolean!
deprecationReason: String
}
-}
fieldField
:: forall n
. MonadParse n
=> Parser 'Output n (P.Definition P.FieldInfo -> J.Value)
fieldField =
let
name :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
name = P.selection_ $$(G.litName "name") Nothing P.string $>
nameAsJSON . P.dName
description :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
description = P.selection_ $$(G.litName "description") Nothing P.string $> \defInfo ->
case P.dDescription defInfo of
Nothing -> J.Null
Just desc -> J.String (G.unDescription desc)
args :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
args = do
printer <- P.subselection_ $$(G.litName "args") Nothing inputValue
return $ J.Array . V.fromList . map printer . sortOn P.dName . P.fArguments . P.dInfo
typeF :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
typeF = do
printer <- P.subselection_ $$(G.litName "type") Nothing typeField
return $ printer . (\case P.FieldInfo _ tp -> SomeType tp) . P.dInfo
-- TODO We don't seem to track deprecation info
isDeprecated :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
isDeprecated = P.selection_ $$(G.litName "isDeprecated") Nothing P.string $>
const (J.Bool False)
deprecationReason :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
deprecationReason = P.selection_ $$(G.litName "deprecationReason") Nothing P.string $>
const J.Null
in
applyPrinter <$>
P.selectionSet $$(G.litName "__Field") Nothing
[ name
, description
, args
, typeF
, isDeprecated
, deprecationReason
]
{-
type __Directive {
name: String!
description: String
locations: [__DirectiveLocation!]!
args: [__InputValue!]!
isRepeatable: Boolean!
}
-}
directiveSet
:: forall n
. MonadParse n
=> Parser 'Output n (P.DirectiveInfo -> J.Value)
directiveSet =
let
name :: FieldParser n (P.DirectiveInfo -> J.Value)
name = P.selection_ $$(G.litName "name") Nothing P.string $>
(J.toJSON . P.diName)
description :: FieldParser n (P.DirectiveInfo -> J.Value)
description = P.selection_ $$(G.litName "description") Nothing P.string $>
(J.toJSON . P.diDescription)
locations :: FieldParser n (P.DirectiveInfo -> J.Value)
locations = P.selection_ $$(G.litName "locations") Nothing P.string $>
(J.toJSON . map showDirLoc . P.diLocations)
args :: FieldParser n (P.DirectiveInfo -> J.Value)
args = do
printer <- P.subselection_ $$(G.litName "args") Nothing inputValue
pure $ J.toJSON . map printer . P.diArguments
isRepeatable :: FieldParser n (P.DirectiveInfo -> J.Value)
isRepeatable = P.selection_ $$(G.litName "isRepeatable") Nothing P.string $>
const J.Null
in
applyPrinter <$> P.selectionSet $$(G.litName "__Directive") Nothing
[ name
, description
, locations
, args
, isRepeatable
]
where
showDirLoc :: G.DirectiveLocation -> Text
showDirLoc = \case
G.DLExecutable edl -> T.pack $ drop 3 $ show edl
G.DLTypeSystem tsdl -> T.pack $ drop 4 $ show tsdl
{-
type __Schema {
description: String
types: [__Type!]!
queryType: __Type!
mutationType: __Type
subscriptionType: __Type
directives: [__Directive!]!
}
-}
schemaSet
:: forall n
. MonadParse n
=> Schema
-> Parser 'Output n J.Value
schemaSet fakeSchema =
let
description :: FieldParser n J.Value
description = P.selection_ $$(G.litName "description") Nothing P.string $>
case sDescription fakeSchema of
Nothing -> J.Null
Just s -> J.String $ G.unDescription s
types :: FieldParser n J.Value
types = do
printer <- P.subselection_ $$(G.litName "types") Nothing typeField
return $ J.Array $ V.fromList $ map (printer . schemaTypeToSomeType) $
sortOn P.dName $ Map.elems $ sTypes fakeSchema
where
schemaTypeToSomeType
:: P.Definition P.SomeTypeInfo
-> SomeType
schemaTypeToSomeType (P.Definition n u d (P.SomeTypeInfo i)) =
SomeType $ P.Nullable $ P.TNamed (P.Definition n u d i)
queryType :: FieldParser n J.Value
queryType = do
printer <- P.subselection_ $$(G.litName "queryType") Nothing typeField
return $ printer $ SomeType $ sQueryType fakeSchema
mutationType :: FieldParser n J.Value
mutationType = do
printer <- P.subselection_ $$(G.litName "mutationType") Nothing typeField
return $ case sMutationType fakeSchema of
Nothing -> J.Null
Just tp -> printer $ SomeType tp
subscriptionType :: FieldParser n J.Value
subscriptionType = do
printer <- P.subselection_ $$(G.litName "subscriptionType") Nothing typeField
return $ case sSubscriptionType fakeSchema of
Nothing -> J.Null
Just tp -> printer $ SomeType tp
directives :: FieldParser n J.Value
directives = do
printer <- P.subselection_ $$(G.litName "directives") Nothing directiveSet
return $ J.toJSON $ map printer $ sDirectives fakeSchema
in
selectionSetToJSON . fmap (P.handleTypename nameAsJSON) <$>
P.selectionSet
$$(G.litName "__Schema")
Nothing
[ description
, types
, queryType
, mutationType
, subscriptionType
, directives
]
selectionSetToJSON
:: OMap.InsOrdHashMap G.Name J.Value
-> J.Value
selectionSetToJSON = J.Object . OMap.toHashMap . OMap.mapKeys G.unName
applyPrinter
:: OMap.InsOrdHashMap G.Name (P.ParsedSelection (a -> J.Value))
-> a
-> J.Value
applyPrinter = flip (\x -> selectionSetToJSON . fmap (($ x) . P.handleTypename (const . nameAsJSON)))
nameAsJSON :: G.Name -> J.Value
nameAsJSON = J.String . G.unName
Reference in New Issue View Git Blame Copy Permalink