{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.JSONSchema.Parse ( decodeIntrospection, ) where import Control.Applicative (pure) import Control.Monad ((>>=)) import Data.Aeson import Data.ByteString.Lazy (ByteString) import Data.Either (Either (..)) import Data.Functor ((<$>), fmap) import Data.List (concat) import Data.Maybe (Maybe (..)) import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind (..)) import Data.Morpheus.Client.JSONSchema.Types ( EnumValue (..), Field (..), InputValue (..), Introspection (..), Schema (..), Type (..), ) import Data.Morpheus.Core ( defaultConfig, validateSchema, ) import Data.Morpheus.Error (globalErrorMessage) import Data.Morpheus.Internal.Utils ( fromElems, ) import Data.Morpheus.Types.IO (JSONResponse (..)) import qualified Data.Morpheus.Types.Internal.AST as AST ( Schema, ) import Data.Morpheus.Types.Internal.AST ( ANY, ArgumentsDefinition (..), CONST, DataTypeWrapper (..), FieldDefinition, IN, Message, OUT, TypeContent (..), TypeDefinition (..), TypeName, TypeWrapper, VALID, createScalarType, mkEnumContent, mkInputValue, mkObjectField, mkType, mkUnionContent, msg, toAny, toHSWrappers, ) import Data.Morpheus.Types.Internal.Resolving ( Eventless, failure, ) import Data.Semigroup ((<>)) import Data.String (String) import Data.Traversable (traverse) import Prelude ( ($), (.), Bool (..), Show (..), uncurry, ) decoderError :: Message -> Eventless a decoderError = failure . globalErrorMessage decodeIntrospection :: ByteString -> Eventless (AST.Schema VALID) decodeIntrospection jsonDoc = case jsonSchema of Left errors -> decoderError $ msg errors Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} -> traverse parse types >>= fromElems . concat >>= validate Right res -> decoderError (msg $ show res) where validate :: AST.Schema CONST -> Eventless (AST.Schema VALID) validate = validateSchema False defaultConfig jsonSchema :: Either String (JSONResponse Introspection) jsonSchema = eitherDecode jsonDoc class ParseJSONSchema a b where parse :: a -> Eventless b instance ParseJSONSchema Type [TypeDefinition ANY CONST] where parse Type {name = Just typeName, kind = SCALAR} = pure [createScalarType typeName] parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} = pure [mkType typeName $ mkEnumContent (fmap enumName enums)] parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} = case traverse name unions of Nothing -> decoderError "ERROR: GQL ERROR" Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni] parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = do (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields fs <- fromElems fields pure [mkType typeName $ DataInputObject fs] parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = do (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields fs <- fromElems fields pure [mkType typeName $ DataObject [] fs] parse _ = pure [] instance ParseJSONSchema Field (FieldDefinition OUT CONST) where parse Field {fieldName, fieldArgs, fieldType} = do (wrappers, typename) <- fieldTypeFromJSON fieldType args <- traverse genArg fieldArgs >>= fromElems pure $ mkObjectField (ArgumentsDefinition Nothing args) fieldName wrappers typename where genArg InputValue {inputName = argName, inputType = argType} = uncurry (mkInputValue argName) <$> fieldTypeFromJSON argType instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where parse InputValue {inputName, inputType} = uncurry (mkInputValue inputName) <$> fieldTypeFromJSON inputType fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName) fieldTypeFromJSON = fmap toHs . fieldTypeRec [] where toHs (w, t) = (toHSWrappers w, t) fieldTypeRec :: [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], TypeName) fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} = fieldTypeRec (ListType : acc) ofType fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} = fieldTypeRec (NonNullType : acc) ofType fieldTypeRec acc Type {name = Just name} = pure (acc, name) fieldTypeRec _ x = decoderError $ "Unsuported Field" <> msg (show x)