airgql/source/AirGQL/Introspection/Resolver.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Replace case with maybe" #-}
module AirGQL.Introspection.Resolver (
  makeType,
  makeConstField,
  makeField,
) where

import Protolude (
  Either (Left),
  IO,
  Int,
  Maybe (Just, Nothing),
  MonadReader (ask),
  Text,
  pure,
  show,
  ($),
  (+),
  (<$>),
  (<&>),
  (<>),
  (>=),
 )
import Protolude qualified as P

import AirGQL.Introspection.Types qualified as IType
import Control.Exception qualified as Exception
import Data.HashMap.Strict qualified as HashMap
import Data.Text qualified as T
import GHC.IO.Exception (userError)
import Language.GraphQL.Class (ToGraphQL (toGraphQL))
import Language.GraphQL.Error (ResolverException (ResolverException))
import Language.GraphQL.Type qualified as Type
import Language.GraphQL.Type.In qualified as In
import Language.GraphQL.Type.Out qualified as Out


type Result = Either Text


throwResolverError :: Text -> m a
throwResolverError err =
  Exception.throw $
    ResolverException $
      userError $
        T.unpack err


{-| Turns a type descriptor into a graphql output type, erroring out on input
types. Child resolvers look up their respective fields in the value produced by
their parent.

Lookups for `__Type` objects are memoized, and a maximum depth of 30 is enforced.
-}
makeType :: IType.IntrospectionType -> Result (Out.Type IO)
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 =
      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.nonNull IType.typeString)
                    (Type.String "Maximum depth exceeded")
                else makeChildField (depth + 1) field
            pure (field.name, resolver)

          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
        _ -> do
          Left $ "invalid type in out position: " <> show (toGraphQL ty)

    -- Creates a field which looks up its value in the object returned by the
    -- parent resolver.
    makeChildField :: Int -> IType.Field -> Result (Out.Resolver IO)
    makeChildField depth field = do
      -- These lines are the same as `makeField`, except calling
      -- `makeTypeWithDepthMemo` instead of `makeType`
      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
                  throwResolverError $
                    "Error: field '"
                      <> field.name
                      <> "' not found "
                else pure Type.Null

        result <- case context.values of
          Type.Object obj -> do
            let errorValue = HashMap.lookup ("__error_" <> field.name) obj
            P.for_ errorValue $ \case
              Type.String err -> throwResolverError err
              _ -> pure ()

            case HashMap.lookup field.name obj of
              Just value -> pure value
              Nothing -> defaultValue
          _ -> defaultValue

        field.customResolver result
  in
    makeTypeWithDepth 0


{-| Turns a field descriptor into a graphql field. See the documentation
for `makeType` for details about the behaviour of child resolvers.
-}
makeField :: IType.Field -> Result (Out.Field IO)
makeField field = do
  args <- P.for field.args $ \arg -> do
    ty <- makeInType arg.type_
    pure (arg.name, In.Argument arg.description ty arg.defaultValue)
  ty <- makeType field.type_
  pure $ Out.Field field.description ty $ HashMap.fromList args


-- | Create a resolver which always returns a constant value.
makeConstField :: IType.Field -> Type.Value -> Result (Out.Resolver IO)
makeConstField field value = do
  gqlField <- makeField field
  pure $ Out.ValueResolver gqlField $ pure value


{-| The input-type version of `makeOutType`. No maximum depth is enforced, nor
is any memoization used. This is the case because input types are usually pretty
shallow.
-}
makeInType :: IType.IntrospectionType -> Result In.Type
makeInType ty = do
  case ty.kind of
    IType.Scalar name -> do
      pure $ In.NamedScalarType $ Type.ScalarType name ty.description
    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 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.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
        $ Type.InputObjectType
          name
          ty.description
        $ HashMap.fromList gqlFields
    _ -> do
      Left $ "invalid type in input position: " <> show (toGraphQL ty)