graphql-engine/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs

{-# LANGUAGE ApplicativeDo #-}

module Hasura.GraphQL.Schema.Introspect
  ( schema,
    typeIntrospection,
  )
where

-- import qualified Hasura.RQL.Types

import Data.Aeson.Ordered qualified as J
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Vector qualified as V
import Hasura.GraphQL.Parser (FieldParser, Kind (..), Parser, Schema (..))
import Hasura.GraphQL.Parser qualified as P
import Hasura.GraphQL.Parser.Class
import Hasura.Prelude
import Language.GraphQL.Draft.Printer qualified as GP
import Language.GraphQL.Draft.Syntax qualified as G
import Text.Builder qualified as T

{-
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 =>
  FieldParser n (Schema -> J.Value)
{-# INLINE typeIntrospection #-}
typeIntrospection = do
  let nameArg :: P.InputFieldsParser n Text
      nameArg = P.field $$(G.litName "name") Nothing P.string
  ~(nameText, printer) <- P.subselection $$(G.litName "__type") Nothing nameArg typeField
  -- We pass around the GraphQL schema information under the name `fakeSchema`,
  -- because the GraphQL spec forces us to expose a hybrid between the
  -- specification of valid queries (including introspection) and an
  -- introspection-free GraphQL schema.  The introspection fields __type and
  -- __schema are not exposed as part of query_root, but the types of those
  -- fields must be.  Hasura.GraphQL.Schema is responsible for organising this.
  pure $ \fakeSchema -> fromMaybe J.Null $ do
    name <- G.mkName nameText
    P.Definition n d (P.SomeTypeInfo i) <- Map.lookup name $ sTypes fakeSchema
    Just $ printer $ SomeType $ P.TNamed P.Nullable $ P.Definition n d i

-- | Generate a __schema introspection parser.
schema ::
  forall n.
  MonadParse n =>
  FieldParser n (Schema -> J.Value)
{-# INLINE schema #-}
schema = P.subselection_ $$(G.litName "__schema") Nothing schemaSet

{-
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.TList P.NonNullable _ ->
                  J.String "NON_NULL"
                P.TNamed P.NonNullable _ ->
                  J.String "NON_NULL"
                P.TList P.Nullable _ ->
                  J.String "LIST"
                P.TNamed P.Nullable (P.Definition _ _ P.TIScalar) ->
                  J.String "SCALAR"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIEnum _)) ->
                  J.String "ENUM"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInputObject _)) ->
                  J.String "INPUT_OBJECT"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIObject _)) ->
                  J.String "OBJECT"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInterface _)) ->
                  J.String "INTERFACE"
                P.TNamed P.Nullable (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.TNamed P.Nullable (P.Definition name' _ _) ->
                  nameAsJSON name'
                _ -> J.Null
      description :: FieldParser n (SomeType -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> \case
            SomeType (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.TNamed P.Nullable (P.Definition _ _ (P.TIObject (P.ObjectInfo fields' _interfaces'))) ->
                  J.Array $ V.fromList $ printer <$> sortOn P.dName fields'
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInterface (P.InterfaceInfo fields' _objects'))) ->
                  J.Array $ V.fromList $ 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.TNamed P.Nullable (P.Definition _ _ (P.TIObject (P.ObjectInfo _fields' interfaces'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . 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.TNamed P.Nullable (P.Definition _ _ (P.TIInterface (P.InterfaceInfo _fields' objects'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . fmap P.TIObject <$> sortOn P.dName objects'
                P.TNamed P.Nullable (P.Definition _ _ (P.TIUnion (P.UnionInfo objects'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . 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.TNamed P.Nullable (P.Definition _ _ (P.TIEnum vals)) ->
                  J.Array $ V.fromList $ fmap 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.TNamed P.Nullable (P.Definition _ _ (P.TIInputObject (P.InputObjectInfo fieldDefs))) ->
                  J.Array $ V.fromList $ map printer $ sortOn P.dName fieldDefs
                _ -> J.Null
      -- ofType peels modalities off of types
      ofType :: FieldParser n (SomeType -> J.Value)
      ofType = do
        printer <- P.subselection_ $$(G.litName "ofType") Nothing typeField
        return $ \case
          -- kind = "NON_NULL": !a -> a
          SomeType (P.TNamed P.NonNullable x) ->
            printer $ SomeType $ P.TNamed P.Nullable x
          -- kind = "NON_NULL": ![a] -> [a], and ![!a] -> [!a]
          SomeType (P.TList P.NonNullable x) ->
            printer $ SomeType $ P.TList P.Nullable x
          -- kind = "LIST": [a] -> a
          SomeType (P.TList P.Nullable 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.InputFieldInfo 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.InputFieldInfo _ (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 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.toOrdered . P.diName)
      description :: FieldParser n (P.DirectiveInfo -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> (J.toOrdered . P.diDescription)
      locations :: FieldParser n (P.DirectiveInfo -> J.Value)
      locations =
        P.selection_ $$(G.litName "locations") Nothing P.string
          $> (J.toOrdered . map showDirLoc . P.diLocations)
      args :: FieldParser n (P.DirectiveInfo -> J.Value)
      args = do
        printer <- P.subselection_ $$(G.litName "args") Nothing inputValue
        pure $ J.array . 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 =>
  Parser 'Output n (Schema -> J.Value)
{-# INLINE schemaSet #-}
schemaSet =
  let description :: FieldParser n (Schema -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> \fakeSchema -> case sDescription fakeSchema of
            Nothing -> J.Null
            Just s -> J.String $ G.unDescription s
      types :: FieldParser n (Schema -> J.Value)
      types = do
        printer <- P.subselection_ $$(G.litName "types") Nothing typeField
        return $
          \fakeSchema ->
            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 d (P.SomeTypeInfo i)) =
            SomeType $ P.TNamed P.Nullable (P.Definition n d i)
      queryType :: FieldParser n (Schema -> J.Value)
      queryType = do
        printer <- P.subselection_ $$(G.litName "queryType") Nothing typeField
        return $ \fakeSchema -> printer $ SomeType $ sQueryType fakeSchema
      mutationType :: FieldParser n (Schema -> J.Value)
      mutationType = do
        printer <- P.subselection_ $$(G.litName "mutationType") Nothing typeField
        return $ \fakeSchema -> case sMutationType fakeSchema of
          Nothing -> J.Null
          Just tp -> printer $ SomeType tp
      subscriptionType :: FieldParser n (Schema -> J.Value)
      subscriptionType = do
        printer <- P.subselection_ $$(G.litName "subscriptionType") Nothing typeField
        return $ \fakeSchema -> case sSubscriptionType fakeSchema of
          Nothing -> J.Null
          Just tp -> printer $ SomeType tp
      directives :: FieldParser n (Schema -> J.Value)
      directives = do
        printer <- P.subselection_ $$(G.litName "directives") Nothing directiveSet
        return $ \fakeSchema -> J.array $ map printer $ sDirectives fakeSchema
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__Schema")
          Nothing
          [ description,
            types,
            queryType,
            mutationType,
            subscriptionType,
            directives
          ]

selectionSetToJSON ::
  OMap.InsOrdHashMap G.Name J.Value ->
  J.Value
selectionSetToJSON = J.object . map (first G.unName) . OMap.toList

applyPrinter ::
  OMap.InsOrdHashMap G.Name (P.ParsedSelection (a -> J.Value)) ->
  a ->
  J.Value
applyPrinter = flip (\x -> selectionSetToJSON . fmap (($ x) . P.handleTypename (const . nameAsJSON)))

nameAsJSON :: P.HasName a => a -> J.Value
nameAsJSON = J.String . G.unName . P.getName