{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.Schema.JSON.Parse
  ( decodeIntrospection,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind (..))
import qualified Data.Morpheus.Client.Schema.JSON.TypeRef as Ref
import Data.Morpheus.Client.Schema.JSON.Types
  ( EnumValue (..),
    Field (..),
    InputValue (..),
    Introspection (..),
    JSONResponse (..),
    Schema (..),
    Type (..),
  )
import Data.Morpheus.Core
  ( defaultConfig,
    validateSchema,
  )
import Data.Morpheus.Internal.Ext
  ( GQLResult,
  )
import Data.Morpheus.Internal.Utils
  ( empty,
    fromElems,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ArgumentDefinition (..),
    CONST,
    FieldDefinition,
    GQLError,
    IN,
    OUT,
    OperationType (..),
    RootOperationTypeDefinition (..),
    SchemaDefinition (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeRef (..),
    TypeWrapper (..),
    VALID,
    buildSchema,
    createScalarType,
    mkEnumContent,
    mkField,
    mkMaybeType,
    mkObjectField,
    mkType,
    mkUnionContent,
    msg,
    toAny,
  )
import qualified Data.Morpheus.Types.Internal.AST as AST
  ( Schema,
  )
import Relude hiding
  ( ByteString,
    Type,
    empty,
    fromList,
    show,
  )
import Prelude (show)

decoderError :: GQLError -> GQLResult a
decoderError :: forall a. GQLError -> GQLResult a
decoderError = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID)
decodeIntrospection :: ByteString -> GQLResult (Schema VALID)
decodeIntrospection ByteString
jsonDoc = case Either String (JSONResponse Introspection)
jsonSchema of
  Left String
errors -> forall a. GQLError -> GQLResult a
decoderError forall a b. (a -> b) -> a -> b
$ forall a. Msg a => a -> GQLError
msg String
errors
  Right
    JSONResponse
      { $sel:responseData:JSONResponse :: forall a. JSONResponse a -> Maybe a
responseData =
          Just
            Introspection
              { $sel:__schema:Introspection :: Introspection -> Schema
__schema =
                  schema :: Schema
schema@Schema {[Type]
$sel:types:Schema :: Schema -> [Type]
types :: [Type]
types}
              }
      } -> do
      SchemaDefinition
schemaDef <- forall (m :: * -> *).
(Monad m, MonadError GQLError m) =>
Schema -> m SchemaDefinition
mkSchemaDef Schema
schema
      [TypeDefinition ANY CONST]
gqlTypes <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. ParseJSONSchema a b => a -> GQLResult b
parse [Type]
types
      forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m) =>
(Maybe SchemaDefinition, [TypeDefinition ANY s],
 DirectivesDefinition s)
-> m (Schema s)
buildSchema (forall a. a -> Maybe a
Just SchemaDefinition
schemaDef, [TypeDefinition ANY CONST]
gqlTypes, forall coll. Empty coll => coll
empty) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema CONST -> GQLResult (Schema VALID)
validate
  Right JSONResponse Introspection
res -> forall a. GQLError -> GQLResult a
decoderError (forall a. Msg a => a -> GQLError
msg forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show JSONResponse Introspection
res)
  where
    validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID)
    validate :: Schema CONST -> GQLResult (Schema VALID)
validate = forall (s :: Stage).
ValidateSchema s =>
Bool -> Config -> Schema s -> GQLResult (Schema VALID)
validateSchema Bool
False Config
defaultConfig
    jsonSchema :: Either String (JSONResponse Introspection)
    jsonSchema :: Either String (JSONResponse Introspection)
jsonSchema = forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
jsonDoc

mkSchemaDef ::
  (Monad m, MonadError GQLError m) =>
  Schema ->
  m SchemaDefinition
mkSchemaDef :: forall (m :: * -> *).
(Monad m, MonadError GQLError m) =>
Schema -> m SchemaDefinition
mkSchemaDef
  Schema
    { TypeRef
$sel:queryType:Schema :: Schema -> TypeRef
queryType :: TypeRef
queryType,
      Maybe TypeRef
$sel:mutationType:Schema :: Schema -> Maybe TypeRef
mutationType :: Maybe TypeRef
mutationType,
      Maybe TypeRef
$sel:subscriptionType:Schema :: Schema -> Maybe TypeRef
subscriptionType :: Maybe TypeRef
subscriptionType
    } =
    Directives CONST
-> OrdMap OperationType RootOperationTypeDefinition
-> SchemaDefinition
SchemaDefinition forall coll. Empty coll => coll
empty
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems
        ( forall a. [Maybe a] -> [a]
catMaybes
            [ forall a. a -> Maybe a
Just (OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Query forall a b. (a -> b) -> a -> b
$ TypeRef -> TypeName
Ref.name TypeRef
queryType),
              OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Mutation forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> TypeName
Ref.name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypeRef
mutationType,
              OperationType -> TypeName -> RootOperationTypeDefinition
RootOperationTypeDefinition OperationType
Subscription forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> TypeName
Ref.name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypeRef
subscriptionType
            ]
        )

class ParseJSONSchema a b where
  parse :: a -> GQLResult b

instance ParseJSONSchema Type [TypeDefinition ANY CONST] where
  parse :: Type -> Result GQLError [TypeDefinition ANY CONST]
parse Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
typeName, $sel:kind:Type :: Type -> TypeKind
kind = TypeKind
SCALAR} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
TypeName -> TypeDefinition a s
createScalarType TypeName
typeName]
  parse Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
typeName, $sel:kind:Type :: Type -> TypeKind
kind = TypeKind
ENUM, $sel:enumValues:Type :: Type -> Maybe [EnumValue]
enumValues = Just [EnumValue]
enums} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName forall a b. (a -> b) -> a -> b
$ forall (a :: TypeCategory) (s :: Stage).
(LEAF <=! a) =>
[TypeName] -> TypeContent TRUE a s
mkEnumContent (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EnumValue -> TypeName
enumName [EnumValue]
enums)]
  parse Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
typeName, $sel:kind:Type :: Type -> TypeKind
kind = TypeKind
UNION, $sel:possibleTypes:Type :: Type -> Maybe [Type]
possibleTypes = Just [Type]
unions} =
    case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TypeName
name [Type]
unions of
      Maybe [TypeName]
Nothing -> forall a. GQLError -> GQLResult a
decoderError GQLError
"ERROR: GQL ERROR"
      Just [TypeName]
uni -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny forall a b. (a -> b) -> a -> b
$ forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). [TypeName] -> TypeContent TRUE OUT s
mkUnionContent [TypeName]
uni]
  parse Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
typeName, $sel:kind:Type :: Type -> TypeKind
kind = TypeKind
INPUT_OBJECT, $sel:inputFields:Type :: Type -> Maybe [InputValue]
inputFields = Just [InputValue]
iFields} =
    do
      ([FieldDefinition IN CONST]
fields :: [FieldDefinition IN CONST]) <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. ParseJSONSchema a b => a -> GQLResult b
parse [InputValue]
iFields
      OrdMap FieldName (FieldDefinition IN CONST)
fs <- forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems [FieldDefinition IN CONST]
fields
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName forall a b. (a -> b) -> a -> b
$ forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (INPUT_OBJECT <=? a) a s
DataInputObject OrdMap FieldName (FieldDefinition IN CONST)
fs]
  parse Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
typeName, $sel:kind:Type :: Type -> TypeKind
kind = TypeKind
OBJECT, $sel:fields:Type :: Type -> Maybe [Field]
fields = Just [Field]
oFields} =
    do
      ([FieldDefinition OUT CONST]
fields :: [FieldDefinition OUT CONST]) <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. ParseJSONSchema a b => a -> GQLResult b
parse [Field]
oFields
      OrdMap FieldName (FieldDefinition OUT CONST)
fs <- forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems [FieldDefinition OUT CONST]
fields
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (a :: TypeCategory) (s :: Stage).
TypeName -> TypeContent TRUE a s -> TypeDefinition a s
mkType TypeName
typeName forall a b. (a -> b) -> a -> b
$ forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s
DataObject [] OrdMap FieldName (FieldDefinition OUT CONST)
fs]
  parse Type
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance ParseJSONSchema Field (FieldDefinition OUT CONST) where
  parse :: Field -> GQLResult (FieldDefinition OUT CONST)
parse Field {FieldName
$sel:fieldName:Field :: Field -> FieldName
fieldName :: FieldName
fieldName, [InputValue]
$sel:fieldArgs:Field :: Field -> [InputValue]
fieldArgs :: [InputValue]
fieldArgs, Type
$sel:fieldType:Field :: Field -> Type
fieldType :: Type
fieldType} = do
    TypeRef TypeName
typename TypeWrapper
wrappers <- Type -> GQLResult TypeRef
fieldTypeFromJSON Type
fieldType
    OrdMap FieldName (ArgumentDefinition CONST)
args <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {s :: Stage}.
InputValue -> Result GQLError (ArgumentDefinition s)
genArg [InputValue]
fieldArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) k a (map :: * -> * -> *).
(Monad m, KeyOf k a, FromList m map k a) =>
[a] -> m (map k a)
fromElems
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (s :: Stage).
ArgumentsDefinition s
-> FieldName -> TypeWrapper -> TypeName -> FieldDefinition OUT s
mkObjectField OrdMap FieldName (ArgumentDefinition CONST)
args FieldName
fieldName TypeWrapper
wrappers TypeName
typename
    where
      genArg :: InputValue -> Result GQLError (ArgumentDefinition s)
genArg InputValue {$sel:inputName:InputValue :: InputValue -> FieldName
inputName = FieldName
argName, $sel:inputType:InputValue :: InputValue -> Type
inputType = Type
argType} =
        forall (s :: Stage). FieldDefinition IN s -> ArgumentDefinition s
ArgumentDefinition forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField forall a. Maybe a
Nothing FieldName
argName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> GQLResult TypeRef
fieldTypeFromJSON Type
argType

instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where
  parse :: InputValue -> GQLResult (FieldDefinition IN CONST)
parse InputValue {FieldName
inputName :: FieldName
$sel:inputName:InputValue :: InputValue -> FieldName
inputName, Type
inputType :: Type
$sel:inputType:InputValue :: InputValue -> Type
inputType} = forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField forall a. Maybe a
Nothing FieldName
inputName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> GQLResult TypeRef
fieldTypeFromJSON Type
inputType

fieldTypeFromJSON :: Type -> GQLResult TypeRef
fieldTypeFromJSON :: Type -> GQLResult TypeRef
fieldTypeFromJSON Type {$sel:kind:Type :: Type -> TypeKind
kind = TypeKind
NON_NULL, $sel:ofType:Type :: Type -> Maybe Type
ofType = Just Type
ofType} = TypeRef -> TypeRef
withListNonNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> GQLResult TypeRef
fieldTypeFromJSON Type
ofType
fieldTypeFromJSON Type {$sel:kind:Type :: Type -> TypeKind
kind = TypeKind
LIST, $sel:ofType:Type :: Type -> Maybe Type
ofType = Just Type
ofType} = TypeRef -> TypeRef
withList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> GQLResult TypeRef
fieldTypeFromJSON Type
ofType
fieldTypeFromJSON Type {$sel:name:Type :: Type -> Maybe TypeName
name = Just TypeName
name} = forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name TypeWrapper
mkMaybeType)
fieldTypeFromJSON Type
x = forall a. GQLError -> GQLResult a
decoderError forall a b. (a -> b) -> a -> b
$ GQLError
"Unsupported Field" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (forall a. Show a => a -> String
show Type
x)

withList :: TypeRef -> TypeRef
withList :: TypeRef -> TypeRef
withList (TypeRef TypeName
name TypeWrapper
x) = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name (TypeWrapper -> Bool -> TypeWrapper
TypeList TypeWrapper
x Bool
False)

withListNonNull :: TypeRef -> TypeRef
withListNonNull :: TypeRef -> TypeRef
withListNonNull (TypeRef TypeName
name (TypeList TypeWrapper
y Bool
_)) = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name (TypeWrapper -> Bool -> TypeWrapper
TypeList TypeWrapper
y Bool
True)
withListNonNull (TypeRef TypeName
name (BaseType Bool
_)) = TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name (Bool -> TypeWrapper
BaseType Bool
True)