diff --git a/examples/Deprecated/API.hs b/examples/Deprecated/API.hs
new file mode 100644
--- /dev/null
+++ b/examples/Deprecated/API.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Deprecated.API
+ ( gqlRoot
+ ) where
+
+import Data.Map (Map)
+import qualified Data.Map as M (fromList)
+import Data.Set (Set)
+import qualified Data.Set as S (fromList)
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+
+-- MORPHEUS
+import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION)
+import Data.Morpheus.Types (EffectM, GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, ResM, Resolver,
+ ScalarValue (..), gqlEffectResolver, gqlResolver)
+
+type instance KIND CityID = ENUM
+
+type instance KIND Euro = SCALAR
+
+type instance KIND UID = INPUT_OBJECT
+
+type instance KIND Coordinates = INPUT_OBJECT
+
+type instance KIND Address = OBJECT
+
+type instance KIND (User res) = OBJECT
+
+type instance KIND (MyUnion res) = UNION
+
+data MyUnion res
+ = USER (User res)
+ | ADDRESS Address
+ deriving (Generic, GQLType)
+
+data CityID
+ = Paris
+ | BLN
+ | HH
+ deriving (Generic, GQLType)
+
+data Euro =
+ Euro Int
+ Int
+ deriving (Generic, GQLType)
+
+instance GQLScalar Euro where
+ parseValue _ = pure (Euro 1 0)
+ serialize (Euro x y) = Int (x * 100 + y)
+
+newtype UID = UID
+ { uid :: Text
+ } deriving (Show, Generic, GQLType)
+
+data Coordinates = Coordinates
+ { latitude :: Euro
+ , longitude :: [Maybe [[UID]]]
+ } deriving (Generic)
+
+instance GQLType Coordinates where
+ description _ = "just random latitude and longitude"
+
+data Address = Address
+ { city :: Text
+ , street :: Text
+ , houseNumber :: Int
+ } deriving (Generic, GQLType)
+
+data AddressArgs = AddressArgs
+ { coordinates :: Coordinates
+ , comment :: Maybe Text
+ } deriving (Generic)
+
+data OfficeArgs = OfficeArgs
+ { zipCode :: Maybe [[Maybe [ID]]]
+ , cityID :: CityID
+ } deriving (Generic)
+
+data User m = User
+ { name :: Text
+ , email :: Text
+ , address :: AddressArgs -> m Address
+ , office :: OfficeArgs -> m Address
+ , myUnion :: () -> m (MyUnion m)
+ , home :: CityID
+ } deriving (Generic)
+
+instance Typeable a => GQLType (User a) where
+ description _ = "Custom Description for Client Defined User Type"
+
+type instance KIND (A a) = OBJECT
+
+newtype A a = A
+ { wrappedA :: a
+ } deriving (Generic, GQLType)
+
+fetchAddress :: Monad m => Euro -> m (Either String Address)
+fetchAddress _ = return $ Right $ Address " " "" 0
+
+fetchUser :: Monad m => m (Either String (User (Resolver m)))
+fetchUser =
+ return $
+ Right $
+ User
+ { name = "George"
+ , email = "George@email.com"
+ , address = const resolveAddress
+ , office = resolveOffice
+ , home = HH
+ , myUnion = const $ return $ USER unionUser
+ }
+ where
+ unionAddress = Address {city = "Hamburg", street = "Street", houseNumber = 20}
+ -- Office
+ resolveOffice OfficeArgs {cityID = Paris} = gqlResolver $ fetchAddress (Euro 1 1)
+ resolveOffice OfficeArgs {cityID = BLN} = gqlResolver $ fetchAddress (Euro 1 2)
+ resolveOffice OfficeArgs {cityID = HH} = gqlResolver $ fetchAddress (Euro 1 3)
+ resolveAddress = gqlResolver $ fetchAddress (Euro 1 0)
+ unionUser =
+ User
+ { name = "David"
+ , email = "David@email.com"
+ , address = const resolveAddress
+ , office = resolveOffice
+ , home = BLN
+ , myUnion = const $ return $ ADDRESS unionAddress
+ }
+
+createUserMutation :: a -> EffectM (User EffectM)
+createUserMutation _ = gqlEffectResolver ["UPDATE_USER"] fetchUser
+
+newUserSubscription :: a -> EffectM (User EffectM)
+newUserSubscription _ = gqlEffectResolver ["UPDATE_USER"] fetchUser
+
+createAddressMutation :: a -> EffectM Address
+createAddressMutation _ = gqlEffectResolver ["UPDATE_ADDRESS"] (fetchAddress (Euro 1 0))
+
+newAddressSubscription :: a -> EffectM Address
+newAddressSubscription _ = gqlEffectResolver ["UPDATE_ADDRESS"] $ fetchAddress (Euro 1 0)
+
+data Query = Query
+ { user :: () -> ResM (User ResM)
+ , wrappedA1 :: A (Int, Text)
+ , wrappedA2 :: A Text
+ , integerSet :: Set Int
+ , textIntMap :: Map Text Int
+ } deriving (Generic)
+
+data Mutation = Mutation
+ { createUser :: () -> EffectM (User EffectM)
+ , createAddress :: () -> EffectM Address
+ } deriving (Generic)
+
+data Subscription = Subscription
+ { newUser :: () -> EffectM (User EffectM)
+ , newAddress :: () -> EffectM Address
+ } deriving (Generic)
+
+gqlRoot :: GQLRootResolver IO Query Mutation Subscription
+gqlRoot =
+ GQLRootResolver
+ { queryResolver =
+ return
+ Query
+ { user = const $ gqlResolver fetchUser
+ , wrappedA1 = A (0, "")
+ , wrappedA2 = A ""
+ , integerSet = S.fromList [1, 2]
+ , textIntMap = M.fromList [("robin", 1), ("carl", 2)]
+ }
+ , mutationResolver = return Mutation {createUser = createUserMutation, createAddress = createAddressMutation}
+ , subscriptionResolver = return Subscription {newUser = newUserSubscription, newAddress = newAddressSubscription}
+ }
diff --git a/examples/Deprecated/Model.hs b/examples/Deprecated/Model.hs
new file mode 100644
--- /dev/null
+++ b/examples/Deprecated/Model.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Deprecated.Model
+ ( jsonAddress
+ , jsonUser
+ , JSONUser(..)
+ , JSONAddress(..)
+ ) where
+
+import Data.Aeson (FromJSON)
+import Data.Text (Text)
+import Files (getJson)
+import GHC.Generics (Generic)
+
+data JSONUser = JSONUser
+ { name :: Text
+ , email :: Text
+ } deriving (Show, Generic, FromJSON)
+
+data JSONAddress = JSONAddress
+ { city :: Text
+ , street :: Text
+ , houseNumber :: Int
+ } deriving (Generic, Show, FromJSON)
+
+jsonUser :: IO (Either String JSONUser)
+jsonUser = getJson "deprecated/user"
+
+jsonAddress :: IO (Either String JSONAddress)
+jsonAddress = getJson "deprecated/address"
diff --git a/examples/Files.hs b/examples/Files.hs
new file mode 100644
--- /dev/null
+++ b/examples/Files.hs
@@ -0,0 +1,12 @@
+module Files
+ ( getJson
+ ) where
+
+import Data.Aeson (FromJSON, eitherDecode)
+import qualified Data.ByteString.Lazy as L (readFile)
+
+jsonPath :: String -> String
+jsonPath name = "examples/db/" ++ name ++ ".json"
+
+getJson :: FromJSON a => FilePath -> IO (Either String a)
+getJson path = eitherDecode <$> L.readFile (jsonPath path)
diff --git a/examples/Main.hs b/examples/Main.hs
new file mode 100644
--- /dev/null
+++ b/examples/Main.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main
+ ( main
+ ) where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Morpheus (Interpreter (..))
+import Data.Morpheus.Server (GQLState, gqlSocketApp, initGQLState)
+import Deprecated.API (gqlRoot)
+import Mythology.API (mythologyApi)
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Network.Wai.Handler.WebSockets as WaiWs
+import Network.WebSockets (defaultConnectionOptions)
+import Web.Scotty (body, file, get, post, raw, scottyApp)
+
+{-
+const ws = new WebSocket('ws://localhost:3000/');
+ws.send(JSON.stringify({"query":"query GetUser{user{name}}"}))
+ws.send(JSON.stringify({"query":"mutation CreateUser{ createUser{name} }"}))
+ws.send(JSON.stringify({"query":"subscription ShowNewUser{ newUser{name} }"}))
+-}
+main :: IO ()
+main = do
+ state <- initGQLState
+ httpApp <- httpServer state
+ Warp.runSettings settings $ WaiWs.websocketsOr defaultConnectionOptions (wsApp state) httpApp
+ where
+ settings = Warp.setPort 3000 Warp.defaultSettings
+ wsApp = gqlSocketApp (interpreter gqlRoot)
+ httpServer :: GQLState -> IO Wai.Application
+ httpServer state =
+ scottyApp $ do
+ post "/" $ raw =<< (liftIO . interpreter gqlRoot state =<< body)
+ get "/" $ file "examples/index.html"
+ post "/mythology" $ raw =<< (liftIO . mythologyApi =<< body)
+ get "/mythology" $ file "examples/index.html"
diff --git a/examples/Mythology/API.hs b/examples/Mythology/API.hs
new file mode 100644
--- /dev/null
+++ b/examples/Mythology/API.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Mythology.API
+ ( mythologyApi
+ ) where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Types (GQLRootResolver (..), ResM, gqlResolver)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Mythology.Character.Deity (Deity (..), dbDeity)
+
+newtype Query = Query
+ { deity :: DeityArgs -> ResM Deity
+ } deriving (Generic)
+
+data DeityArgs = DeityArgs
+ { name :: Text -- Required Argument
+ , mythology :: Maybe Text -- Optional Argument
+ } deriving (Generic)
+
+resolveDeity :: DeityArgs -> ResM Deity
+resolveDeity args = gqlResolver $ dbDeity (name args) (mythology args)
+
+rootResolver :: GQLRootResolver IO Query () ()
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {deity = resolveDeity}
+ , mutationResolver = return ()
+ , subscriptionResolver = return ()
+ }
+
+mythologyApi :: B.ByteString -> IO B.ByteString
+mythologyApi = interpreter rootResolver
diff --git a/examples/Mythology/Character/Deity.hs b/examples/Mythology/Character/Deity.hs
new file mode 100644
--- /dev/null
+++ b/examples/Mythology/Character/Deity.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Mythology.Character.Deity
+ ( Deity(..)
+ , dbDeity
+ ) where
+
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (GQLType (..))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Mythology.Place.Places (Realm (..))
+
+type instance KIND Deity = OBJECT
+
+instance GQLType Deity where
+ description _ = "Custom Description for Client Defined User Type"
+
+data Deity = Deity
+ { fullName :: Text -- Non-Nullable Field
+ , power :: Maybe Text -- Nullable Field
+ , realm :: Realm
+ } deriving (Generic)
+
+dbDeity :: Text -> Maybe Text -> IO (Either String Deity)
+dbDeity _ _ = return $ Right $ Deity {fullName = "Morpheus", power = Just "Shapeshifting", realm = Dream}
diff --git a/examples/Mythology/Character/Human.hs b/examples/Mythology/Character/Human.hs
new file mode 100644
--- /dev/null
+++ b/examples/Mythology/Character/Human.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Mythology.Character.Human
+ ( Human(..)
+ ) where
+
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (GQLType)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Mythology.Place.Places (City (..))
+
+type instance KIND Human = OBJECT
+
+data Human = Human
+ { name :: Text
+ , home :: City
+ } deriving (Generic, GQLType)
diff --git a/examples/Mythology/Place/Places.hs b/examples/Mythology/Place/Places.hs
new file mode 100644
--- /dev/null
+++ b/examples/Mythology/Place/Places.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Mythology.Place.Places
+ ( Realm(..)
+ , City(..)
+ ) where
+
+import Data.Morpheus.Kind (ENUM, KIND)
+import Data.Morpheus.Types (GQLType)
+import GHC.Generics (Generic)
+
+type instance KIND Realm = ENUM
+
+data Realm
+ = MountOlympus
+ | Sky
+ | Sea
+ | Underworld
+ | Dream
+ deriving (Generic, GQLType)
+
+type instance KIND City = ENUM
+
+data City
+ = Athens
+ | Colchis
+ | Delphi
+ | Ithaca
+ | Sparta
+ | Troy
diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal
--- a/morpheus-graphql.cabal
+++ b/morpheus-graphql.cabal
@@ -2,10 +2,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: d7cc2512dba12ffbd4ce4220a0c8dfc022a9ea87b81033770a75b7146ec2c5e1
+-- hash: 4207df71e3ee77e9ae54b225cd5b0f2186ae77d3da256bd79d9856c5c51f0151
name: morpheus-graphql
-version: 0.0.1
+version: 0.1.0
synopsis: Morpheus GraphQL
description: Build GraphQL APIs with your favourite functional language!
category: web, graphql
@@ -18,6 +18,162 @@
license-file: LICENSE
build-type: Simple
cabal-version: >= 1.10
+data-files:
+ test/Feature/Holistic/API.gql
+ test/Feature/Holistic/arguments/nameConflict/query.gql
+ test/Feature/Holistic/arguments/nameConflict/response.json
+ test/Feature/Holistic/arguments/undefinedArgument/query.gql
+ test/Feature/Holistic/arguments/undefinedArgument/response.json
+ test/Feature/Holistic/arguments/unknownArguments/query.gql
+ test/Feature/Holistic/arguments/unknownArguments/response.json
+ test/Feature/Holistic/cases.json
+ test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql
+ test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json
+ test/Feature/Holistic/fragment/inlineFragment/query.gql
+ test/Feature/Holistic/fragment/inlineFragment/response.json
+ test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql
+ test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json
+ test/Feature/Holistic/fragment/loopingFragment/query.gql
+ test/Feature/Holistic/fragment/loopingFragment/response.json
+ test/Feature/Holistic/fragment/unknownTargetType/query.gql
+ test/Feature/Holistic/fragment/unknownTargetType/response.json
+ test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql
+ test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json
+ test/Feature/Holistic/introspection/defaultTypes/Float/query.gql
+ test/Feature/Holistic/introspection/defaultTypes/Float/response.json
+ test/Feature/Holistic/introspection/defaultTypes/ID/query.gql
+ test/Feature/Holistic/introspection/defaultTypes/ID/response.json
+ test/Feature/Holistic/introspection/defaultTypes/Int/query.gql
+ test/Feature/Holistic/introspection/defaultTypes/Int/response.json
+ test/Feature/Holistic/introspection/defaultTypes/String/query.gql
+ test/Feature/Holistic/introspection/defaultTypes/String/response.json
+ test/Feature/Holistic/introspection/kinds/ENUM/query.gql
+ test/Feature/Holistic/introspection/kinds/ENUM/response.json
+ test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql
+ test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json
+ test/Feature/Holistic/introspection/kinds/OBJECT/query.gql
+ test/Feature/Holistic/introspection/kinds/OBJECT/response.json
+ test/Feature/Holistic/introspection/kinds/SCALAR/query.gql
+ test/Feature/Holistic/introspection/kinds/SCALAR/response.json
+ test/Feature/Holistic/introspection/kinds/UNION/query.gql
+ test/Feature/Holistic/introspection/kinds/UNION/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__Directive/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__EnumValue/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__Field/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__InputValue/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__Type/response.json
+ test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql
+ test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json
+ test/Feature/Holistic/parsing/complex/query.gql
+ test/Feature/Holistic/parsing/complex/response.json
+ test/Feature/Holistic/parsing/extraCommas/query.gql
+ test/Feature/Holistic/parsing/extraCommas/response.json
+ test/Feature/Holistic/parsing/generousSpaces/query.gql
+ test/Feature/Holistic/parsing/generousSpaces/response.json
+ test/Feature/Holistic/parsing/invalidFields/query.gql
+ test/Feature/Holistic/parsing/invalidFields/response.json
+ test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql
+ test/Feature/Holistic/parsing/invalidNotNullOperator/response.json
+ test/Feature/Holistic/parsing/missingCloseBrace/query.gql
+ test/Feature/Holistic/parsing/missingCloseBrace/response.json
+ test/Feature/Holistic/parsing/notNullSpacing/query.gql
+ test/Feature/Holistic/parsing/notNullSpacing/response.json
+ test/Feature/Holistic/parsing/notNullSpacing/variables.json
+ test/Feature/Holistic/selection/AliasNameConflict/query.gql
+ test/Feature/Holistic/selection/AliasNameConflict/response.json
+ test/Feature/Holistic/selection/AliasResolve/query.gql
+ test/Feature/Holistic/selection/AliasResolve/response.json
+ test/Feature/Holistic/selection/AliasUnknownField/query.gql
+ test/Feature/Holistic/selection/AliasUnknownField/response.json
+ test/Feature/Holistic/selection/hasNoSubFields/query.gql
+ test/Feature/Holistic/selection/hasNoSubFields/response.json
+ test/Feature/Holistic/selection/mustHaveSubFields/query.gql
+ test/Feature/Holistic/selection/mustHaveSubFields/response.json
+ test/Feature/Holistic/selection/nameConflict/query.gql
+ test/Feature/Holistic/selection/nameConflict/response.json
+ test/Feature/Holistic/selection/unknownField/query.gql
+ test/Feature/Holistic/selection/unknownField/response.json
+ test/Feature/InputType/cases.json
+ test/Feature/InputType/variables/incompatibleType/equalType/query.gql
+ test/Feature/InputType/variables/incompatibleType/equalType/response.json
+ test/Feature/InputType/variables/incompatibleType/equalType/variables.json
+ test/Feature/InputType/variables/incompatibleType/stricterType/query.gql
+ test/Feature/InputType/variables/incompatibleType/stricterType/response.json
+ test/Feature/InputType/variables/incompatibleType/stricterType/variables.json
+ test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql
+ test/Feature/InputType/variables/incompatibleType/weakerType1/response.json
+ test/Feature/InputType/variables/incompatibleType/weakerType1/variables.json
+ test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql
+ test/Feature/InputType/variables/incompatibleType/weakerType2/response.json
+ test/Feature/InputType/variables/incompatibleType/weakerType2/variables.json
+ test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql
+ test/Feature/InputType/variables/incompatibleType/weakerType3/response.json
+ test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json
+ test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql
+ test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json
+ test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json
+ test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql
+ test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json
+ test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json
+ test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql
+ test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json
+ test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json
+ test/Feature/InputType/variables/nullableVariable/query.gql
+ test/Feature/InputType/variables/nullableVariable/response.json
+ test/Feature/InputType/variables/undefinedVariable/query.gql
+ test/Feature/InputType/variables/undefinedVariable/response.json
+ test/Feature/InputType/variables/unknownType/query.gql
+ test/Feature/InputType/variables/unknownType/response.json
+ test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql
+ test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql
+ test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/response.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/variables.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql
+ test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/response.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/variables.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql
+ test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/response.json
+ test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/variables.json
+ test/Feature/InputType/variables/validListVariable/query.gql
+ test/Feature/InputType/variables/validListVariable/response.json
+ test/Feature/InputType/variables/validListVariable/variables.json
+ test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql
+ test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json
+ test/Feature/Schema/cases.json
+ test/Feature/Schema/nameCollision/query.gql
+ test/Feature/Schema/nameCollision/response.json
+ test/Feature/UnionType/cannotBeSpreadOnType/query.gql
+ test/Feature/UnionType/cannotBeSpreadOnType/response.json
+ test/Feature/UnionType/cases.json
+ test/Feature/UnionType/fragmentOnAAndB/query.gql
+ test/Feature/UnionType/fragmentOnAAndB/response.json
+ test/Feature/UnionType/fragmentOnlyOnA/query.gql
+ test/Feature/UnionType/fragmentOnlyOnA/response.json
+ test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql
+ test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json
+ test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql
+ test/Feature/UnionType/inlineFragment/fragmentOnAAndB/response.json
+ test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql
+ test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json
+ test/Feature/WrappedTypeName/cases.json
+ test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql
+ test/Feature/WrappedTypeName/ignoreMutationResolver/response.json
+ test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql
+ test/Feature/WrappedTypeName/ignoreQueryResolver/response.json
+ test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql
+ test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json
+ test/Feature/WrappedTypeName/validWrappedTypes/query.gql
+ test/Feature/WrappedTypeName/validWrappedTypes/response.json
source-repository head
type: git
@@ -26,88 +182,163 @@
library
exposed-modules:
Data.Morpheus
+ Data.Morpheus.Kind
+ Data.Morpheus.Types
+ Data.Morpheus.Server
+ other-modules:
Data.Morpheus.Error.Arguments
Data.Morpheus.Error.Fragment
Data.Morpheus.Error.Input
Data.Morpheus.Error.Internal
Data.Morpheus.Error.Mutation
+ Data.Morpheus.Error.Schema
Data.Morpheus.Error.Selection
Data.Morpheus.Error.Spread
- Data.Morpheus.Error.Syntax
+ Data.Morpheus.Error.Subscription
Data.Morpheus.Error.Utils
Data.Morpheus.Error.Variable
- Data.Morpheus.Generics.DeriveResolvers
- Data.Morpheus.Generics.GDecode
- Data.Morpheus.Generics.GDecodeEnum
- Data.Morpheus.Generics.TypeRep
- Data.Morpheus.Generics.Utils
- Data.Morpheus.Kind
- Data.Morpheus.Kind.GQLArgs
- Data.Morpheus.Kind.GQLEnum
- Data.Morpheus.Kind.GQLInput
- Data.Morpheus.Kind.GQLKind
- Data.Morpheus.Kind.GQLMutation
- Data.Morpheus.Kind.GQLObject
- Data.Morpheus.Kind.GQLQuery
- Data.Morpheus.Kind.GQLScalar
+ Data.Morpheus.Interpreter
Data.Morpheus.Parser.Arguments
Data.Morpheus.Parser.Body
Data.Morpheus.Parser.Fragment
- Data.Morpheus.Parser.Mutation
+ Data.Morpheus.Parser.Internal
+ Data.Morpheus.Parser.Operator
Data.Morpheus.Parser.Parser
Data.Morpheus.Parser.Primitive
- Data.Morpheus.Parser.Query
- Data.Morpheus.Parser.RootHead
- Data.Morpheus.PreProcess.Fragment
- Data.Morpheus.PreProcess.Input.Enum
- Data.Morpheus.PreProcess.Input.Object
- Data.Morpheus.PreProcess.PreProcess
- Data.Morpheus.PreProcess.Resolve.Arguments
- Data.Morpheus.PreProcess.Resolve.ResolveRawQuery
- Data.Morpheus.PreProcess.Resolve.Spread
- Data.Morpheus.PreProcess.Selection
- Data.Morpheus.PreProcess.Utils
- Data.Morpheus.PreProcess.Validate.Arguments
- Data.Morpheus.PreProcess.Validate.Validate
- Data.Morpheus.PreProcess.Variable
+ Data.Morpheus.Parser.Terms
+ Data.Morpheus.Parser.Value
+ Data.Morpheus.Resolve.Decode
+ Data.Morpheus.Resolve.Encode
+ Data.Morpheus.Resolve.Generics.EnumRep
+ Data.Morpheus.Resolve.Generics.TypeRep
+ Data.Morpheus.Resolve.Introspect
+ Data.Morpheus.Resolve.Operator
+ Data.Morpheus.Resolve.Resolve
Data.Morpheus.Schema.Directive
Data.Morpheus.Schema.DirectiveLocation
Data.Morpheus.Schema.EnumValue
Data.Morpheus.Schema.Field
Data.Morpheus.Schema.InputValue
- Data.Morpheus.Schema.Internal.Types
+ Data.Morpheus.Schema.Internal.RenderIntrospection
Data.Morpheus.Schema.Schema
+ Data.Morpheus.Schema.SchemaAPI
Data.Morpheus.Schema.Type
Data.Morpheus.Schema.TypeKind
- Data.Morpheus.Schema.Utils.Utils
- Data.Morpheus.Types.Core
- Data.Morpheus.Types.Describer
- Data.Morpheus.Types.Error
- Data.Morpheus.Types.JSType
- Data.Morpheus.Types.MetaInfo
- Data.Morpheus.Types.Query.Fragment
- Data.Morpheus.Types.Query.Operator
- Data.Morpheus.Types.Query.RawSelection
- Data.Morpheus.Types.Query.Selection
- Data.Morpheus.Types.Request
- Data.Morpheus.Types.Response
+ Data.Morpheus.Server.Apollo
+ Data.Morpheus.Server.ClientRegister
+ Data.Morpheus.Types.Custom
+ Data.Morpheus.Types.GQLScalar
+ Data.Morpheus.Types.GQLType
+ Data.Morpheus.Types.ID
+ Data.Morpheus.Types.Internal.AST.Operator
+ Data.Morpheus.Types.Internal.AST.RawSelection
+ Data.Morpheus.Types.Internal.AST.Selection
+ Data.Morpheus.Types.Internal.Base
+ Data.Morpheus.Types.Internal.Data
+ Data.Morpheus.Types.Internal.Validation
+ Data.Morpheus.Types.Internal.Value
+ Data.Morpheus.Types.Internal.WebSocket
+ Data.Morpheus.Types.IO
+ Data.Morpheus.Types.Resolver
Data.Morpheus.Types.Types
- Data.Morpheus.Wrapper
- other-modules:
+ Data.Morpheus.Validation.Arguments
+ Data.Morpheus.Validation.Fragment
+ Data.Morpheus.Validation.Input.Enum
+ Data.Morpheus.Validation.Input.Object
+ Data.Morpheus.Validation.Selection
+ Data.Morpheus.Validation.Spread
+ Data.Morpheus.Validation.Utils.Selection
+ Data.Morpheus.Validation.Utils.Utils
+ Data.Morpheus.Validation.Validation
+ Data.Morpheus.Validation.Variable
Paths_morpheus_graphql
hs-source-dirs:
src
ghc-options: -Wall
build-depends:
- aeson >=1.0 && <=1.4.2.0
- , attoparsec >=0.13.2.2 && <0.14
+ aeson >=1.0 && <=1.5
, base >=4.7 && <5
, bytestring >=0.10.4 && <0.11
, containers >=0.4.2.1 && <0.7
+ , megaparsec >=7.0.0 && <8.0
, mtl >=2.0 && <=2.2.2
, scientific >=0.3.6.2 && <0.4
, text >=1.2.3.0 && <1.3
, transformers >=0.3.0.0 && <0.6
, unordered-containers >=0.2.8.0 && <0.3
+ , uuid >=1.0 && <=1.4
, vector >=0.12.0.1 && <0.13
+ , wai-websockets >=1.0 && <=3.5
+ , websockets >=0.11.0 && <=0.12.5.3
+ default-language: Haskell2010
+
+executable api
+ main-is: Main.hs
+ other-modules:
+ Deprecated.API
+ Deprecated.Model
+ Files
+ Mythology.API
+ Mythology.Character.Deity
+ Mythology.Character.Human
+ Mythology.Place.Places
+ Paths_morpheus_graphql
+ hs-source-dirs:
+ examples
+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , bytestring
+ , containers >=0.4.2.1 && <0.7
+ , megaparsec >=7.0.0 && <8.0
+ , morpheus-graphql
+ , mtl
+ , scientific >=0.3.6.2 && <0.4
+ , scotty
+ , text
+ , transformers >=0.3.0.0 && <0.6
+ , unordered-containers >=0.2.8.0 && <0.3
+ , uuid >=1.0 && <=1.4
+ , vector >=0.12.0.1 && <0.13
+ , wai
+ , wai-websockets >=1.0 && <=3.5
+ , warp
+ , websockets >=0.11.0 && <=0.12.5.3
+ default-language: Haskell2010
+
+test-suite morpheus-test
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Feature.Holistic.API
+ Feature.InputType.API
+ Feature.Schema.A2
+ Feature.Schema.API
+ Feature.UnionType.API
+ Feature.WrappedTypeName.API
+ Lib
+ TestFeature
+ Paths_morpheus_graphql
+ hs-source-dirs:
+ test
+ ghc-options: -Wall
+ build-depends:
+ aeson
+ , base >=4.7 && <5
+ , bytestring >=0.10.4 && <0.11
+ , containers >=0.4.2.1 && <0.7
+ , megaparsec >=7.0.0 && <8.0
+ , morpheus-graphql
+ , mtl >=2.0 && <=2.2.2
+ , scientific >=0.3.6.2 && <0.4
+ , tasty
+ , tasty-hunit
+ , text >=1.2.3.0 && <1.3
+ , transformers >=0.3.0.0 && <0.6
+ , unordered-containers >=0.2.8.0 && <0.3
+ , uuid >=1.0 && <=1.4
+ , vector >=0.12.0.1 && <0.13
+ , wai-websockets >=1.0 && <=3.5
+ , websockets >=0.11.0 && <=0.12.5.3
default-language: Haskell2010
diff --git a/src/Data/Morpheus.hs b/src/Data/Morpheus.hs
--- a/src/Data/Morpheus.hs
+++ b/src/Data/Morpheus.hs
@@ -1,59 +1,6 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-
+-- | Build GraphQL APIs with your favourite functional language!
module Data.Morpheus
- ( interpreter
+ ( Interpreter(..)
) where
-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
-import Data.Aeson (decode, encode)
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Morpheus.Error.Utils (errorMessage, renderErrors)
-import Data.Morpheus.Kind.GQLMutation (GQLMutation (..))
-import Data.Morpheus.Kind.GQLQuery (GQLQuery (..))
-import Data.Morpheus.Parser.Parser (parseGQL, parseLineBreaks)
-import Data.Morpheus.PreProcess.PreProcess (preProcessQuery)
-import Data.Morpheus.Schema.Internal.Types (TypeLib)
-import Data.Morpheus.Types.Error (ResolveIO, failResolveIO)
-import Data.Morpheus.Types.JSType (JSType)
-import Data.Morpheus.Types.Query.Operator (Operator (..))
-import Data.Morpheus.Types.Request (GQLRequest)
-import Data.Morpheus.Types.Response (GQLResponse (..))
-import Data.Morpheus.Types.Types (GQLRoot (..))
-import Data.Text (pack)
-
-schema :: (GQLQuery a, GQLMutation b) => a -> b -> TypeLib
-schema queryRes mutationRes = mutationSchema mutationRes $ querySchema queryRes
-
-resolve :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> GQLRequest -> ResolveIO JSType
-resolve rootResolver body = do
- rootGQL <- ExceptT $ pure (parseGQL body >>= preProcessQuery gqlSchema)
- case rootGQL of
- Query _ _args selection _pos -> encodeQuery queryRes gqlSchema selection
- Mutation _ _args selection _pos -> encodeMutation mutationRes selection
- where
- gqlSchema = schema queryRes mutationRes
- queryRes = query rootResolver
- mutationRes = mutation rootResolver
-
-lineBreaks :: B.ByteString -> [Int]
-lineBreaks req =
- case decode req of
- Just x -> parseLineBreaks x
- Nothing -> []
-
-interpreterRaw :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> B.ByteString -> IO GQLResponse
-interpreterRaw rootResolver request = do
- value <- runExceptT $ parseRequest request >>= resolve rootResolver
- case value of
- Left x -> pure $ Errors $ renderErrors (lineBreaks request) x
- Right x -> pure $ Data x
-
-interpreter :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> B.ByteString -> IO B.ByteString
-interpreter rootResolver request = encode <$> interpreterRaw rootResolver request
-
-parseRequest :: B.ByteString -> ResolveIO GQLRequest
-parseRequest text =
- case decode text of
- Just x -> pure x
- Nothing -> failResolveIO $ errorMessage 0 (pack $ show text)
+import Data.Morpheus.Interpreter (Interpreter (..))
diff --git a/src/Data/Morpheus/Error/Arguments.hs b/src/Data/Morpheus/Error/Arguments.hs
--- a/src/Data/Morpheus/Error/Arguments.hs
+++ b/src/Data/Morpheus/Error/Arguments.hs
@@ -7,11 +7,11 @@
, argumentNameCollision
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (GQLError (..), GQLErrors)
-import Data.Text (Text)
-import qualified Data.Text as T (concat)
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (Position, EnhancedKey (..))
+import Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)
+import Data.Text (Text)
+import qualified Data.Text as T (concat)
{-
ARGUMENTS:
@@ -27,7 +27,7 @@
- experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".",
- date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"."
-}
-argumentGotInvalidValue :: Text -> Text -> Int -> GQLErrors
+argumentGotInvalidValue :: Text -> Text -> Position -> GQLErrors
argumentGotInvalidValue key' inputMessage' position' = errorMessage position' text
where
text = T.concat ["Argument ", key', " got invalid value ;", inputMessage']
@@ -35,14 +35,14 @@
unknownArguments :: Text -> [EnhancedKey] -> GQLErrors
unknownArguments fieldName = map keyToError
where
- keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, posIndex = [pos]}
+ keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, positions = [pos]}
toMessage argName = T.concat ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."]
argumentNameCollision :: [EnhancedKey] -> GQLErrors
argumentNameCollision = map keyToError
where
- keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, posIndex = [pos]}
- toMessage argName = T.concat ["There can Be only One Argument Named \"", argName]
+ keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, positions = [pos]}
+ toMessage argName = T.concat ["There can Be only One Argument Named \"", argName, "\""]
undefinedArgument :: EnhancedKey -> GQLErrors
undefinedArgument (EnhancedKey key' position') = errorMessage position' text
diff --git a/src/Data/Morpheus/Error/Fragment.hs b/src/Data/Morpheus/Error/Fragment.hs
--- a/src/Data/Morpheus/Error/Fragment.hs
+++ b/src/Data/Morpheus/Error/Fragment.hs
@@ -5,11 +5,11 @@
) where
-- import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (GQLError (..), GQLErrors)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..))
+import Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)
--- import Data.Morpheus.Types.MetaInfo (MetaInfo(..))
-import qualified Data.Text as T
+-- import Data.Morpheus.Types.Internal.Base (MetaInfo(..))
+import qualified Data.Text as T
{-
FRAGMENT:
@@ -23,7 +23,7 @@
{...H} -> "Unknown fragment \"H\"."
-}
cannotSpreadWithinItself :: [EnhancedKey] -> GQLErrors
-cannotSpreadWithinItself fragments = [GQLError {desc = text, posIndex = map location fragments}]
+cannotSpreadWithinItself fragments = [GQLError {desc = text, positions = map location fragments}]
where
text =
T.concat
diff --git a/src/Data/Morpheus/Error/Input.hs b/src/Data/Morpheus/Error/Input.hs
--- a/src/Data/Morpheus/Error/Input.hs
+++ b/src/Data/Morpheus/Error/Input.hs
@@ -7,18 +7,19 @@
, InputValidation
) where
-import Data.Aeson (encode)
-import Data.ByteString.Lazy.Char8 (unpack)
-import Data.Morpheus.Types.JSType (JSType)
-import Data.Text (Text)
-import qualified Data.Text as T (concat, intercalate, pack)
+import Data.Aeson (encode)
+import Data.ByteString.Lazy.Char8 (unpack)
+import Data.Morpheus.Types.Internal.Value (Value)
+import Data.Text (Text)
+import qualified Data.Text as T (concat, intercalate, pack)
type InputValidation a = Either InputError a
data InputError
= UnexpectedType [Prop]
Text
- JSType
+ Value
+ (Maybe Text)
| UndefinedField [Prop]
Text
| UnknownField [Prop]
@@ -30,17 +31,28 @@
}
inputErrorMessage :: InputError -> Text
-inputErrorMessage (UnexpectedType path type' jsType) = expectedTypeAFoundB path type' jsType
-inputErrorMessage (UndefinedField path' field') = undefinedField path' field'
-inputErrorMessage (UnknownField path' field') = unknownField path' field'
+inputErrorMessage (UnexpectedType path type' value errorMessage) = expectedTypeAFoundB path type' value errorMessage
+inputErrorMessage (UndefinedField path' field') = undefinedField path' field'
+inputErrorMessage (UnknownField path' field') = unknownField path' field'
pathToText :: [Prop] -> Text
pathToText [] = ""
pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path']
-expectedTypeAFoundB :: [Prop] -> Text -> JSType -> Text
-expectedTypeAFoundB path' expected found =
+expectedTypeAFoundB :: [Prop] -> Text -> Value -> Maybe Text -> Text
+expectedTypeAFoundB path' expected found Nothing =
T.concat [pathToText path', " Expected type \"", expected, "\" found ", T.pack (unpack $ encode found), "."]
+expectedTypeAFoundB path' expected found (Just errorMessage) =
+ T.concat
+ [ pathToText path'
+ , " Expected type \""
+ , expected
+ , "\" found "
+ , T.pack (unpack $ encode found)
+ , "; "
+ , errorMessage
+ , "."
+ ]
undefinedField :: [Prop] -> Text -> Text
undefinedField path' field' = T.concat [pathToText path', " Undefined Field \"", field', "\"."]
diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs
--- a/src/Data/Morpheus/Error/Internal.hs
+++ b/src/Data/Morpheus/Error/Internal.hs
@@ -4,27 +4,32 @@
( internalTypeMismatch
, internalArgumentError
, internalUnknownTypeMessage
+ , internalError
+ , internalErrorT
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Error (GQLErrors)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Text (Text)
-import qualified Data.Text as T (concat, pack)
+import Data.Morpheus.Error.Utils (globalErrorMessage)
+import Data.Morpheus.Types.Internal.Validation (GQLErrors, ResolveT, failResolveT)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Text (Text)
+import qualified Data.Text as T (concat, pack)
-- GQL:: if no mutation defined -> "Schema is not configured for mutations."
-- all kind internal error in development
internalError :: Text -> Either GQLErrors b
-internalError x = Left $ errorMessage 0 $ T.concat ["INTERNAL ERROR: ", x]
+internalError x = Left $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]
+internalErrorT :: Monad m => Text -> ResolveT m b
+internalErrorT x = failResolveT $ globalErrorMessage $ T.concat ["INTERNAL ERROR: ", x]
+
-- if type did not not found, but was defined by Schema
internalUnknownTypeMessage :: Text -> GQLErrors
-internalUnknownTypeMessage x = errorMessage 0 $ T.concat ["type did not not found, but was defined by Schema", x]
+internalUnknownTypeMessage x = globalErrorMessage $ T.concat ["type did not not found, but was defined by Schema", x]
-- if arguments is already validated but has not found required argument
internalArgumentError :: Text -> Either GQLErrors b
internalArgumentError x = internalError $ T.concat ["Argument ", x]
-- if value is already validated but value has different type
-internalTypeMismatch :: Text -> JSType -> Either GQLErrors b
+internalTypeMismatch :: Text -> Value -> Either GQLErrors b
internalTypeMismatch text jsType = internalError $ T.concat ["Type mismatch ", text, T.pack $ show jsType]
diff --git a/src/Data/Morpheus/Error/Mutation.hs b/src/Data/Morpheus/Error/Mutation.hs
--- a/src/Data/Morpheus/Error/Mutation.hs
+++ b/src/Data/Morpheus/Error/Mutation.hs
@@ -4,9 +4,9 @@
( mutationIsNotDefined
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Error (GQLErrors)
-import Data.Morpheus.Types.MetaInfo (Position)
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (GQLErrors)
mutationIsNotDefined :: Position -> GQLErrors
mutationIsNotDefined position' = errorMessage position' "Schema is not configured for mutations."
diff --git a/src/Data/Morpheus/Error/Schema.hs b/src/Data/Morpheus/Error/Schema.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Error/Schema.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Error.Schema
+ ( nameCollisionError
+ , schemaValidationError
+ ) where
+
+import Data.Morpheus.Error.Utils (globalErrorMessage)
+import Data.Morpheus.Types.Internal.Validation (GQLErrors)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+
+schemaValidationError :: Text -> GQLErrors
+schemaValidationError error' = globalErrorMessage $ "Schema Validation Error, " <> error'
+
+nameCollisionError :: Text -> GQLErrors
+nameCollisionError name =
+ schemaValidationError $ "Name collision: \"" <> name <> "\" is used for different dataTypes in two separate modules"
diff --git a/src/Data/Morpheus/Error/Selection.hs b/src/Data/Morpheus/Error/Selection.hs
--- a/src/Data/Morpheus/Error/Selection.hs
+++ b/src/Data/Morpheus/Error/Selection.hs
@@ -8,38 +8,36 @@
, fieldNotResolved
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (GQLError (..), GQLErrors)
-import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position)
-import qualified Data.Text as T (Text, concat)
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position)
+import Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)
+import Data.Text (Text)
+import qualified Data.Text as T (concat)
-fieldNotResolved :: Position -> T.Text -> T.Text -> GQLErrors
+fieldNotResolved :: Position -> Text -> Text -> GQLErrors
fieldNotResolved position' key' message' = errorMessage position' text
where
text = T.concat ["Failure on Resolving Field \"", key', "\": ", message']
-- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."
-hasNoSubfields :: MetaInfo -> GQLErrors
-hasNoSubfields meta = errorMessage (position meta) text
+hasNoSubfields :: Text -> Text -> Position -> GQLErrors
+hasNoSubfields key typeName position = errorMessage position text
where
- text =
- T.concat
- ["Field \"", key meta, "\" must not have a selection since type \"", typeName meta, "\" has no subfields."]
+ text = T.concat ["Field \"", key, "\" must not have a selection since type \"", typeName, "\" has no subfields."]
-cannotQueryField :: MetaInfo -> GQLErrors
-cannotQueryField meta = errorMessage (position meta) text
+cannotQueryField :: Text -> Text -> Position -> GQLErrors
+cannotQueryField key typeName position = errorMessage position text
where
- text = T.concat ["Cannot query field \"", key meta, "\" on type \"", typeName meta, "\"."]
+ text = T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."]
-duplicateQuerySelections :: T.Text -> [EnhancedKey] -> GQLErrors
+duplicateQuerySelections :: Text -> [EnhancedKey] -> GQLErrors
duplicateQuerySelections parentType = map keyToError
where
- keyToError (EnhancedKey key' pos) = GQLError {desc = toMessage key', posIndex = [pos]}
+ keyToError (EnhancedKey key' pos) = GQLError {desc = toMessage key', positions = [pos]}
toMessage key' = T.concat ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."]
-- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?
-subfieldsNotSelected :: MetaInfo -> GQLErrors
-subfieldsNotSelected meta = errorMessage (position meta) text
+subfieldsNotSelected :: Text -> Text -> Position -> GQLErrors
+subfieldsNotSelected key typeName position = errorMessage position text
where
- text = T.concat ["Field \"", key meta, "\" of type \"", typeName meta, "\" must have a selection of subfields"]
+ text = T.concat ["Field \"", key, "\" of type \"", typeName, "\" must have a selection of subfields"]
diff --git a/src/Data/Morpheus/Error/Spread.hs b/src/Data/Morpheus/Error/Spread.hs
--- a/src/Data/Morpheus/Error/Spread.hs
+++ b/src/Data/Morpheus/Error/Spread.hs
@@ -5,11 +5,11 @@
, cannotBeSpreadOnType
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Error (GQLErrors)
-import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position)
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (GQLErrors)
+import Data.Text (Text)
+import qualified Data.Text as T
-- {...H} -> "Unknown fragment \"H\"."
unknownFragment :: Text -> Position -> GQLErrors
@@ -18,16 +18,18 @@
text = T.concat ["Unknown Fragment \"", key', "\"."]
-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."
-cannotBeSpreadOnType :: MetaInfo -> T.Text -> GQLErrors
-cannotBeSpreadOnType spread selectionType = errorMessage (position spread) text
+cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> Text -> GQLErrors
+cannotBeSpreadOnType key' type' position' selectionType' = errorMessage position' text
where
text =
T.concat
- [ "Fragment \""
- , key spread
- , "\" cannot be spread here as objects of type \""
- , typeName spread
+ [ "Fragment"
+ , getName key'
+ , " cannot be spread here as objects of type \""
+ , selectionType'
, "\" can never be of type \""
- , selectionType
+ , type'
, "\"."
]
+ getName (Just x') = T.concat [" \"", x', "\""]
+ getName Nothing = ""
diff --git a/src/Data/Morpheus/Error/Subscription.hs b/src/Data/Morpheus/Error/Subscription.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Error/Subscription.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Error.Subscription
+ ( subscriptionIsNotDefined
+ ) where
+
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (GQLErrors)
+
+subscriptionIsNotDefined :: Position -> GQLErrors
+subscriptionIsNotDefined position' = errorMessage position' "Schema is not configured for subscriptions."
diff --git a/src/Data/Morpheus/Error/Syntax.hs b/src/Data/Morpheus/Error/Syntax.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Error/Syntax.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Error.Syntax
- ( syntaxError
- ) where
-
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Error (GQLErrors)
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Text (Text)
-import qualified Data.Text as T (concat)
-
-
-syntaxError :: Text -> Position -> GQLErrors
-syntaxError e pos = errorMessage pos $ T.concat ["Syntax Error: ", e]
diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs
--- a/src/Data/Morpheus/Error/Utils.hs
+++ b/src/Data/Morpheus/Error/Utils.hs
@@ -1,30 +1,33 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
module Data.Morpheus.Error.Utils
( errorMessage
+ , globalErrorMessage
, renderErrors
+ , badRequestError
) where
-import Data.Morpheus.Types.Error (ErrorLocation (..), GQLError (..), GQLErrors, JSONError (..))
-import Data.Morpheus.Types.MetaInfo (LineBreaks, Position)
-import Data.Text (Text)
+import Data.ByteString.Lazy.Char8 (ByteString, pack)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (ErrorLocation (..), GQLError (..), GQLErrors, JSONError (..))
+import Data.Text (Text)
+import Text.Megaparsec (SourcePos (SourcePos), sourceColumn, sourceLine, unPos)
errorMessage :: Position -> Text -> GQLErrors
-errorMessage pos text = [GQLError {desc = text, posIndex = [pos]}]
+errorMessage position text = [GQLError {desc = text, positions = [position]}]
-renderErrors :: LineBreaks -> [GQLError] -> [JSONError]
-renderErrors x = map (renderError x)
+globalErrorMessage :: Text -> GQLErrors
+globalErrorMessage text = [GQLError {desc = text, positions = []}]
-renderError :: LineBreaks -> GQLError -> JSONError
-renderError lineBreaks internError =
- JSONError {message = desc internError, locations = map (errorLocation lineBreaks) $ posIndex internError}
+renderErrors :: [GQLError] -> [JSONError]
+renderErrors = map renderError
-lineIndexAndNumber :: Position -> LineBreaks -> (Int, Int)
-lineIndexAndNumber position lineBreaks = (length linesBefore + 1, linePos linesBefore)
- where
- linesBefore = filter (position >=) lineBreaks
- linePos [] = 1
- linePos _ = maximum linesBefore + 1
+renderError :: GQLError -> JSONError
+renderError GQLError {desc, positions} = JSONError {message = desc, locations = map toErrorLocation positions}
-errorLocation :: LineBreaks -> Position -> ErrorLocation
-errorLocation lineBreaks pos = do
- let (lineBreaks', position) = lineIndexAndNumber pos lineBreaks
- ErrorLocation lineBreaks' (pos - position)
+toErrorLocation :: Position -> ErrorLocation
+toErrorLocation SourcePos {sourceLine, sourceColumn} =
+ ErrorLocation {line = unPos sourceLine, column = unPos sourceColumn}
+
+badRequestError :: String -> ByteString
+badRequestError aesonError' = pack $ "Bad Request. Could not decode Request body: " ++ aesonError'
diff --git a/src/Data/Morpheus/Error/Variable.hs b/src/Data/Morpheus/Error/Variable.hs
--- a/src/Data/Morpheus/Error/Variable.hs
+++ b/src/Data/Morpheus/Error/Variable.hs
@@ -6,43 +6,34 @@
, variableGotInvalidValue
, uninitializedVariable
, unusedVariables
+ , incompatibleVariableType
) where
-import Data.Morpheus.Error.Utils (errorMessage)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (GQLError (..), GQLErrors)
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Text (Text)
-import qualified Data.Text as T (concat)
- -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",
-
-{-|
-VARIABLES:
-
-Variable -> Error (position Query Head)
- data E = EN | DE
- query M ( $v : E ){...}
-
-
-query Q ($a: D) -> "Unknown type \"D\"."
-
-case String
- - { "v" : "EN" } -> no error converts as enum
+import Data.Morpheus.Error.Utils (errorMessage)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position)
+import Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T (concat)
-case type mismatch
- - { "v": { "a": "v1" ... } } -> "Variable \"$v\" got invalid value { "a": "v1" ... } ; Expected type LANGUAGE."
- - { "v" : "v1" } -> "Variable \"$v\" got invalid value \"v1\"; Expected type LANGUAGE."
- - { "v": 1 } "Variable \"$v\" got invalid value 1; Expected type LANGUAGE."
+-- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."
+incompatibleVariableType :: Text -> Text -> Text -> Position -> GQLErrors
+incompatibleVariableType variableName variableType argType argPosition = errorMessage argPosition text
+ where
+ text =
+ "Variable \"$" <> variableName <> "\" of type \"" <> variableType <> "\" used in position expecting type \"" <>
+ argType <>
+ "\"."
-TODO: variable does not match to argument type
- - query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."
-|-}
-unusedVariables :: [EnhancedKey] -> GQLErrors
-unusedVariables = map keyToError
+-- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",
+unusedVariables :: Text -> [EnhancedKey] -> GQLErrors
+unusedVariables operator' = map keyToError
where
- keyToError (EnhancedKey key' position') = GQLError {desc = text key', posIndex = [position']}
- text key' = T.concat ["Variable \"$", key', "\" is never used in operation \"Query\"."]
+ keyToError (EnhancedKey key' position') = GQLError {desc = text key', positions = [position']}
+ text key' = T.concat ["Variable \"$", key', "\" is never used in operation \"", operator', "\"."]
+-- type mismatch
+-- { "v": 1 } "Variable \"$v\" got invalid value 1; Expected type LANGUAGE."
variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors
variableGotInvalidValue name' inputMessage' position' = errorMessage position' text
where
@@ -58,7 +49,7 @@
where
text = T.concat ["Variable \"", key', "\" is not defined by operation \"", operation', "\"."]
-uninitializedVariable :: Position -> Text -> GQLErrors
-uninitializedVariable position' key' = errorMessage position' text
+uninitializedVariable :: Position -> Text -> Text -> GQLErrors
+uninitializedVariable position' type' key' = errorMessage position' text
where
- text = T.concat ["Value for Variable \"$", key', "\" is not initialized in Query body."]
+ text = T.concat ["Variable \"$", key', "\" of required type \"", type', "!\" was not provided."]
diff --git a/src/Data/Morpheus/Generics/DeriveResolvers.hs b/src/Data/Morpheus/Generics/DeriveResolvers.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Generics/DeriveResolvers.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Generics.DeriveResolvers
- ( DeriveResolvers(..)
- , resolveBySelection
- ) where
-
-import Data.Maybe (fromMaybe)
-import Data.Morpheus.Types.Error (ResolveIO)
-import Data.Morpheus.Types.JSType (JSType (..))
-import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..))
-import Data.Morpheus.Types.Query.Selection (Selection)
-import qualified Data.Text as T
-import GHC.Generics
-
--- type D1 = M1 D
--- type C1 = M1 C
--- type S1 = M1 S
--- M1 : Meta-information (constructor names, etc.)
--- D :Datatype : Class for dataTypes that represent dataTypes
--- C :Constructor :
--- S - Selector: Class for dataTypes that represent records
--- Rep = D1 (...) (C1 ...) (S1 (...) :+: D1 (...) (C1 ...) (S1 (...)
-unwrapMonadTuple :: Monad m => (T.Text, m a) -> m (T.Text, a)
-unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x)
-
-selectResolver ::
- [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> (T.Text, Selection) -> ResolveIO (T.Text, JSType)
-selectResolver x (key, gql) = unwrapMonadTuple (key, (fromMaybe (\_ -> pure JSNull) $ lookup key x) (key, gql))
-
-resolveBySelection :: [(T.Text, Selection)] -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> ResolveIO JSType
-resolveBySelection selection resolvers = JSObject <$> mapM (selectResolver resolvers) selection
-
-class DeriveResolvers f where
- deriveResolvers :: Meta.MetaInfo -> f a -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)]
-
-instance DeriveResolvers U1 where
- deriveResolvers _ _ = []
-
-instance (Selector s, DeriveResolvers f) => DeriveResolvers (M1 S s f) where
- deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.key = T.pack $ selName m}) src
-
-instance (Datatype c, DeriveResolvers f) => DeriveResolvers (M1 D c f) where
- deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.typeName = T.pack $ datatypeName m}) src
-
-instance (Constructor c, DeriveResolvers f) => DeriveResolvers (M1 C c f) where
- deriveResolvers meta (M1 src) = deriveResolvers meta src
-
-instance (DeriveResolvers f, DeriveResolvers g) => DeriveResolvers (f :*: g) where
- deriveResolvers meta (a :*: b) = deriveResolvers meta a ++ deriveResolvers meta b
diff --git a/src/Data/Morpheus/Generics/GDecode.hs b/src/Data/Morpheus/Generics/GDecode.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Generics/GDecode.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Generics.GDecode
- ( GDecode(..)
- ) where
-
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.MetaInfo
-import qualified Data.Text as T
-import GHC.Generics
-
-fixProxy :: (a -> f a) -> f a
-fixProxy f = f undefined
-
-class GDecode i f where
- gDecode :: MetaInfo -> i -> Validation (f a)
-
-instance GDecode i U1 where
- gDecode _ _ = pure U1
-
-instance (Selector c, GDecode i f) => GDecode i (M1 S c f) where
- gDecode meta gql = fixProxy (\x -> M1 <$> gDecode (meta {key = T.pack $ selName x}) gql)
-
-instance (Datatype c, GDecode i f) => GDecode i (M1 D c f) where
- gDecode meta gql = fixProxy (\x -> M1 <$> gDecode (meta {typeName = T.pack $ datatypeName x}) gql)
-
-instance GDecode i f => GDecode i (M1 C c f) where
- gDecode meta gql = M1 <$> gDecode meta gql
-
-instance (GDecode i f, GDecode i g) => GDecode i (f :*: g) where
- gDecode meta gql = (:*:) <$> gDecode meta gql <*> gDecode meta gql
diff --git a/src/Data/Morpheus/Generics/GDecodeEnum.hs b/src/Data/Morpheus/Generics/GDecodeEnum.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Generics/GDecodeEnum.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Generics.GDecodeEnum
- ( GDecodeEnum(..)
- ) where
-
-import Data.Proxy (Proxy (..))
-import qualified Data.Text as T
-import GHC.Generics
-
-class GDecodeEnum f where
- gToEnum :: T.Text -> f a
- tagName :: Proxy f -> T.Text
- getTags :: Proxy f -> [T.Text]
-
-instance (Datatype c, GDecodeEnum f) => GDecodeEnum (M1 D c f) where
- gToEnum = M1 . gToEnum
- tagName _ = ""
- getTags _ = getTags (Proxy :: Proxy f)
-
-instance (Constructor c) => GDecodeEnum (M1 C c U1) where
- gToEnum _ = M1 U1
- tagName _ = T.pack $ conName (undefined :: (M1 C c U1 x))
- getTags proxy = [tagName proxy]
-
-instance (GDecodeEnum a, GDecodeEnum b) => GDecodeEnum (a :+: b) where
- gToEnum name =
- if tagName (Proxy @a) == name
- then L1 $ gToEnum name
- else R1 $ gToEnum name
- tagName _ = ""
- getTags _ = getTags (Proxy @a) ++ getTags (Proxy @b)
diff --git a/src/Data/Morpheus/Generics/TypeRep.hs b/src/Data/Morpheus/Generics/TypeRep.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Generics/TypeRep.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Generics.TypeRep
- ( Selectors(..)
- , resolveTypes
- ) where
-
-import Data.Morpheus.Schema.Internal.Types (TypeLib)
-import Data.Proxy (Proxy (..))
-import GHC.Generics
-
-shift :: a -> (a -> b) -> b
-shift x y = y x
-
-resolveTypes :: TypeLib -> [TypeLib -> TypeLib] -> TypeLib
-resolveTypes = foldl shift
-
-class Selectors rep t where
- getFields :: Proxy rep -> [(t, TypeLib -> TypeLib)]
-
-instance Selectors f t => Selectors (M1 D x f) t where
- getFields _ = getFields (Proxy @f)
-
-instance Selectors f t => Selectors (M1 C x f) t where
- getFields _ = getFields (Proxy @f)
-
-instance (Selectors a t, Selectors b t) => Selectors (a :*: b) t where
- getFields _ = getFields (Proxy @a) ++ getFields (Proxy @b)
-
-instance Selectors U1 t where
- getFields _ = []
diff --git a/src/Data/Morpheus/Generics/Utils.hs b/src/Data/Morpheus/Generics/Utils.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Generics/Utils.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-module Data.Morpheus.Generics.Utils
- ( typeOf
- , SelOf
- , RecSel
- ) where
-
-import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon)
-import Data.Proxy (Proxy)
-import Data.Text (Text, pack)
-import GHC.Generics
-
-typeOf :: Typeable a => Proxy a -> Text
-typeOf = pack . tyConName . typeRepTyCon . typeRep
-
-type SelOf s = M1 S s (Rec0 ()) ()
-
-type RecSel s a = M1 S s (Rec0 a)
diff --git a/src/Data/Morpheus/Interpreter.hs b/src/Data/Morpheus/Interpreter.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Interpreter.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Morpheus.Interpreter
+ ( Interpreter(..)
+ ) where
+
+import Data.Aeson (encode)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB (ByteString, fromStrict, toStrict)
+import Data.Morpheus.Resolve.Operator (RootResCon)
+import Data.Morpheus.Resolve.Resolve (packStream, resolve, resolveByteString, resolveStream,
+ resolveStreamByteString)
+import Data.Morpheus.Server.ClientRegister (GQLState)
+import Data.Morpheus.Types.Internal.WebSocket (OutputAction)
+import Data.Morpheus.Types.IO (GQLRequest, GQLResponse)
+import Data.Morpheus.Types.Resolver (GQLRootResolver (..))
+import Data.Text (Text)
+import qualified Data.Text.Lazy as LT (Text, fromStrict, toStrict)
+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
+
+-- | main query processor and resolver
+-- possible versions of interpreter
+--
+-- 1. with effect and state: where 'GQLState' is State Monad of subscriptions
+--
+-- @
+-- k :: GQLState -> a -> IO a
+-- @
+--
+-- 2. without effect and state: stateless query processor without any effect,
+-- if you don't need any subscription use this one , is simple and fast
+--
+-- @
+-- k :: a -> IO a
+-- -- or
+-- k :: GQLRequest -> IO GQLResponse
+-- @
+class Interpreter k m where
+ interpreter ::
+ Monad m
+ => (RootResCon m a b c) =>
+ GQLRootResolver m a b c -> k
+
+{-
+ simple HTTP stateless Interpreter without side effects
+-}
+type StateLess m a = a -> m a
+
+instance Interpreter (GQLRequest -> m GQLResponse) m where
+ interpreter = resolve
+
+instance Interpreter (StateLess m LB.ByteString) m where
+ interpreter = resolveByteString
+
+instance Interpreter (StateLess m LT.Text) m where
+ interpreter root request = decodeUtf8 <$> interpreter root (encodeUtf8 request)
+
+instance Interpreter (StateLess m ByteString) m where
+ interpreter root request = LB.toStrict <$> interpreter root (LB.fromStrict request)
+
+instance Interpreter (StateLess m Text) m where
+ interpreter root request = LT.toStrict <$> interpreter root (LT.fromStrict request)
+
+{-
+ HTTP Interpreter with state and side effects, every mutation will
+ trigger subscriptions in shared `GQLState`
+-}
+type WSPub m a = GQLState -> a -> m a
+
+instance Interpreter (WSPub IO LB.ByteString) IO where
+ interpreter root state = packStream state (resolveStreamByteString root)
+
+instance Interpreter (WSPub IO LT.Text) IO where
+ interpreter root state request = decodeUtf8 <$> interpreter root state (encodeUtf8 request)
+
+instance Interpreter (WSPub IO ByteString) IO where
+ interpreter root state request = LB.toStrict <$> interpreter root state (LB.fromStrict request)
+
+instance Interpreter (WSPub IO Text) IO where
+ interpreter root state request = LT.toStrict <$> interpreter root state (LT.fromStrict request)
+
+{-
+ Websocket Interpreter without state and side effects, mutations and subscription will return Actions
+ that will be executed in Websocket server
+-}
+type WSSub m a = a -> m (OutputAction m a)
+
+instance Interpreter (GQLRequest -> m (OutputAction m LB.ByteString)) m where
+ interpreter root request = fmap encode <$> resolveStream root request
+
+instance Interpreter (WSSub m LB.ByteString) m where
+ interpreter = resolveStreamByteString
+
+instance Interpreter (WSSub m LT.Text) m where
+ interpreter root request = fmap decodeUtf8 <$> interpreter root (encodeUtf8 request)
+
+instance Interpreter (WSSub m ByteString) m where
+ interpreter root request = fmap LB.toStrict <$> interpreter root (LB.fromStrict request)
+
+instance Interpreter (WSSub m Text) m where
+ interpreter root request = fmap LT.toStrict <$> interpreter root (LT.fromStrict request)
diff --git a/src/Data/Morpheus/Kind.hs b/src/Data/Morpheus/Kind.hs
--- a/src/Data/Morpheus/Kind.hs
+++ b/src/Data/Morpheus/Kind.hs
@@ -1,19 +1,64 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | associating types to GraphQL Kinds
module Data.Morpheus.Kind
- ( GQLObject
- , GQLKind(description)
- , GQLQuery
- , GQLArgs
- , GQLInput
- , GQLEnum
- , GQLMutation
- , GQLScalar(..)
+ ( SCALAR
+ , OBJECT
+ , ENUM
+ , WRAPPER
+ , UNION
+ , INPUT_OBJECT
+ , KIND
) where
-import Data.Morpheus.Kind.GQLArgs (GQLArgs)
-import Data.Morpheus.Kind.GQLEnum (GQLEnum)
-import Data.Morpheus.Kind.GQLInput (GQLInput)
-import Data.Morpheus.Kind.GQLKind (GQLKind (description))
-import Data.Morpheus.Kind.GQLMutation (GQLMutation (..))
-import Data.Morpheus.Kind.GQLObject (GQLObject)
-import Data.Morpheus.Kind.GQLQuery (GQLQuery (..))
-import Data.Morpheus.Kind.GQLScalar (GQLScalar (parseValue, serialize))
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Text (Text)
+
+-- MORPHEUS
+import Data.Morpheus.Types.Resolver (Resolver)
+
+-- | Type Family to associate type to GraphQL Kind
+type family KIND a :: *
+
+-- | GraphQL Scalar: Int, Float, String, Boolean or any user defined custom Scalar type
+data SCALAR
+
+-- | GraphQL Object
+data OBJECT
+
+-- | GraphQL Enum
+data ENUM
+
+-- | GraphQL input Object
+data INPUT_OBJECT
+
+-- | GraphQL Union
+data UNION
+
+-- | GraphQL Arrays , Resolvers and NonNull fields
+data WRAPPER
+
+-- default Type Instances
+type instance KIND Text = SCALAR
+
+type instance KIND Int = SCALAR
+
+type instance KIND Float = SCALAR
+
+type instance KIND Bool = SCALAR
+
+type instance KIND (Maybe a) = WRAPPER
+
+type instance KIND [a] = WRAPPER
+
+type instance KIND (a, b) = WRAPPER
+
+type instance KIND (Set a) = WRAPPER
+
+type instance KIND (Map k v) = WRAPPER
+
+type instance KIND (Resolver m a) = WRAPPER
+
+type instance KIND (a -> b) = WRAPPER
diff --git a/src/Data/Morpheus/Kind/GQLArgs.hs b/src/Data/Morpheus/Kind/GQLArgs.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLArgs.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Morpheus.Kind.GQLArgs
- ( GQLArgs(..)
- ) where
-
-import Data.Morpheus.Error.Internal (internalArgumentError)
-import Data.Morpheus.Generics.GDecode (GDecode (..))
-import Data.Morpheus.Generics.TypeRep (Selectors (..))
-import Data.Morpheus.Generics.Utils (RecSel, SelOf)
-import qualified Data.Morpheus.Kind.GQLInput as I (GQLInput (..))
-import Data.Morpheus.Schema.Internal.Types (InputField, TypeLib)
-import Data.Morpheus.Schema.Type (DeprecationArgs)
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.MetaInfo (MetaInfo (..), initialMeta)
-import Data.Morpheus.Types.Query.Selection (Argument (..), Arguments)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text, pack)
-import GHC.Generics
-
-instance (Selector s, I.GQLInput a) => Selectors (RecSel s a) (Text, InputField) where
- getFields _ = [((name, I.asArgument (Proxy @a) name), I.introInput (Proxy @a))]
- where
- name = pack $ selName (undefined :: SelOf s)
-
-instance I.GQLInput a => GDecode Arguments (K1 i a) where
- gDecode meta args =
- case lookup (key meta) args of
- Nothing -> internalArgumentError "Required Argument Not Found"
- Just (Argument x _pos) -> K1 <$> I.decode x
-
-class GQLArgs p where
- decode :: Arguments -> Validation p
- default decode :: (Generic p, GDecode Arguments (Rep p)) =>
- Arguments -> Validation p
- decode args = to <$> gDecode initialMeta args
- introspect :: Proxy p -> [((Text, InputField), TypeLib -> TypeLib)]
- default introspect :: Selectors (Rep p) (Text, InputField) =>
- Proxy p -> [((Text, InputField), TypeLib -> TypeLib)]
- introspect _ = getFields (Proxy @(Rep p))
-
-instance GQLArgs () where
- decode _ = pure ()
- introspect _ = []
-
-instance GQLArgs DeprecationArgs
diff --git a/src/Data/Morpheus/Kind/GQLEnum.hs b/src/Data/Morpheus/Kind/GQLEnum.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLEnum.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Morpheus.Kind.GQLEnum
- ( GQLEnum(..)
- ) where
-
-import Data.Morpheus.Generics.GDecodeEnum (GDecodeEnum (..))
-import Data.Morpheus.Kind.GQLKind (GQLKind (..), enumTypeOf)
-import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation)
-import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib)
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Proxy (Proxy (..))
-import Data.Text (Text)
-import GHC.Generics
-
-class GQLEnum a where
- decode :: Text -> a
- default decode :: (Generic a, GDecodeEnum (Rep a)) =>
- Text -> a
- decode text = to $ gToEnum text
- asInputField :: Proxy a -> Text -> InputField
- default asInputField :: GQLKind a =>
- Proxy a -> Text -> InputField
- asInputField proxy = InputField . asField proxy
- asField :: Proxy a -> Text -> Field
- default asField :: GQLKind a =>
- Proxy a -> Text -> Field
- asField proxy name = Field {fieldName = name, notNull = True, kind = ENUM, fieldType = typeID proxy, asList = False}
- introspect :: Proxy a -> TypeLib -> TypeLib
- default introspect :: (GQLKind a, GDecodeEnum (Rep a)) =>
- Proxy a -> TypeLib -> TypeLib
- introspect = updateLib (enumTypeOf $ getTags (Proxy @(Rep a))) []
-
-instance GQLEnum TypeKind
-
-instance GQLEnum DirectiveLocation
diff --git a/src/Data/Morpheus/Kind/GQLInput.hs b/src/Data/Morpheus/Kind/GQLInput.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLInput.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Data.Morpheus.Kind.GQLInput
- ( GQLInput(..)
- ) where
-
-import Data.Morpheus.Error.Internal (internalArgumentError, internalTypeMismatch)
-import Data.Morpheus.Generics.GDecode (GDecode (..))
-import Data.Morpheus.Generics.TypeRep (Selectors (..))
-import qualified Data.Morpheus.Kind.GQLEnum as E (GQLEnum (..))
-import Data.Morpheus.Kind.GQLKind (GQLKind (..), inputObjectOf, introspectScalar)
-import qualified Data.Morpheus.Kind.GQLScalar as S (GQLScalar (..))
-import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib)
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Types.Describer (EnumOf (..), ScalarOf (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..))
-import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..), initialMeta)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text)
-import GHC.Generics
-
-instance GQLInput a => GDecode JSType (K1 i a) where
- gDecode meta (JSObject object) =
- case lookup (Meta.key meta) object of
- Nothing -> internalArgumentError "Missing Argument"
- Just value -> K1 <$> decode value
- gDecode _ isType = internalTypeMismatch "InputObject" isType
-
-class GQLInput a where
- decode :: JSType -> Validation a
- default decode :: (Generic a, GDecode JSType (Rep a)) =>
- JSType -> Validation a
- decode (JSObject x) = to <$> gDecode Meta.initialMeta (JSObject x)
- decode isType = internalTypeMismatch "InputObject" isType
- asArgument :: Proxy a -> Text -> InputField
- default asArgument :: GQLKind a =>
- Proxy a -> Text -> InputField
- asArgument proxy name =
- InputField $ Field {fieldName = name, notNull = True, asList = False, kind = INPUT_OBJECT, fieldType = typeID proxy}
- introInput :: Proxy a -> TypeLib -> TypeLib
- default introInput :: (GQLKind a, Selectors (Rep a) (Text, InputField)) =>
- Proxy a -> TypeLib -> TypeLib
- introInput = updateLib (inputObjectOf fields) stack
- where
- fieldTypes = getFields (Proxy @(Rep a))
- stack = map snd fieldTypes
- fields = map fst fieldTypes
-
-inputFieldOf :: GQLKind a => Proxy a -> Text -> InputField
-inputFieldOf proxy name =
- InputField $ Field {fieldName = name, asList = False, notNull = True, kind = SCALAR, fieldType = typeID proxy}
-
-instance GQLInput Text where
- decode (Scalar (String x)) = pure x
- decode isType = internalTypeMismatch "String" isType
- asArgument = inputFieldOf
- introInput = introspectScalar
-
-instance GQLInput Bool where
- decode (Scalar (Boolean x)) = pure x
- decode isType = internalTypeMismatch "Boolean" isType
- asArgument = inputFieldOf
- introInput = introspectScalar
-
-instance GQLInput Int where
- decode (Scalar (Int x)) = pure x
- decode isType = internalTypeMismatch "Int" isType
- asArgument = inputFieldOf
- introInput = introspectScalar
-
-instance GQLInput Float where
- decode (Scalar (Float x)) = pure x
- decode isType = internalTypeMismatch "Int" isType
- asArgument = inputFieldOf
- introInput = introspectScalar
-
-instance (GQLInput a, GQLKind a) => GQLInput (Maybe a) where
- decode JSNull = pure Nothing
- decode x = Just <$> decode x
- asArgument _ name = InputField $ setNullable $ unpackInputField $ asArgument (Proxy @a) name
- where
- setNullable :: Field -> Field
- setNullable x = x {notNull = False}
- introInput _ typeLib = typeLib
-
-instance (E.GQLEnum a, GQLKind a) => GQLInput (EnumOf a) where
- decode (JSEnum text) = pure $ EnumOf (E.decode text)
- decode isType = internalTypeMismatch "Enum" isType
- asArgument _ = E.asInputField (Proxy @a)
- introInput _ = E.introspect (Proxy @a)
-
-instance (S.GQLScalar a, GQLKind a) => GQLInput (ScalarOf a) where
- decode text = ScalarOf <$> S.decode text
- asArgument _ = S.asInputField (Proxy @a)
- introInput _ = S.introspect (Proxy @a)
-
-instance (GQLInput a, GQLKind a) => GQLInput [a] where
- decode (JSList li) = mapM decode li
- decode isType = internalTypeMismatch "List" isType
- asArgument _ = asArgument (Proxy @a)
- introInput _ = introInput (Proxy @a) -- TODO: wrap as List
diff --git a/src/Data/Morpheus/Kind/GQLKind.hs b/src/Data/Morpheus/Kind/GQLKind.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLKind.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
-module Data.Morpheus.Kind.GQLKind
- ( GQLKind(..)
- , scalarTypeOf
- , asObjectType
- , enumTypeOf
- , inputObjectOf
- , introspectScalar
- ) where
-
-import Data.Morpheus.Generics.TypeRep (resolveTypes)
-import Data.Morpheus.Generics.Utils (typeOf)
-import Data.Morpheus.Schema.Directive (Directive)
-import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation)
-import Data.Morpheus.Schema.EnumValue (EnumValue)
-import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), InputField, Leaf (..), LibType (..),
- ObjectField (..), TypeLib, defineType, isTypeDefined)
-import Data.Morpheus.Schema.Schema (Schema)
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Schema.Utils.Utils (Field, InputValue, Type)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text)
-import Data.Typeable (Typeable)
-
-scalarTypeOf :: GQLKind a => Proxy a -> LibType
-scalarTypeOf = Leaf . LScalar . buildType
-
-enumTypeOf :: GQLKind a => [Text] -> Proxy a -> LibType
-enumTypeOf tags = Leaf . LEnum tags . buildType
-
-asObjectType :: GQLKind a => [(Text, ObjectField)] -> Proxy a -> LibType
-asObjectType fields = OutputObject . GObject fields . buildType
-
-inputObjectOf :: GQLKind a => [(Text, InputField)] -> Proxy a -> LibType
-inputObjectOf inputFields = InputObject . GObject inputFields . buildType
-
-introspectScalar :: GQLKind a => Proxy a -> TypeLib -> TypeLib
-introspectScalar = updateLib scalarTypeOf []
-
-class GQLKind a where
- description :: Proxy a -> Text
- description _ = "default selection Description"
- typeID :: Proxy a -> Text
- default typeID :: Typeable a =>
- Proxy a -> Text
- typeID = typeOf
- buildType :: Proxy a -> Core
- buildType proxy = Core {name = typeID proxy, typeDescription = description proxy}
- updateLib :: (Proxy a -> LibType) -> [TypeLib -> TypeLib] -> Proxy a -> TypeLib -> TypeLib
- updateLib typeBuilder stack proxy lib' =
- if isTypeDefined (typeID proxy) lib'
- then lib'
- else resolveTypes lib' (defineType (typeID proxy, typeBuilder proxy) : stack)
-
-instance GQLKind EnumValue where
- typeID _ = "__EnumValue"
-
-instance GQLKind Type where
- typeID _ = "__Type"
-
-instance GQLKind Field where
- typeID _ = "__Field"
-
-instance GQLKind InputValue where
- typeID _ = "__InputValue"
-
-instance GQLKind Schema where
- typeID _ = "__Schema"
-
-instance GQLKind Directive where
- typeID _ = "__Directive"
-
-instance GQLKind TypeKind where
- typeID _ = "__TypeKind"
-
-instance GQLKind DirectiveLocation where
- typeID _ = "__DirectiveLocation"
-
-instance GQLKind Int where
- typeID _ = "Int"
-
-instance GQLKind Float where
- typeID _ = "Int"
-
-instance GQLKind Text where
- typeID _ = "String"
-
-instance GQLKind Bool where
- typeID _ = "Boolean"
-
-instance GQLKind a => GQLKind (Maybe a) where
- typeID _ = typeID (Proxy @a)
diff --git a/src/Data/Morpheus/Kind/GQLMutation.hs b/src/Data/Morpheus/Kind/GQLMutation.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLMutation.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Kind.GQLMutation
- ( GQLMutation(..)
- ) where
-
-import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection)
-import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes)
-import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField, TypeLib (..))
-import Data.Morpheus.Types.Error (ResolveIO)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Morpheus.Types.MetaInfo (initialMeta)
-import Data.Morpheus.Types.Query.Selection (SelectionSet)
-import Data.Proxy
-import Data.Text (Text)
-import GHC.Generics
-
-class GQLMutation a where
- encodeMutation :: a -> SelectionSet -> ResolveIO JSType
- default encodeMutation :: (Generic a, DeriveResolvers (Rep a)) =>
- a -> SelectionSet -> ResolveIO JSType
- encodeMutation rootResolver sel = resolveBySelection sel $ deriveResolvers initialMeta $ from rootResolver
- mutationSchema :: a -> TypeLib -> TypeLib
- default mutationSchema :: (Selectors (Rep a) (Text, ObjectField)) =>
- a -> TypeLib -> TypeLib
- mutationSchema _ initialType = resolveTypes mutationType types
- where
- mutationType = initialType {mutation = Just ("Mutation", GObject fields $ Core "Mutation" "Description")}
- fieldTypes = getFields (Proxy :: Proxy (Rep a))
- types = map snd fieldTypes
- fields = map fst fieldTypes
-
-instance GQLMutation () where
- encodeMutation _ _ = pure JSNull
- mutationSchema _ = id
diff --git a/src/Data/Morpheus/Kind/GQLObject.hs b/src/Data/Morpheus/Kind/GQLObject.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLObject.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Kind.GQLObject
- ( GQLObject(..)
- ) where
-
-import Control.Monad.Trans (lift)
-import Control.Monad.Trans.Except
-import Data.Morpheus.Error.Selection (fieldNotResolved, subfieldsNotSelected)
-import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection)
-import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes)
-import Data.Morpheus.Generics.Utils (RecSel, SelOf)
-import qualified Data.Morpheus.Kind.GQLArgs as Args (GQLArgs (..))
-import qualified Data.Morpheus.Kind.GQLEnum as E (GQLEnum (..))
-import Data.Morpheus.Kind.GQLKind (GQLKind (..), asObjectType, introspectScalar)
-import qualified Data.Morpheus.Kind.GQLScalar as S (GQLScalar (..))
-import Data.Morpheus.Schema.Directive (Directive)
-import Data.Morpheus.Schema.EnumValue (EnumValue)
-import Data.Morpheus.Schema.Internal.Types (ObjectField (..), TypeLib)
-import qualified Data.Morpheus.Schema.Internal.Types as I (Field (..))
-import Data.Morpheus.Schema.Schema (Schema)
-import Data.Morpheus.Schema.Type (DeprecationArgs)
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Schema.Utils.Utils (Field, InputValue, Type)
-import Data.Morpheus.Types.Describer ((::->) (..), EnumOf (..), ScalarOf (..),
- WithDeprecationArgs (..))
-import Data.Morpheus.Types.Error (ResolveIO, failResolveIO)
-import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..))
-import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..), initialMeta)
-import Data.Morpheus.Types.Query.Selection (Selection (..))
-import Data.Proxy
-import Data.Text (Text, pack)
-import GHC.Generics
-
-instance GQLObject a => DeriveResolvers (K1 i a) where
- deriveResolvers meta (K1 src) = [(Meta.key meta, (`encode` src))]
-
-instance (Selector s, GQLObject a) => Selectors (RecSel s a) (Text, ObjectField) where
- getFields _ = [((name, fieldType (Proxy @a) name), introspect (Proxy @a))]
- where
- name = pack $ selName (undefined :: SelOf s)
-
-class GQLObject a where
- encode :: (Text, Selection) -> a -> ResolveIO JSType
- default encode :: (Generic a, DeriveResolvers (Rep a)) =>
- (Text, Selection) -> a -> ResolveIO JSType
- encode (_, SelectionSet _ selection _pos) = resolveBySelection selection . deriveResolvers Meta.initialMeta . from
- encode (_, Field _ key pos) = const $ failResolveIO $ subfieldsNotSelected meta -- TODO: must be internal Error
- where
- meta = Meta.MetaInfo {Meta.typeName = "", Meta.key = key, Meta.position = pos}
- fieldType :: Proxy a -> Text -> ObjectField
- default fieldType :: (Selectors (Rep a) (Text, ObjectField), GQLKind a) =>
- Proxy a -> Text -> ObjectField
- fieldType proxy name =
- ObjectField [] $
- I.Field {I.fieldName = name, I.notNull = True, I.asList = False, I.kind = OBJECT, I.fieldType = typeID proxy}
- introspect :: Proxy a -> TypeLib -> TypeLib
- default introspect :: (Selectors (Rep a) (Text, ObjectField), GQLKind a) =>
- Proxy a -> TypeLib -> TypeLib
- introspect = updateLib (asObjectType fields) stack
- where
- fieldTypes = getFields (Proxy @(Rep a))
- fields = map fst fieldTypes
- stack = map snd fieldTypes
-
-liftResolver :: Int -> Text -> IO (Either String a) -> ResolveIO a
-liftResolver position' typeName' x = do
- result <- lift x
- case result of
- Left message' -> failResolveIO $ fieldNotResolved position' typeName' (pack message')
- Right value -> pure value
-
-instance (GQLObject a, Args.GQLArgs p) => GQLObject (p ::-> a) where
- encode (key', SelectionSet gqlArgs body position') (Resolver resolver) =
- (ExceptT $ pure $ Args.decode gqlArgs) >>= liftResolver position' key' . resolver >>=
- encode (key', SelectionSet gqlArgs body position')
- encode (key', Field gqlArgs field position') (Resolver resolver) =
- (ExceptT $ pure $ Args.decode gqlArgs) >>= liftResolver position' key' . resolver >>=
- encode (key', Field gqlArgs field position')
- introspect _ typeLib = resolveTypes typeLib $ args' ++ fields
- where
- args' = map snd $ Args.introspect (Proxy @p)
- fields = [introspect (Proxy @a)]
- fieldType _ name = (fieldType (Proxy @a) name) {args = map fst $ Args.introspect (Proxy @p)}
-
--- manual deriving of DeprecationArgs ::-> a
-instance GQLObject a => GQLObject (WithDeprecationArgs a) where
- encode sel (WithDeprecationArgs val) = encode sel val
- introspect _ typeLib = resolveTypes typeLib $ args' ++ fields
- where
- args' = map snd $ Args.introspect (Proxy @DeprecationArgs)
- fields = [introspect (Proxy @a)]
- fieldType _ name = (fieldType (Proxy @a) name) {args = map fst $ Args.introspect (Proxy @DeprecationArgs)}
-
-instance GQLObject a => GQLObject (Maybe a) where
- encode _ Nothing = pure JSNull
- encode query (Just value) = encode query value
- introspect _ = introspect (Proxy @a)
- fieldType _ name = (fType name) {fieldContent = (fieldContent $ fType name) {I.notNull = False}}
- where
- fType = fieldType (Proxy @a)
-
-scalarField :: GQLKind a => Proxy a -> Text -> ObjectField
-scalarField proxy name =
- ObjectField
- []
- I.Field {I.fieldName = name, I.notNull = True, I.asList = False, I.kind = SCALAR, I.fieldType = typeID proxy}
-
-instance GQLObject Int where
- encode _ = pure . Scalar . Int
- introspect = introspectScalar
- fieldType = scalarField
-
-instance GQLObject Float where
- encode _ = pure . Scalar . Float
- introspect = introspectScalar
- fieldType = scalarField
-
-instance GQLObject Text where
- encode _ = pure . Scalar . String
- introspect = introspectScalar
- fieldType = scalarField
-
-instance GQLObject Bool where
- encode _ = pure . Scalar . Boolean
- introspect = introspectScalar
- fieldType = scalarField
-
-instance GQLObject a => GQLObject [a] where
- encode (_, Field {}) _ = pure $ JSList []
- encode query list = JSList <$> mapM (encode query) list
- introspect _ = introspect (Proxy @a)
- fieldType _ name = fType {fieldContent = (fieldContent fType) {I.asList = True}}
- where
- fType = fieldType (Proxy @a) name
-
-instance (Show a, GQLKind a, E.GQLEnum a) => GQLObject (EnumOf a) where
- encode _ = pure . Scalar . String . pack . show . unpackEnum
- fieldType _ = ObjectField [] . E.asField (Proxy @a)
- introspect _ = E.introspect (Proxy @a)
-
-instance S.GQLScalar a => GQLObject (ScalarOf a) where
- encode _ (ScalarOf x) = pure $ Scalar $ S.serialize x
- fieldType _ = ObjectField [] . S.asField (Proxy @a)
- introspect _ = S.introspect (Proxy @a)
-
-instance GQLObject EnumValue
-
-instance GQLObject Type
-
-instance GQLObject Field
-
-instance GQLObject InputValue
-
-instance GQLObject Schema
-
-instance GQLObject Directive
diff --git a/src/Data/Morpheus/Kind/GQLQuery.hs b/src/Data/Morpheus/Kind/GQLQuery.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLQuery.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Kind.GQLQuery
- ( GQLQuery(..)
- ) where
-
-import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection)
-import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes)
-import Data.Morpheus.Kind.GQLObject (GQLObject (..))
-import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField, TypeLib, initTypeLib)
-import Data.Morpheus.Schema.Schema (Schema, initSchema)
-import Data.Morpheus.Types.Error (ResolveIO)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Morpheus.Types.MetaInfo (initialMeta)
-import Data.Morpheus.Types.Query.Selection (SelectionSet)
-import Data.Proxy
-import Data.Text (Text)
-import GHC.Generics
-
-class GQLQuery a where
- encodeQuery :: a -> TypeLib -> SelectionSet -> ResolveIO JSType
- default encodeQuery :: (Generic a, DeriveResolvers (Rep a)) =>
- a -> TypeLib -> SelectionSet -> ResolveIO JSType
- encodeQuery rootResolver types sel = resolveBySelection sel (schemaResolver ++ resolvers)
- where
- schemaResolver = [("__schema", (`encode` initSchema types))]
- resolvers = deriveResolvers initialMeta $ from rootResolver
- querySchema :: a -> TypeLib
- default querySchema :: (Selectors (Rep a) (Text, ObjectField)) =>
- a -> TypeLib
- querySchema _ = resolveTypes typeLib stack
- where
- typeLib = introspect (Proxy @Schema) queryType
- queryType = initTypeLib ("Query", GObject fields (Core "Query" "Description"))
- fieldTypes = getFields (Proxy @(Rep a))
- stack = map snd fieldTypes
- fields = map fst fieldTypes
diff --git a/src/Data/Morpheus/Kind/GQLScalar.hs b/src/Data/Morpheus/Kind/GQLScalar.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Kind/GQLScalar.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Kind.GQLScalar where
-
-import Control.Monad ((>=>))
-import Data.Morpheus.Error.Internal (internalTypeMismatch)
-import Data.Morpheus.Kind.GQLKind (GQLKind (..), scalarTypeOf)
-import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib)
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Types.Core (Key)
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..))
-import Data.Proxy (Proxy (..))
-
-toScalar :: JSType -> Validation ScalarValue
-toScalar (Scalar x) = pure x
-toScalar jsType = internalTypeMismatch "Scalar" jsType
-
-class GQLScalar a where
- parseValue :: ScalarValue -> Validation a
- decode :: JSType -> Validation a
- decode = toScalar >=> parseValue
- serialize :: a -> ScalarValue
- encode :: a -> JSType
- encode = Scalar . serialize
- asInputField :: GQLKind a => Proxy a -> Key -> InputField
- asInputField proxy = InputField . asField proxy
- asField :: Proxy a -> Key -> Field
- default asField :: GQLKind a =>
- Proxy a -> Key -> Field
- asField proxy name = Field {fieldName = name, notNull = True, asList = False, kind = SCALAR, fieldType = typeID proxy}
- introspect :: Proxy a -> TypeLib -> TypeLib
- default introspect :: GQLKind a =>
- Proxy a -> TypeLib -> TypeLib
- introspect = updateLib scalarTypeOf []
diff --git a/src/Data/Morpheus/Parser/Arguments.hs b/src/Data/Morpheus/Parser/Arguments.hs
--- a/src/Data/Morpheus/Parser/Arguments.hs
+++ b/src/Data/Morpheus/Parser/Arguments.hs
@@ -1,48 +1,27 @@
module Data.Morpheus.Parser.Arguments
- ( arguments
+ ( maybeArguments
) where
-import Control.Applicative ((<|>))
-import Data.Attoparsec.Text (Parser, char, sepBy, skipSpace)
-import Data.Morpheus.Parser.Primitive (getPosition, jsBool, jsNumber, jsString, token, variable)
-import Data.Morpheus.Types.JSType (JSType (JSEnum))
-import Data.Morpheus.Types.Query.RawSelection (RawArgument (..), RawArguments)
-import Data.Text (Text)
-
-enum :: Parser JSType
-enum = JSEnum <$> token
-
-argumentType :: Parser RawArgument
-argumentType = do
- pos <- getPosition
- arg <- jsString <|> jsNumber <|> jsBool <|> enum
- pure $ Argument arg pos
-
-variableType :: Parser RawArgument
-variableType = do
- pos <- getPosition
- val <- variable
- pure $ VariableReference val pos
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Primitive (token, variable)
+import Data.Morpheus.Parser.Terms (parseAssignment, parseMaybeTuple)
+import Data.Morpheus.Parser.Value (enumValue, parseValue)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Argument (..), RawArgument (..), RawArguments,
+ Reference (..))
+import Text.Megaparsec (getSourcePos, label, (<|>))
-inputValue :: Parser RawArgument
-inputValue = skipSpace *> argumentType <|> variableType
+valueArgument :: Parser RawArgument
+valueArgument = label "valueArgument" $ do
+ position' <- getSourcePos
+ value' <- parseValue <|> enumValue
+ pure $ RawArgument $ Argument {argumentValue = value', argumentPosition = position'}
-parameter :: Parser (Text, RawArgument)
-parameter = do
- skipSpace
- key <- token
- skipSpace
- _ <- char ':'
- skipSpace
- value <- inputValue
- pure (key, value)
+variableArgument :: Parser RawArgument
+variableArgument = label "variableArgument" $ do
+ (reference', position') <- variable
+ pure $ VariableReference $ Reference {referenceName = reference', referencePosition = position'}
-arguments :: Parser RawArguments
-arguments = do
- skipSpace
- _ <- char '('
- skipSpace
- parameters <- parameter `sepBy` (skipSpace *> char ',')
- skipSpace
- _ <- char ')'
- pure parameters
+maybeArguments :: Parser RawArguments
+maybeArguments = label "maybeArguments" $ parseMaybeTuple argument
+ where
+ argument = parseAssignment token (valueArgument <|> variableArgument)
diff --git a/src/Data/Morpheus/Parser/Body.hs b/src/Data/Morpheus/Parser/Body.hs
--- a/src/Data/Morpheus/Parser/Body.hs
+++ b/src/Data/Morpheus/Parser/Body.hs
@@ -1,51 +1,73 @@
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Parser.Body
- ( body
- , entries
+ ( entries
) where
-import Control.Applicative (some, (<|>))
-import Data.Attoparsec.Text (Parser, char, letter, sepBy, skipSpace,
- string, try)
-import Data.Morpheus.Parser.Arguments (arguments)
-import Data.Morpheus.Parser.Primitive (getPosition, separator, token)
-import Data.Morpheus.Types.Query.RawSelection (RawArguments, RawSelection (..),
- RawSelectionSet)
-import Data.Text (Text, pack)
+import Data.Morpheus.Parser.Arguments (maybeArguments)
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Primitive (qualifier, token)
+import Data.Morpheus.Parser.Terms (onType, parseAssignment, spreadLiteral)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..),
+ RawSelection' (..), RawSelectionSet, Reference (..))
+import Data.Text (Text)
+import Text.Megaparsec (sepEndBy, between, getSourcePos, label, many, try, (<|>))
+import Text.Megaparsec.Char (char, space)
spread :: Parser (Text, RawSelection)
-spread = do
- skipSpace
- index <- getPosition
- _ <- string "..."
- key <- some (letter <|> char '_')
- return (pack key, Spread (pack key) index)
+spread = label "spread" $ do
+ index <- spreadLiteral
+ key' <- token
+ return (key', Spread $ Reference {referenceName = key', referencePosition = index})
-entry :: Parser (Text, RawSelection)
-entry = do
- skipSpace
- index <- getPosition
- key <- token
- args <- try arguments <|> pure []
- value <- try (body args) <|> pure (RawField args key index)
- return (key, value)
+inlineFragment :: Parser (Text, RawSelection)
+inlineFragment = label "InlineFragment" $ do
+ index <- spreadLiteral
+ type' <- onType
+ fragmentBody <- entries
+ pure
+ ( "INLINE_FRAGMENT"
+ , InlineFragment $ Fragment {fragmentType = type', fragmentSelection = fragmentBody, fragmentPosition = index})
-separated :: Parser a -> Parser [a]
-separated x = x `sepBy` separator
+{-
+ accept:
+ - field
+ - field {...}
+ - field (...)
+ - field () {...}
+-}
+parseSelectionField :: Parser (Text, RawSelection)
+parseSelectionField = label "SelectionField" $ do
+ (name', position') <- qualifier
+ arguments' <- maybeArguments
+ value' <- body arguments' <|> buildField arguments' position'
+ return (name', value')
+ where
+ buildField arguments' position' =
+ pure
+ (RawSelectionField $
+ RawSelection' {rawSelectionArguments = arguments', rawSelectionRec = (), rawSelectionPosition = position'})
+alias :: Parser (Text, RawSelection)
+alias = label "alias" $ do
+ ((name', position'), selection') <- parseAssignment qualifier parseSelectionField
+ return (name', RawAlias {rawAliasPosition = position', rawAliasSelection = selection'})
+
entries :: Parser RawSelectionSet
-entries = do
- _ <- char '{'
- skipSpace
- entries' <- separated $ entry <|> spread
- skipSpace
- _ <- char '}'
- return entries'
+entries = label "entries" $
+ between
+ (char '{' *> space)
+ (char '}' *> space)
+ (entry `sepEndBy` many (char ',' *> space))
+ where
+ entry = label "entry" $
+ try inlineFragment <|> try spread <|> try alias <|> parseSelectionField
+
body :: RawArguments -> Parser RawSelection
-body args = do
- skipSpace
- index <- getPosition
+body args = label "body" $ do
+ index <- getSourcePos
entries' <- entries
- return (RawSelectionSet args entries' index)
+ return
+ (RawSelectionSet $
+ RawSelection' {rawSelectionArguments = args, rawSelectionRec = entries', rawSelectionPosition = index})
diff --git a/src/Data/Morpheus/Parser/Fragment.hs b/src/Data/Morpheus/Parser/Fragment.hs
--- a/src/Data/Morpheus/Parser/Fragment.hs
+++ b/src/Data/Morpheus/Parser/Fragment.hs
@@ -4,23 +4,21 @@
( fragment
) where
-import Data.Attoparsec.Text (Parser, skipSpace, string)
-import Data.Morpheus.Parser.Body (entries)
-import Data.Morpheus.Parser.Primitive (getPosition, token)
-import Data.Morpheus.Types.Query.Fragment (Fragment (..))
-import Data.Text (Text)
+import Data.Morpheus.Parser.Body (entries)
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Primitive (token)
+import Data.Morpheus.Parser.Terms (onType)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..))
+import Data.Text (Text)
+import Text.Megaparsec (getSourcePos, label)
+import Text.Megaparsec.Char (space, string)
fragment :: Parser (Text, Fragment)
-fragment = do
- skipSpace
- index <- getPosition
+fragment = label "fragment" $ do
+ index <- getSourcePos
_ <- string "fragment"
- skipSpace
- name <- token
- skipSpace
- _ <- string "on"
- skipSpace
- targetName <- token
- skipSpace
+ space
+ name' <- token
+ type' <- onType
fragmentBody <- entries
- pure (name, Fragment {key = name, target = targetName, content = fragmentBody, position = index})
+ pure (name', Fragment {fragmentType = type', fragmentSelection = fragmentBody, fragmentPosition = index})
diff --git a/src/Data/Morpheus/Parser/Internal.hs b/src/Data/Morpheus/Parser/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Parser/Internal.hs
@@ -0,0 +1,18 @@
+module Data.Morpheus.Parser.Internal
+ ( GQLSyntax(..)
+ , Parser
+ , Position
+ ) where
+
+import Data.Text (Text)
+import Data.Void (Void)
+import Text.Megaparsec (Parsec, SourcePos)
+
+type Position = SourcePos
+
+type Parser = Parsec Void Text
+
+data GQLSyntax a
+ = Invalid Text
+ Position
+ | Valid a
diff --git a/src/Data/Morpheus/Parser/Mutation.hs b/src/Data/Morpheus/Parser/Mutation.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Parser/Mutation.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Parser.Mutation
- ( mutation
- ) where
-
-import Control.Applicative ((<|>))
-import Data.Attoparsec.Text (Parser, skipSpace, string, try)
-import Data.Morpheus.Parser.Body (entries)
-import Data.Morpheus.Parser.Primitive (getPosition, token)
-import Data.Morpheus.Parser.RootHead (rootHeadArguments)
-import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator)
-
-mutation :: Parser RawOperator
-mutation = do
- pos <- getPosition
- _ <- string "mutation "
- skipSpace
- name <- token
- variables <- try (skipSpace *> rootHeadArguments) <|> pure []
- skipSpace
- sel <- entries
- pure $ Mutation name variables sel pos
diff --git a/src/Data/Morpheus/Parser/Operator.hs b/src/Data/Morpheus/Parser/Operator.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Parser/Operator.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Parser.Operator
+ ( parseAnonymousQuery
+ , parseOperator
+ ) where
+
+import Data.Functor (($>))
+import Data.Morpheus.Parser.Body (entries)
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Primitive (token, variable)
+import Data.Morpheus.Parser.Terms (nonNull, parseAssignment, parseMaybeTuple)
+import Data.Morpheus.Types.Internal.AST.Operator (Operator (..), Operator' (..), RawOperator, RawOperator',
+ Variable (..))
+import Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..))
+import Data.Text (Text)
+import Text.Megaparsec (between, getSourcePos, label, (), (<|>))
+import Text.Megaparsec.Char (char, space, space1, string)
+
+wrapMock :: Parser ([DataTypeWrapper], Text)
+wrapMock = do
+ mock <- token
+ space
+ return ([], mock)
+
+insideList :: Parser ([DataTypeWrapper], Text)
+insideList =
+ between
+ (char '[' *> space)
+ (char ']' *> space)
+ (do (list, name) <- wrapMock <|> insideList
+ nonNull' <- nonNull
+ return ((ListType : nonNull') ++ list, name))
+
+wrappedSignature :: Parser ([DataTypeWrapper], Text)
+wrappedSignature = do
+ sig <- insideList <|> wrapMock
+ space
+ return sig
+
+operatorArgument :: Parser (Text, Variable ())
+operatorArgument =
+ label "operatorArgument" $ do
+ ((name', position'), (wrappers', type')) <- parseAssignment variable wrappedSignature
+ nonNull' <- nonNull
+ pure
+ ( name'
+ , Variable
+ { variableType = type'
+ , isVariableRequired = 0 < length nonNull'
+ , variableTypeWrappers = nonNull' ++ wrappers'
+ , variablePosition = position'
+ , variableValue = ()
+ })
+
+parseOperator :: Parser RawOperator
+parseOperator =
+ label "operator" $ do
+ pos <- getSourcePos
+ kind' <- operatorKind
+ operatorName' <- token
+ variables <- parseMaybeTuple operatorArgument
+ sel <- entries
+ pure (kind' $ Operator' operatorName' variables sel pos)
+
+parseAnonymousQuery :: Parser RawOperator
+parseAnonymousQuery =
+ label "AnonymousQuery" $ do
+ position' <- getSourcePos
+ selection' <- entries
+ pure (Query $ Operator' "" [] selection' position') "can't parse AnonymousQuery"
+
+operatorKind :: Parser (RawOperator' -> RawOperator)
+operatorKind =
+ label "operatorKind" $ do
+ kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription)
+ space1
+ return kind
diff --git a/src/Data/Morpheus/Parser/Parser.hs b/src/Data/Morpheus/Parser/Parser.hs
--- a/src/Data/Morpheus/Parser/Parser.hs
+++ b/src/Data/Morpheus/Parser/Parser.hs
@@ -1,45 +1,53 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Data.Morpheus.Parser.Parser
( parseGQL
- , parseLineBreaks
) where
-import Control.Applicative (many, (<|>))
-import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, skipSpace)
-import Data.Map (fromList, toList)
-import Data.Maybe (fromMaybe)
-import Data.Morpheus.Error.Syntax (syntaxError)
-import Data.Morpheus.Parser.Fragment (fragment)
-import qualified Data.Morpheus.Parser.Mutation as M
-import Data.Morpheus.Parser.Primitive (getLines)
-import qualified Data.Morpheus.Parser.Query as Q
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Morpheus.Types.Request (GQLRequest (..))
-import Data.Morpheus.Types.Types (GQLQueryRoot (..))
-import Data.Text (Text, pack)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Map (fromList, toList)
+import Data.Maybe (maybe)
+import Data.Morpheus.Parser.Fragment (fragment)
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Operator (parseAnonymousQuery, parseOperator)
+import Data.Morpheus.Types.Internal.Validation (GQLError (GQLError), GQLErrors, Validation, desc, positions)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Morpheus.Types.IO (GQLRequest (..))
+import Data.Morpheus.Types.Types (GQLQueryRoot (..))
+import Data.Text (Text, pack)
+import Data.Void (Void)
+import Text.Megaparsec (ParseError, ParseErrorBundle (ParseErrorBundle), SourcePos,
+ attachSourcePos, bundleErrors, bundlePosState, eof,
+ errorOffset, label, manyTill, parseErrorPretty, runParser,
+ (<|>))
+import Text.Megaparsec.Char (space)
request :: Parser GQLQueryRoot
-request = do
- queryValue <- Q.query <|> M.mutation
- fragmentLib <- fromList <$> many fragment
- skipSpace
- endOfInput
- pure GQLQueryRoot {queryBody = queryValue, fragments = fragmentLib, inputVariables = []}
+request =
+ label "GQLQueryRoot" $ do
+ space
+ operator' <- parseAnonymousQuery <|> parseOperator
+ fragmentLib <- fromList <$> manyTill fragment eof
+ pure GQLQueryRoot {queryBody = operator', fragments = fragmentLib, inputVariables = []}
-getVariables :: GQLRequest -> [(Text, JSType)]
-getVariables request' = fromMaybe [] (toList <$> variables request')
+processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors
+processErrorBundle = fmap parseErrorToGQLError . bundleToErrors
+ where
+ parseErrorToGQLError :: (ParseError Text Void, SourcePos) -> GQLError
+ parseErrorToGQLError (err, position) = GQLError {desc = pack (parseErrorPretty err), positions = [position]}
+ bundleToErrors :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]
+ bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} =
+ NonEmpty.toList $ fst $ attachSourcePos errorOffset bundleErrors bundlePosState
-parseReq :: GQLRequest -> Either String GQLQueryRoot
-parseReq requestBody = parseOnly request $ query requestBody
+getVariables :: GQLRequest -> [(Text, Value)]
+getVariables request' = maybe [] toList (variables request')
-parseLineBreaks :: GQLRequest -> [Int]
-parseLineBreaks requestBody =
- case parseOnly getLines $ query requestBody of
- Right x -> x
- Left _ -> []
+parseReq :: GQLRequest -> Either (ParseErrorBundle Text Void) GQLQueryRoot
+parseReq requestBody = runParser request "" $ query requestBody
parseGQL :: GQLRequest -> Validation GQLQueryRoot
parseGQL requestBody =
case parseReq requestBody of
Right root -> Right $ root {inputVariables = getVariables requestBody}
- Left parseError -> Left $ syntaxError (pack $ show parseError) 0
+ Left parseError -> Left $ processErrorBundle parseError
diff --git a/src/Data/Morpheus/Parser/Primitive.hs b/src/Data/Morpheus/Parser/Primitive.hs
--- a/src/Data/Morpheus/Parser/Primitive.hs
+++ b/src/Data/Morpheus/Parser/Primitive.hs
@@ -1,73 +1,38 @@
{-# LANGUAGE OverloadedStrings #-}
-module Data.Morpheus.Parser.Primitive where
-
-import Control.Applicative
-import Data.Attoparsec.Text
-import Data.Functor
-import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..), decodeScientific)
-import qualified Data.Text as T (Text, pack)
-
-import qualified Data.Attoparsec.Internal.Types as AT
-
-replaceType :: T.Text -> T.Text
-replaceType "type" = "_type"
-replaceType x = x
-
-boolTrue :: Parser JSType
-boolTrue = string "true" $> Scalar (Boolean True)
-
-boolFalse :: Parser JSType
-boolFalse = string "false" $> Scalar (Boolean False)
-
-jsBool :: Parser JSType
-jsBool = boolTrue <|> boolFalse
-
-jsNumber :: Parser JSType
-jsNumber = Scalar . decodeScientific <$> scientific
-
-codes :: String
-codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
-
-replacements :: String
-replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
-
-escaped :: Parser Char
-escaped = do
- x <- notChar '\"'
- if x == '\\'
- then choice (zipWith escapeChar codes replacements)
- else pure x
- where
- escapeChar code replacement = char code >> return replacement
-
-jsString :: Parser JSType
-jsString = do
- _ <- char '"'
- value <- many escaped
- _ <- char '"'
- pure $ Scalar $ String $ T.pack value
-
-token :: Parser T.Text
-token = replaceType . T.pack <$> some (letter <|> char '_')
-
-variable :: Parser T.Text
-variable = skipSpace *> char '$' *> token
+module Data.Morpheus.Parser.Primitive
+ ( token
+ , qualifier
+ , variable
+ ) where
-separator :: Parser Char
-separator = char ',' <|> char ' ' <|> char '\n' <|> char '\t'
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Value (convertToHaskellName)
+import Data.Text (Text)
+import qualified Data.Text as T (pack)
+import Text.Megaparsec (getSourcePos, label, many, (<|>))
+import Text.Megaparsec.Char (char, digitChar, letterChar, space)
-getPosition :: Parser Int
-getPosition = AT.Parser internFunc
- where
- internFunc t pos more _ success = success t pos more (AT.fromPos pos)
+token :: Parser Text
+token =
+ label "token" $ do
+ firstChar <- letterChar <|> char '_'
+ restToken <- many $ letterChar <|> char '_' <|> digitChar
+ space
+ return $ convertToHaskellName $ T.pack $ firstChar : restToken
-getNextLine :: Parser Int
-getNextLine = do
- _ <- many (notChar '\n')
- index <- getPosition
- _ <- char '\n'
- pure index
+qualifier :: Parser (Text, Position)
+qualifier =
+ label "qualifier" $ do
+ position' <- getSourcePos
+ value <- token
+ return (value, position')
-getLines :: Parser [Int]
-getLines = many getNextLine
+variable :: Parser (Text, Position)
+variable =
+ label "variable" $ do
+ position' <- getSourcePos
+ _ <- char '$'
+ varName' <- token
+ return (varName', position')
diff --git a/src/Data/Morpheus/Parser/Query.hs b/src/Data/Morpheus/Parser/Query.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Parser/Query.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Parser.Query
- ( query
- ) where
-
-import Control.Applicative ((<|>))
-import Data.Attoparsec.Text (Parser, skipSpace, string, try)
-import Data.Morpheus.Parser.Body (entries)
-import Data.Morpheus.Parser.Primitive (getPosition, token)
-import Data.Morpheus.Parser.RootHead (rootHeadArguments)
-import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator, VariableDefinitions)
-import Data.Text (Text)
-
-queryHead :: Parser (Text, VariableDefinitions)
-queryHead = do
- _ <- string "query "
- skipSpace
- queryName <- token
- variables <- try (skipSpace *> rootHeadArguments) <|> pure []
- pure (queryName, variables)
-
-query :: Parser RawOperator
-query = do
- pos <- getPosition
- (queryName, args) <- try (skipSpace *> queryHead) <|> pure ("", [])
- skipSpace
- selection <- entries
- pure $ Query queryName args selection pos
diff --git a/src/Data/Morpheus/Parser/RootHead.hs b/src/Data/Morpheus/Parser/RootHead.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Parser/RootHead.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Data.Morpheus.Parser.RootHead
- ( rootHeadArguments
- ) where
-
-import Data.Attoparsec.Text (Parser, char, sepBy, skipSpace)
-import Data.Morpheus.Parser.Primitive (getPosition, token, variable)
-import Data.Morpheus.Types.Query.Operator (Variable (..), VariableDefinitions)
-import Data.Text (Text)
-
-rootHeadVariable :: Parser (Text, Variable)
-rootHeadVariable = do
- skipSpace
- pos <- getPosition
- variableName <- variable
- skipSpace
- _ <- char ':'
- skipSpace
- variableType <- token
- pure (variableName, Variable variableType pos)
-
-rootHeadArguments :: Parser VariableDefinitions
-rootHeadArguments = do
- skipSpace
- _ <- char '('
- skipSpace
- parameters <- rootHeadVariable `sepBy` (skipSpace *> char ',')
- skipSpace
- _ <- char ')'
- pure parameters
diff --git a/src/Data/Morpheus/Parser/Terms.hs b/src/Data/Morpheus/Parser/Terms.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Parser/Terms.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Parser.Terms
+ ( onType
+ , spreadLiteral
+ , nonNull
+ , parseMaybeTuple
+ , parseAssignment
+ ) where
+
+import Data.Functor (($>))
+import Data.Morpheus.Parser.Internal (Parser, Position)
+import Data.Morpheus.Parser.Primitive (token)
+import Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..))
+import Data.Text (Text)
+import Text.Megaparsec (between, getSourcePos, label, sepBy, (), (<|>))
+import Text.Megaparsec.Char (char, space, space1, string)
+
+nonNull :: Parser [DataTypeWrapper]
+nonNull = do
+ wrapper <- (char '!' $> [NonNullType]) <|> pure []
+ space
+ return wrapper
+
+parseMaybeTuple :: Parser a -> Parser [a]
+parseMaybeTuple parser = parseTuple parser <|> pure []
+
+parseTuple :: Parser a -> Parser [a]
+parseTuple parser = label "Tuple" $
+ between
+ (char '(' *> space)
+ (char ')' *> space)
+ (parser `sepBy` (char ',' *> space) "empty Tuple value!")
+
+parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)
+parseAssignment nameParser' valueParser' = label "assignment" $ do
+ name' <- nameParser'
+ char ':' *> space
+ value' <- valueParser'
+ pure (name', value')
+
+onType :: Parser Text
+onType = do
+ _ <- string "on"
+ space1
+ token
+
+spreadLiteral :: Parser Position
+spreadLiteral = do
+ index <- getSourcePos
+ _ <- string "..."
+ space
+ return index
diff --git a/src/Data/Morpheus/Parser/Value.hs b/src/Data/Morpheus/Parser/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Parser/Value.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Morpheus.Parser.Value
+ ( parseValue
+ , enumValue
+ ) where
+
+import Data.Functor (($>))
+import Data.Morpheus.Parser.Internal (Parser)
+import Data.Morpheus.Parser.Primitive (token)
+import Data.Morpheus.Parser.Terms (parseAssignment)
+import Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..), decodeScientific)
+import Data.Text (pack)
+import Text.Megaparsec (between, anySingleBut, choice, label, many, sepBy, (<|>))
+import Text.Megaparsec.Char (char, space, string)
+import Text.Megaparsec.Char.Lexer (scientific)
+
+parseValue :: Parser Value
+parseValue = label "value" $ do
+ value <- valueNull <|> booleanValue <|> valueNumber <|> stringValue <|> objectValue <|> listValue
+ space
+ return value
+
+valueNull :: Parser Value
+valueNull = string "null" $> Null
+
+booleanValue :: Parser Value
+booleanValue = boolTrue <|> boolFalse
+ where
+ boolTrue = string "true" $> Scalar (Boolean True)
+ boolFalse = string "false" $> Scalar (Boolean False)
+
+valueNumber :: Parser Value
+valueNumber = Scalar . decodeScientific <$> scientific
+
+enumValue :: Parser Value
+enumValue = do
+ enum <- Enum <$> token
+ space
+ return enum
+
+escaped :: Parser Char
+escaped = label "escaped" $ do
+ x <- anySingleBut '\"'
+ if x == '\\'
+ then choice (zipWith escapeChar codes replacements)
+ else pure x
+ where
+ replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']
+ codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']
+ escapeChar code replacement = char code >> return replacement
+
+stringValue :: Parser Value
+stringValue = label "stringValue" $
+ Scalar . String . pack <$>
+ between
+ (char '"')
+ (char '"')
+ (many escaped)
+
+listValue :: Parser Value
+listValue = label "listValue" $
+ List <$> between
+ (char '[' *> space)
+ (char ']' *> space)
+ (parseValue `sepBy` (char ',' *> space))
+
+objectValue :: Parser Value
+objectValue = label "objectValue" $
+ Object <$> between
+ (char '{' *> space)
+ (char '}' *> space)
+ (parseAssignment token parseValue `sepBy` (char ',' *> space))
diff --git a/src/Data/Morpheus/PreProcess/Fragment.hs b/src/Data/Morpheus/PreProcess/Fragment.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Fragment.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-module Data.Morpheus.PreProcess.Fragment
- ( validateFragments
- ) where
-
-import qualified Data.Map as M (toList)
-import Data.Morpheus.Error.Fragment (cannotSpreadWithinItself)
-import Data.Morpheus.PreProcess.Utils (existsObjectType)
-import Data.Morpheus.Schema.Internal.Types (TypeLib)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.Query.Fragment (Fragment (..))
-import Data.Morpheus.Types.Query.RawSelection (RawSelection (..))
-import Data.Morpheus.Types.Types (GQLQueryRoot (..))
-import Data.Text (Text)
-
-type Node = EnhancedKey
-
-type NodeEdges = (Node, [Node])
-
-type Graph = [NodeEdges]
-
-scanForSpread :: TypeLib -> GQLQueryRoot -> (Text, RawSelection) -> [Node]
-scanForSpread lib' root (_', RawSelectionSet _ selectors _) = concatMap (scanForSpread lib' root) selectors
-scanForSpread _ _ (_, RawField {}) = []
-scanForSpread _ _ (_, Spread value pos) = [EnhancedKey value pos]
-
-validateFragment :: TypeLib -> GQLQueryRoot -> (Text, Fragment) -> Validation NodeEdges
-validateFragment lib' root (fName, Fragment {content = selection, target = target', position = position'}) =
- existsObjectType position' target' lib' >>
- pure (EnhancedKey fName position', concatMap (scanForSpread lib' root) selection)
-
-validateFragments :: TypeLib -> GQLQueryRoot -> Validation ()
-validateFragments lib root = mapM (validateFragment lib root) (M.toList $ fragments root) >>= detectLoopOnFragments
-
-detectLoopOnFragments :: Graph -> Validation ()
-detectLoopOnFragments lib = mapM_ checkFragment lib
- where
- checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID]
-
-checkForCycle :: Graph -> Node -> [Node] -> Validation Graph
-checkForCycle lib parentNode history =
- case lookup parentNode lib of
- Just node -> concat <$> mapM checkNode node
- Nothing -> pure []
- where
- checkNode x =
- if x `elem` history
- then cycleError x
- else recurse x
- recurse node = checkForCycle lib node $ history ++ [node]
- cycleError n = Left $ cannotSpreadWithinItself $ history ++ [n]
diff --git a/src/Data/Morpheus/PreProcess/Input/Enum.hs b/src/Data/Morpheus/PreProcess/Input/Enum.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Input/Enum.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.PreProcess.Input.Enum
- ( validateEnum
- ) where
-
-import Data.List (elem)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Text (Text)
-
-validateEnum :: error -> [Text] -> JSType -> Either error JSType
-validateEnum error' tags' (JSEnum enumValue) =
- if enumValue `elem` tags'
- then pure (JSEnum enumValue)
- else Left error'
-validateEnum error' _ _ = Left error'
diff --git a/src/Data/Morpheus/PreProcess/Input/Object.hs b/src/Data/Morpheus/PreProcess/Input/Object.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Input/Object.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.PreProcess.Input.Object
- ( validateInputObject
- , validateInput
- ) where
-
-import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))
-import Data.Morpheus.PreProcess.Input.Enum (validateEnum)
-import Data.Morpheus.PreProcess.Utils (lookupField, lookupType)
-import Data.Morpheus.Schema.Internal.Types (Core (..), Field (..), GObject (..), InputField (..), InputObject,
- InputType, Leaf (..), TypeLib (..))
-import qualified Data.Morpheus.Schema.Internal.Types as T (InternalType (..))
-import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..))
-import Data.Text (Text)
-
-generateError :: JSType -> Text -> [Prop] -> InputError
-generateError jsType expected' path' = UnexpectedType path' expected' jsType
-
-existsInputObjectType :: InputError -> TypeLib -> Text -> InputValidation InputObject
-existsInputObjectType error' lib' = lookupType error' (inputObject lib')
-
-existsLeafType :: InputError -> TypeLib -> Text -> InputValidation Leaf
-existsLeafType error' lib' = lookupType error' (leaf lib')
-
-validateScalarTypes :: Text -> ScalarValue -> [Prop] -> InputValidation ScalarValue
-validateScalarTypes "String" (String x) = pure . const (String x)
-validateScalarTypes "String" scalar = Left . generateError (Scalar scalar) "String"
-validateScalarTypes "Int" (Int x) = pure . const (Int x)
-validateScalarTypes "Int" scalar = Left . generateError (Scalar scalar) "Int"
-validateScalarTypes "Boolean" (Boolean x) = pure . const (Boolean x)
-validateScalarTypes "Boolean" scalar = Left . generateError (Scalar scalar) "Boolean"
-validateScalarTypes _ scalar = pure . const scalar
-
-validateEnumType :: Text -> [Text] -> JSType -> [Prop] -> InputValidation JSType
-validateEnumType expected' tags jsType props = validateEnum (UnexpectedType props expected' jsType) tags jsType
-
-validateLeaf :: Leaf -> JSType -> [Prop] -> InputValidation JSType
-validateLeaf (LEnum tags core) jsType props = validateEnumType (name core) tags jsType props
-validateLeaf (LScalar core) (Scalar found) props = Scalar <$> validateScalarTypes (name core) found props
-validateLeaf (LScalar core) jsType props = Left $ generateError jsType (name core) props
-
-validateInputObject :: [Prop] -> TypeLib -> GObject InputField-> (Text, JSType) -> InputValidation (Text, JSType)
-validateInputObject prop' lib' (GObject parentFields _) (_name, JSObject fields) = do
- fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name)
- let currentProp = prop' ++ [Prop _name fieldTypeName']
- let error' = generateError (JSObject fields) fieldTypeName' currentProp
- inputObject' <- existsInputObjectType error' lib' fieldTypeName'
- mapM (validateInputObject currentProp lib' inputObject') fields >>= \x -> pure (_name, JSObject x)
-validateInputObject prop' lib' (GObject parentFields _) (_name, jsType) = do
- fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name)
- let currentProp = prop' ++ [Prop _name fieldTypeName']
- let error' = generateError jsType fieldTypeName' currentProp
- fieldType' <- existsLeafType error' lib' fieldTypeName'
- validateLeaf fieldType' jsType currentProp >> pure (_name, jsType)
-
-validateInput :: TypeLib -> InputType -> (Text, JSType) -> InputValidation JSType
-validateInput typeLib (T.Object oType) (_, JSObject fields) =
- JSObject <$> mapM (validateInputObject [] typeLib oType) fields
-validateInput _ (T.Object (GObject _ core)) (_, jsType) = Left $ generateError jsType (name core) []
-validateInput _ (T.Scalar core) (_, jsValue) = validateLeaf (LScalar core) jsValue []
-validateInput _ (T.Enum tags core) (_, jsValue) = validateLeaf (LEnum tags core) jsValue []
diff --git a/src/Data/Morpheus/PreProcess/PreProcess.hs b/src/Data/Morpheus/PreProcess/PreProcess.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/PreProcess.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.PreProcess.PreProcess
- ( preProcessQuery
- ) where
-
-import Data.Map (fromList)
-import Data.Morpheus.Error.Mutation (mutationIsNotDefined)
-import Data.Morpheus.PreProcess.Fragment (validateFragments)
-import Data.Morpheus.PreProcess.Resolve.ResolveRawQuery (resolveRawQuery)
-import Data.Morpheus.PreProcess.Validate.Validate (mapSelectorValidation)
-import Data.Morpheus.PreProcess.Variable (allVariableReferences, resolveOperationVariables)
-import Data.Morpheus.Schema.Internal.Types (GObject (..), ObjectField (..), OutputObject,
- TypeLib (..))
-import qualified Data.Morpheus.Schema.Internal.Types as SC (Field (..))
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator, ValidOperator,
- VariableDefinitions)
-import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet)
-import Data.Morpheus.Types.Query.Selection (SelectionSet)
-import Data.Morpheus.Types.Types (GQLQueryRoot (..))
-import Data.Text (Text)
-
-updateQuery :: RawOperator -> SelectionSet -> ValidOperator
-updateQuery (Query name' _ _ pos) sel = Query name' [] sel pos
-updateQuery (Mutation name' _ _ pos) sel = Mutation name' [] sel pos
-
-fieldSchema :: [(Text, ObjectField)]
-fieldSchema =
- [ ( "__schema"
- , ObjectField
- { args = []
- , fieldContent =
- SC.Field
- { SC.fieldName = "__schema"
- , SC.notNull = True
- , SC.asList = False
- , SC.kind = OBJECT
- , SC.fieldType = "__Schema"
- }
- })
- ]
-
-setFieldSchema :: GObject ObjectField -> GObject ObjectField
-setFieldSchema (GObject fields core) = GObject (fields ++ fieldSchema) core
-
-getOperator :: RawOperator -> TypeLib -> Validation (OutputObject, VariableDefinitions, RawSelectionSet)
-getOperator (Query _ args' sel _) lib' = pure (snd $ query lib', args', sel)
-getOperator (Mutation _ args' sel position') lib' =
- case mutation lib' of
- Just (_, mutation') -> pure (mutation', args', sel)
- Nothing -> Left $ mutationIsNotDefined position'
-
-resolveValues :: TypeLib -> GQLQueryRoot -> Validation (OutputObject, SelectionSet)
-resolveValues typesLib root = do
- (query', args', rawSel) <- getOperator (queryBody root) typesLib
- variables' <-
- resolveOperationVariables typesLib (fromList $ inputVariables root) (allVariableReferences [rawSel]) args'
- validateFragments typesLib root
- let operator' = setFieldSchema query'
- selection' <- resolveRawQuery typesLib (fragments root) variables' rawSel operator'
- pure (operator', selection')
-
-preProcessQuery :: TypeLib -> GQLQueryRoot -> Validation ValidOperator
-preProcessQuery lib' root' = do
- (operatorType', selection') <- resolveValues lib' root'
- selectors <- mapSelectorValidation lib' operatorType' selection'
- pure $ updateQuery (queryBody root') selectors
diff --git a/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs b/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module Data.Morpheus.PreProcess.Resolve.Arguments
- ( resolveArguments
- ) where
-
-import Data.Morpheus.PreProcess.Variable (resolveArgumentValue)
-import Data.Morpheus.Types.Error (Validation)
-import qualified Data.Morpheus.Types.Query.RawSelection as Raw (RawArguments)
-import Data.Morpheus.Types.Query.Selection (Arguments)
-import Data.Morpheus.Types.Types (Variables)
-
-resolveArguments :: Variables -> Raw.RawArguments -> Validation Arguments
-resolveArguments variables' = mapM (resolveArgumentValue variables')
diff --git a/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs b/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Data.Morpheus.PreProcess.Resolve.ResolveRawQuery
- ( resolveRawQuery
- ) where
-
-import Data.Morpheus.PreProcess.Resolve.Arguments (resolveArguments)
-import Data.Morpheus.PreProcess.Resolve.Spread (resolveSpread)
-import Data.Morpheus.PreProcess.Selection (lookupSelectionObjectFieldType)
-import Data.Morpheus.Schema.Internal.Types (GObject (..), ObjectField (..), OutputObject, TypeLib (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.Query.Fragment (FragmentLib)
-import Data.Morpheus.Types.Query.RawSelection (RawSelection (..), RawSelectionSet)
-import Data.Morpheus.Types.Query.Selection (Selection (..), SelectionSet)
-import Data.Morpheus.Types.Types (Variables)
-import Data.Text (Text)
-
-resolveVariableAndSpread ::
- TypeLib -> FragmentLib -> Variables -> GObject ObjectField -> (Text, RawSelection) -> Validation SelectionSet
-resolveVariableAndSpread lib' fragments' variables' parent' (key', RawSelectionSet rawArgs rawSelectors position') = do
- fieldType' <- lookupSelectionObjectFieldType position' key' lib' parent'
- args' <- resolveArguments variables' rawArgs
- sel <- concat <$> mapM (resolveVariableAndSpread lib' fragments' variables' fieldType') rawSelectors
- pure [(key', SelectionSet args' sel position')]
-resolveVariableAndSpread _ _ variables' _ (sKey, RawField rawArgs field sPos) = do
- args' <- resolveArguments variables' rawArgs
- pure [(sKey, Field args' field sPos)]
-resolveVariableAndSpread lib' fragments' variables' parent' (spreadID, Spread _ sPos) =
- concat <$> (resolveSpread fragments' parent' sPos spreadID >>= recursiveResolve)
- where
- recursiveResolve = mapM (resolveVariableAndSpread lib' fragments' variables' parent')
-
-resolveRawQuery :: TypeLib -> FragmentLib -> Variables -> RawSelectionSet -> OutputObject -> Validation SelectionSet
-resolveRawQuery lib' fragments' variables' sel query' =
- concat <$> mapM (resolveVariableAndSpread lib' fragments' variables' query') sel
diff --git a/src/Data/Morpheus/PreProcess/Resolve/Spread.hs b/src/Data/Morpheus/PreProcess/Resolve/Spread.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Resolve/Spread.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module Data.Morpheus.PreProcess.Resolve.Spread
- ( getFragment
- , castFragmentType
- , resolveSpread
- ) where
-
-import qualified Data.Map as M (lookup)
-import Data.Morpheus.Error.Spread (cannotBeSpreadOnType, unknownFragment)
-import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position)
-import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..))
-import Data.Morpheus.Types.Query.Fragment (Fragment (..), FragmentLib)
-import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet)
-import Data.Text (Text)
-
-getFragment :: Position -> Text -> FragmentLib -> Validation Fragment
-getFragment position' id' lib =
- case M.lookup id' lib of
- Nothing -> Left $ unknownFragment id' position'
- Just fragment -> pure fragment
-
-castFragmentType :: MetaInfo -> GObject ObjectField -> Fragment -> Validation Fragment
-castFragmentType spreadMeta (GObject _ core) fragment =
- if name core == target fragment
- then pure fragment
- else Left $ cannotBeSpreadOnType (spreadMeta {typeName = target fragment}) (name core)
-
-resolveSpread :: FragmentLib -> GObject ObjectField -> Position -> Text -> Validation RawSelectionSet
-resolveSpread fragments' parentType' position' id' = content <$> (getFragment position' id' fragments' >>= cast)
- where
- cast fragment' =
- castFragmentType
- (MetaInfo {Meta.position = position', Meta.key = id', Meta.typeName = target fragment'})
- parentType'
- fragment'
diff --git a/src/Data/Morpheus/PreProcess/Selection.hs b/src/Data/Morpheus/PreProcess/Selection.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Selection.hs
+++ /dev/null
@@ -1,51 +0,0 @@
-module Data.Morpheus.PreProcess.Selection
- ( lookupFieldAsSelectionSet
- , lookupSelectionObjectFieldType
- , mustBeObject
- , notObject
- , lookupSelectionField
- ) where
-
-import Data.Morpheus.Error.Selection (cannotQueryField, hasNoSubfields, subfieldsNotSelected)
-import Data.Morpheus.PreProcess.Utils (lookupField, lookupType)
-import Data.Morpheus.Schema.Internal.Types (Core (..), Field (..), GObject (..), ObjectField (..),
- OutputObject, TypeLib (..))
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position)
-import Data.Text (Text)
-
-isObjectKind :: ObjectField -> Bool
-isObjectKind (ObjectField _ field') = OBJECT == kind field'
-
-mustBeObject :: (Text, Position) -> ObjectField -> Validation ObjectField
-mustBeObject (key', position') field' =
- if isObjectKind field'
- then pure field'
- else Left $ hasNoSubfields meta
- where
- meta = MetaInfo {position = position', key = key', typeName = fieldType $ fieldContent field'}
-
-notObject :: (Text, Position) -> ObjectField -> Validation ObjectField
-notObject (key', position') field' =
- if isObjectKind field'
- then Left $ subfieldsNotSelected meta
- else pure field'
- where
- meta = MetaInfo {position = position', key = key', typeName = fieldType $ fieldContent field'}
-
-lookupFieldAsSelectionSet :: Position -> Text -> TypeLib -> ObjectField -> Validation OutputObject
-lookupFieldAsSelectionSet position' key' lib' field' = lookupType error' (object lib') type'
- where
- error' = hasNoSubfields $ MetaInfo {position = position', key = key', typeName = type'}
- type' = fieldType $ fieldContent field'
-
-lookupSelectionField :: Position -> Text -> GObject ObjectField -> Validation ObjectField
-lookupSelectionField position' key' (GObject fields' core') = lookupField key' fields' error'
- where
- error' = cannotQueryField $ MetaInfo {position = position', key = key', typeName = name core'}
-
-lookupSelectionObjectFieldType :: Position -> Text -> TypeLib -> GObject ObjectField -> Validation OutputObject
-lookupSelectionObjectFieldType position' key' lib' object' =
- lookupSelectionField position' key' object' >>= mustBeObject (key', position') >>=
- lookupFieldAsSelectionSet position' key' lib'
diff --git a/src/Data/Morpheus/PreProcess/Utils.hs b/src/Data/Morpheus/PreProcess/Utils.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Utils.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-module Data.Morpheus.PreProcess.Utils
- ( differKeys
- , existsObjectType
- , lookupType
- , getInputType
- , lookupField
- , checkNameCollision
- , checkForUnknownKeys
- ) where
-
-import Data.List ((\\))
-import Data.Morpheus.Error.Variable (unknownType)
-import Data.Morpheus.Schema.Internal.Types (InputType, InternalType (..), Leaf (..), OutputObject,
- TypeLib (..))
-import Data.Morpheus.Types.Core (EnhancedKey (..), Key, enhanceKeyWithNull)
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.MetaInfo (Position)
-import qualified Data.Set as S
-import Data.Text (Text)
-
-type GenError error a = error -> Either error a
-
-lookupType :: error -> [(Text, a)] -> Text -> Either error a
-lookupType error' lib' typeName' =
- case lookup typeName' lib' of
- Nothing -> Left error'
- Just x -> pure x
-
-lookupField :: Text -> [(Text, fType)] -> GenError error fType
-lookupField id' lib' error' =
- case lookup id' lib' of
- Nothing -> Left error'
- Just field -> pure field
-
-getInputType :: Text -> TypeLib -> GenError error InputType
-getInputType typeName' lib error' =
- case lookup typeName' (inputObject lib) of
- Just x -> pure (Object x)
- Nothing ->
- case lookup typeName' (leaf lib) of
- Nothing -> Left error'
- Just (LScalar x) -> pure (Scalar x)
- Just (LEnum x y) -> pure (Enum x y)
-
-existsObjectType :: Position -> Text -> TypeLib -> Validation OutputObject
-existsObjectType position' typeName' lib = lookupType error' (object lib) typeName'
- where
- error' = unknownType typeName' position'
-
-differKeys :: [EnhancedKey] -> [Key] -> [EnhancedKey]
-differKeys enhanced keys = enhanced \\ map enhanceKeyWithNull keys
-
-removeDuplicates :: Ord a => [a] -> [a]
-removeDuplicates = S.toList . S.fromList
-
-elementOfKeys :: [Text] -> EnhancedKey -> Bool
-elementOfKeys keys' EnhancedKey {uid = id'} = id' `elem` keys'
-
-checkNameCollision :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]
-checkNameCollision enhancedKeys' keys' errorGenerator' =
- case differKeys enhancedKeys' (removeDuplicates keys') of
- [] -> pure enhancedKeys'
- duplicates' -> Left $ errorGenerator' duplicates'
-
-checkForUnknownKeys :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]
-checkForUnknownKeys enhancedKeys' keys' errorGenerator' =
- case filter (not . elementOfKeys keys') enhancedKeys' of
- [] -> pure enhancedKeys'
- unknownKeys' -> Left $ errorGenerator' unknownKeys'
diff --git a/src/Data/Morpheus/PreProcess/Validate/Arguments.hs b/src/Data/Morpheus/PreProcess/Validate/Arguments.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Validate/Arguments.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-module Data.Morpheus.PreProcess.Validate.Arguments
- ( validateArguments
- ) where
-
-import Data.Morpheus.Error.Arguments (argumentGotInvalidValue, argumentNameCollision,
- undefinedArgument, unknownArguments)
-import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage)
-import Data.Morpheus.Error.Internal (internalUnknownTypeMessage)
-import Data.Morpheus.PreProcess.Input.Object (validateInput)
-import Data.Morpheus.PreProcess.Utils (checkForUnknownKeys, checkNameCollision, getInputType)
-import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), ObjectField (..), TypeLib)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.JSType (JSType (JSNull))
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Morpheus.Types.Query.Selection (Argument (..), Arguments)
-import Data.Text (Text)
-
-handleInputError :: Text -> Int -> InputValidation a -> Validation ()
-handleInputError key' position' (Left error') = Left $ argumentGotInvalidValue key' (inputErrorMessage error') position'
-handleInputError _ _ _ = pure ()
-
-validateArgumentValue :: TypeLib -> Text -> (Text, Argument) -> Validation (Text, Argument)
-validateArgumentValue lib' typeID' (key', Argument value' position') =
- getInputType typeID' lib' (internalUnknownTypeMessage typeID') >>= checkType >> pure (key', Argument value' position')
- where
- checkType type' = handleInputError key' position' (validateInput lib' type' (key', value'))
-
-validateArgument :: TypeLib -> Position -> Arguments -> (Text, InputField) -> Validation (Text, Argument)
-validateArgument types position' requestArgs (key', InputField arg) =
- case lookup key' requestArgs of
- Nothing ->
- if notNull arg
- then Left $ undefinedArgument (EnhancedKey key' position')
- else pure (key', Argument JSNull position')
- Just (Argument value pos) -> validateArgumentValue types (fieldType arg) (key', Argument value pos)
-
-checkForUnknownArguments :: (Text, ObjectField) -> Arguments -> Validation [(Text, InputField)]
-checkForUnknownArguments (fieldKey', ObjectField fieldArgs _) args' =
- checkForUnknownKeys enhancedKeys' fieldKeys error' >> checkNameCollision enhancedKeys' fieldKeys argumentNameCollision >>
- pure fieldArgs
- where
- error' = unknownArguments fieldKey'
- enhancedKeys' = map argToKey args'
- argToKey (key', Argument _ pos) = EnhancedKey key' pos
- fieldKeys = map fst fieldArgs
-
-validateArguments :: TypeLib -> (Text, ObjectField) -> Position -> Arguments -> Validation Arguments
-validateArguments typeLib inputs pos args' =
- checkForUnknownArguments inputs args' >>= mapM (validateArgument typeLib pos args')
diff --git a/src/Data/Morpheus/PreProcess/Validate/Validate.hs b/src/Data/Morpheus/PreProcess/Validate/Validate.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Validate/Validate.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.PreProcess.Validate.Validate
- ( mapSelectorValidation
- ) where
-
-import Data.Morpheus.Error.Selection (duplicateQuerySelections)
-import Data.Morpheus.PreProcess.Selection (lookupFieldAsSelectionSet, lookupSelectionField,
- mustBeObject, notObject)
-import Data.Morpheus.PreProcess.Utils (checkNameCollision)
-import Data.Morpheus.PreProcess.Validate.Arguments (validateArguments)
-import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField (..), TypeLib (..))
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.Query.Selection (Selection (..), SelectionSet)
-import Data.Text (Text)
-
-selToKey :: (Text, Selection) -> EnhancedKey
-selToKey (sName, Field _ _ pos) = EnhancedKey sName pos
-selToKey (sName, SelectionSet _ _ pos) = EnhancedKey sName pos
-
-checkDuplicatesOn :: GObject ObjectField -> SelectionSet -> Validation SelectionSet
-checkDuplicatesOn (GObject _ core) keys = checkNameCollision enhancedKeys (map fst keys) error' >> pure keys
- where
- error' = duplicateQuerySelections (name core)
- enhancedKeys = map selToKey keys
-
-validateBySchema :: TypeLib -> GObject ObjectField -> (Text, Selection) -> Validation (Text, Selection)
-validateBySchema lib' parent' (key', SelectionSet args' selectors position') = do
- field' <- lookupSelectionField position' key' parent' >>= mustBeObject (key', position')
- fieldType' <- lookupFieldAsSelectionSet position' key' lib' field'
- arguments' <- validateArguments lib' (key', field') position' args'
- selectorsQS <- mapSelectorValidation lib' fieldType' selectors
- pure (key', SelectionSet arguments' selectorsQS position')
-validateBySchema lib' parent' (key', Field args' field position') = do
- field' <- lookupSelectionField position' key' parent' >>= notObject (key', position')
- arguments' <- validateArguments lib' (key', field') position' args'
- pure (key', Field arguments' field position')
-
-mapSelectorValidation :: TypeLib -> GObject ObjectField -> SelectionSet -> Validation SelectionSet
-mapSelectorValidation typeLib type' selectors =
- checkDuplicatesOn type' selectors >>= mapM (validateBySchema typeLib type')
diff --git a/src/Data/Morpheus/PreProcess/Variable.hs b/src/Data/Morpheus/PreProcess/Variable.hs
deleted file mode 100644
--- a/src/Data/Morpheus/PreProcess/Variable.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.PreProcess.Variable
- ( resolveOperationVariables
- , resolveArgumentValue
- , allVariableReferences
- ) where
-
-import Data.List ((\\))
-import qualified Data.Map as M (fromList, lookup)
-import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage)
-import Data.Morpheus.Error.Variable (undefinedVariable, uninitializedVariable, unknownType,
- unusedVariables, variableGotInvalidValue)
-import Data.Morpheus.PreProcess.Input.Object (validateInput)
-import Data.Morpheus.PreProcess.Utils (getInputType)
-import Data.Morpheus.Schema.Internal.Types (InputType, TypeLib)
-import Data.Morpheus.Types.Core (EnhancedKey (..))
-import Data.Morpheus.Types.Error (Validation)
-import Data.Morpheus.Types.JSType (JSType (..))
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Morpheus.Types.Query.Operator (Variable (..))
-import Data.Morpheus.Types.Query.RawSelection (RawArgument (..), RawSelection (..), RawSelectionSet)
-import qualified Data.Morpheus.Types.Query.Selection as Valid (Argument (..))
-import Data.Morpheus.Types.Types (Variables)
-import Data.Text (Text)
-
-getVariableType :: Text -> Position -> TypeLib -> Validation InputType
-getVariableType type' position' lib' = getInputType type' lib' error'
- where
- error' = unknownType type' position'
-
-lookupVariable :: Variables -> Text -> (Text -> error) -> Either error JSType
-lookupVariable variables' key' error' =
- case M.lookup key' variables' of
- Nothing -> Left $ error' key'
- Just value -> pure value
-
-getVariable :: Position -> Variables -> Text -> Validation JSType
-getVariable position' variables' key' = lookupVariable variables' key' (undefinedVariable "Query" position')
-
-lookupBodyValue :: Position -> Variables -> Text -> Validation JSType
-lookupBodyValue position' variables' key' = lookupVariable variables' key' (uninitializedVariable position')
-
-handleInputError :: Text -> Int -> InputValidation JSType -> Validation (Text, JSType)
-handleInputError key' position' (Left error') = Left $ variableGotInvalidValue key' (inputErrorMessage error') position'
-handleInputError key' _ (Right value') = pure (key', value')
-
-lookupAndValidateValueOnBody :: TypeLib -> Variables -> (Text, Variable) -> Validation (Text, JSType)
-lookupAndValidateValueOnBody typeLib root (key', Variable type' pos) = getVariableType type' pos typeLib >>= checkType
- where
- checkType _type = do
- variableValue <- lookupBodyValue pos root key'
- handleInputError key' pos $ validateInput typeLib _type (key', variableValue)
-
-resolveOperationVariables :: TypeLib -> Variables -> [EnhancedKey] -> [(Text, Variable)] -> Validation Variables
-resolveOperationVariables typeLib root references' variables' = do
- checkUnusedVariable references' variables'
- M.fromList <$> mapM (lookupAndValidateValueOnBody typeLib root) variables'
-
-varToKey :: (Text, Variable) -> EnhancedKey
-varToKey (key', Variable _ position') = EnhancedKey key' position'
-
-checkUnusedVariable :: [EnhancedKey] -> [(Text, Variable)] -> Validation ()
-checkUnusedVariable references' variables' =
- case map varToKey variables' \\ references' of
- [] -> pure ()
- unused' -> Left $ unusedVariables unused'
-
-allVariableReferences :: [RawSelectionSet] -> [EnhancedKey]
-allVariableReferences = concatMap (concatMap searchReferencesIn)
-
-referencesFromArgument :: (Text, RawArgument) -> [EnhancedKey]
-referencesFromArgument (_, Argument _ _) = []
-referencesFromArgument (_, VariableReference value' position') = [EnhancedKey value' position']
-
-searchReferencesIn :: (Text, RawSelection) -> [EnhancedKey]
-searchReferencesIn (_, RawSelectionSet rawArgs rawSelectors _) =
- concatMap referencesFromArgument rawArgs ++ concatMap searchReferencesIn rawSelectors
-searchReferencesIn (_, RawField rawArgs _ _) = concatMap referencesFromArgument rawArgs
-searchReferencesIn (_, Spread _ _) = []
-
-resolveArgumentValue :: Variables -> (Text, RawArgument) -> Validation (Text, Valid.Argument)
-resolveArgumentValue root (key', VariableReference variableID pos) = do
- value <- getVariable pos root variableID
- pure (key', Valid.Argument value pos)
-resolveArgumentValue _ (key', Argument value pos) = pure (key', Valid.Argument value pos)
diff --git a/src/Data/Morpheus/Resolve/Decode.hs b/src/Data/Morpheus/Resolve/Decode.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Decode.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Morpheus.Resolve.Decode
+ ( ArgumentsConstraint
+ , decodeArguments
+ ) where
+
+import Data.Morpheus.Error.Internal (internalArgumentError, internalTypeMismatch)
+import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, KIND, SCALAR, WRAPPER)
+import Data.Morpheus.Resolve.Generics.EnumRep (EnumRep (..))
+import Data.Morpheus.Types.GQLScalar (GQLScalar (..), toScalar)
+import Data.Morpheus.Types.Internal.AST.Selection (Argument (..), Arguments)
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Proxy (Proxy (..))
+import Data.Text (Text, pack)
+import GHC.Generics
+
+type Decode_ a = Value -> Validation a
+
+type ArgumentsConstraint a = (Generic a, GDecode Arguments (Rep a))
+
+decodeArguments :: (Generic p, GDecode Arguments (Rep p)) => Arguments -> Validation p
+decodeArguments args = to <$> gDecode "" args
+
+--
+-- GENERIC
+--
+fixProxy :: (a -> f a) -> f a
+fixProxy f = f undefined
+
+class GDecode i f where
+ gDecode :: Text -> i -> Validation (f a)
+
+instance GDecode i U1 where
+ gDecode _ _ = pure U1
+
+instance (Selector c, GDecode i f) => GDecode i (M1 S c f) where
+ gDecode _ gql = fixProxy (\x -> M1 <$> gDecode (pack $ selName x) gql)
+
+instance (Datatype c, GDecode i f) => GDecode i (M1 D c f) where
+ gDecode key gql = fixProxy $ const (M1 <$> gDecode key gql)
+
+instance GDecode i f => GDecode i (M1 C c f) where
+ gDecode meta gql = M1 <$> gDecode meta gql
+
+instance (GDecode i f, GDecode i g) => GDecode i (f :*: g) where
+ gDecode meta gql = (:*:) <$> gDecode meta gql <*> gDecode meta gql
+
+instance (Decode a (KIND a)) => GDecode Value (K1 i a) where
+ gDecode key' (Object object) =
+ case lookup key' object of
+ Nothing -> internalArgumentError "Missing Argument"
+ Just value -> K1 <$> decode value
+ gDecode _ isType = internalTypeMismatch "InputObject" isType
+
+instance Decode a (KIND a) => GDecode Arguments (K1 i a) where
+ gDecode key' args =
+ case lookup key' args of
+ Nothing -> internalArgumentError "Required Argument Not Found"
+ Just (Argument x _pos) -> K1 <$> decode x
+
+-- | Decode GraphQL query arguments and input values
+decode ::
+ forall a. Decode a (KIND a)
+ => Decode_ a
+decode = __decode (Proxy @(KIND a))
+
+-- | Decode GraphQL query arguments and input values
+class Decode a b where
+ __decode :: Proxy b -> Decode_ a
+
+--
+-- SCALAR
+--
+instance (GQLScalar a) => Decode a SCALAR where
+ __decode _ value =
+ case toScalar value >>= parseValue of
+ Right scalar -> return scalar
+ Left errorMessage -> internalTypeMismatch errorMessage value
+
+--
+-- ENUM
+--
+instance (Generic a, EnumRep (Rep a)) => Decode a ENUM where
+ __decode _ (Enum value) = pure (to $ gToEnum value)
+ __decode _ isType = internalTypeMismatch "Enum" isType
+
+--
+-- INPUT_OBJECT
+--
+instance (Generic a, GDecode Value (Rep a)) => Decode a INPUT_OBJECT where
+ __decode _ (Object x) = to <$> gDecode "" (Object x)
+ __decode _ isType = internalTypeMismatch "InputObject" isType
+
+--
+-- WRAPPERS: Maybe, List
+--
+instance Decode a (KIND a) => Decode (Maybe a) WRAPPER where
+ __decode _ Null = pure Nothing
+ __decode _ x = Just <$> decode x
+
+instance Decode a (KIND a) => Decode [a] WRAPPER where
+ __decode _ (List li) = mapM decode li
+ __decode _ isType = internalTypeMismatch "List" isType
diff --git a/src/Data/Morpheus/Resolve/Encode.hs b/src/Data/Morpheus/Resolve/Encode.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Encode.hs
@@ -0,0 +1,229 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Morpheus.Resolve.Encode
+ ( ObjectFieldResolvers(..)
+ , resolveBySelection
+ , resolversBy
+ , QueryResult
+ ) where
+
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Except
+import Data.Map (Map)
+import qualified Data.Map as M (toList)
+import Data.Maybe (fromMaybe)
+import Data.Proxy (Proxy (..))
+import Data.Set (Set)
+import qualified Data.Set as S (toList)
+import Data.Text (Text, pack)
+import GHC.Generics
+
+-- MORPHEUS
+import Data.Morpheus.Error.Internal (internalErrorT)
+import Data.Morpheus.Error.Selection (fieldNotResolved, subfieldsNotSelected)
+import Data.Morpheus.Kind (ENUM, KIND, OBJECT, SCALAR, UNION, WRAPPER)
+import Data.Morpheus.Resolve.Decode (ArgumentsConstraint, decodeArguments)
+import Data.Morpheus.Resolve.Generics.EnumRep (EnumRep (..))
+import Data.Morpheus.Types.Custom (MapKind, Pair (..), mapKindFromList)
+import Data.Morpheus.Types.GQLScalar (GQLScalar (..))
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (ResolveT, failResolveT)
+import Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..))
+import Data.Morpheus.Types.Resolver (Effect (..), EffectT (..), Resolver)
+
+type SelectRes m a = [(Text, (Text, Selection) -> ResolveT m a)] -> (Text, Selection) -> ResolveT m (Text, a)
+
+type ResolveSel m a = [(Text, Selection)] -> [(Text, (Text, Selection) -> ResolveT m a)] -> ResolveT m a
+
+--
+-- OBJECT
+-- | Derives resolvers by object fields
+class ObjectFieldResolvers f m where
+ objectFieldResolvers :: Text -> f a -> [(Text, (Text, Selection) -> ResolveT m Value)]
+
+instance ObjectFieldResolvers U1 res where
+ objectFieldResolvers _ _ = []
+
+instance (Selector s, ObjectFieldResolvers f res) => ObjectFieldResolvers (M1 S s f) res where
+ objectFieldResolvers _ m@(M1 src) = objectFieldResolvers (pack $ selName m) src
+
+instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 D c f) res where
+ objectFieldResolvers key' (M1 src) = objectFieldResolvers key' src
+
+instance ObjectFieldResolvers f res => ObjectFieldResolvers (M1 C c f) res where
+ objectFieldResolvers key' (M1 src) = objectFieldResolvers key' src
+
+instance (ObjectFieldResolvers f res, ObjectFieldResolvers g res) => ObjectFieldResolvers (f :*: g) res where
+ objectFieldResolvers meta (a :*: b) = objectFieldResolvers meta a ++ objectFieldResolvers meta b
+
+unwrapMonadTuple :: Monad m => (Text, m a) -> m (Text, a)
+unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x)
+
+selectResolver :: Monad m => a -> SelectRes m a
+selectResolver defaultValue resolvers' (key', selection') =
+ case selectionRec selection' of
+ SelectionAlias name' aliasSelection' ->
+ unwrapMonadTuple (key', lookupResolver name' (selection' {selectionRec = aliasSelection'}))
+ _ -> unwrapMonadTuple (key', lookupResolver key' selection')
+ where
+ lookupResolver resolverKey' sel =
+ (fromMaybe (const $ return $defaultValue) $ lookup resolverKey' resolvers') (key', sel)
+
+--
+-- UNION
+--
+class UnionResolvers f m where
+ unionResolvers :: f a -> (Text, (Text, Selection) -> ResolveT m Value)
+
+instance UnionResolvers f res => UnionResolvers (M1 S s f) res where
+ unionResolvers (M1 x) = unionResolvers x
+
+instance UnionResolvers f res => UnionResolvers (M1 D c f) res where
+ unionResolvers (M1 x) = unionResolvers x
+
+instance UnionResolvers f res => UnionResolvers (M1 C c f) res where
+ unionResolvers (M1 x) = unionResolvers x
+
+instance (UnionResolvers a res, UnionResolvers b res) => UnionResolvers (a :+: b) res where
+ unionResolvers (L1 x) = unionResolvers x
+ unionResolvers (R1 x) = unionResolvers x
+
+type ObjectConstraint a m = (Monad m, Generic a, GQLType a, ObjectFieldResolvers (Rep a) m)
+
+type UnionConstraint a m = (Monad m, Generic a, GQLType a, UnionResolvers (Rep a) m)
+
+type EnumConstraint a = (Generic a, EnumRep (Rep a))
+
+type QueryResult = Value
+
+newtype WithGQLKind a b = WithGQLKind
+ { resolverValue :: a
+ }
+
+type GQLKindOf a = WithGQLKind a (KIND a)
+
+encode ::
+ forall a m. Encoder a (KIND a) m
+ => a
+ -> (Text, Selection)
+ -> ResolveT m Value
+encode resolver = __encode (WithGQLKind resolver :: GQLKindOf a)
+
+class Encoder a kind m where
+ __encode :: WithGQLKind a kind -> (Text, Selection) -> ResolveT m Value
+
+--
+-- SCALAR
+--
+instance (GQLScalar a, Monad m) => Encoder a SCALAR m where
+ __encode = pure . pure . Scalar . serialize . resolverValue
+
+--
+-- ENUM
+--
+instance (EnumConstraint a, Monad m) => Encoder a ENUM m where
+ __encode = pure . pure . Scalar . String . encodeRep . from . resolverValue
+
+--
+-- OBJECTS
+--
+instance ObjectConstraint a m => Encoder a OBJECT m where
+ __encode (WithGQLKind value) (_, Selection {selectionRec = SelectionSet selection'}) =
+ resolveBySelection selection' (__typenameResolver : resolversBy value)
+ where
+ __typenameResolver = ("__typename", const $ return $ Scalar $ String $ __typeName (Proxy @a))
+ __encode _ (key, Selection {selectionPosition}) = failResolveT $ subfieldsNotSelected key "" selectionPosition
+
+resolveBySelection :: Monad m => ResolveSel m Value
+resolveBySelection selection resolvers = Object <$> mapM (selectResolver Null resolvers) selection
+
+resolversBy ::
+ (Generic a, Monad m, ObjectFieldResolvers (Rep a) m) => a -> [(Text, (Text, Selection) -> ResolveT m Value)]
+resolversBy = objectFieldResolvers "" . from
+
+instance Encoder a (KIND a) res => ObjectFieldResolvers (K1 s a) res where
+ objectFieldResolvers key' (K1 src) = [(key', encode src)]
+
+-- | Resolves and encodes UNION,
+-- Handles all operators: Query, Mutation and Subscription,
+instance UnionConstraint a m => Encoder a UNION m where
+ __encode (WithGQLKind value) (key', sel@Selection {selectionRec = UnionSelection selections'}) =
+ resolver (key', sel {selectionRec = SelectionSet lookupSelection})
+ where
+ lookupSelection :: SelectionSet
+ -- SPEC: if there is no any fragment that supports current object Type GQL returns {}
+ lookupSelection = fromMaybe [] $ lookup typeName selections'
+ (typeName, resolver) = unionResolvers (from value)
+ __encode _ _ = internalErrorT "union Resolver only should recieve UnionSelection"
+
+instance (GQLType a, Encoder a (KIND a) res) => UnionResolvers (K1 s a) res where
+ unionResolvers (K1 src) = (__typeName (Proxy @a), encode src)
+
+--
+-- RESOLVER: ::-> and ::->>
+--
+-- | Handles all operators: Query, Mutation and Subscription,
+-- if you use it with Mutation or Subscription all effects inside will be lost
+instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) m) => Encoder (a -> Resolver m b) WRAPPER m where
+ __encode (WithGQLKind resolver) selection'@(fieldName, Selection {selectionArguments, selectionPosition}) = do
+ args <- ExceptT $ pure $ decodeArguments selectionArguments
+ lift (runExceptT $ resolver args) >>= liftEither selectionPosition fieldName >>= (`encode` selection')
+
+liftEither :: Monad m => Position -> Text -> Either String a -> ResolveT m a
+liftEither position name (Left message) = failResolveT $ fieldNotResolved position name (pack message)
+liftEither _ _ (Right value) = pure value
+
+-- packs Monad in EffectMonad
+instance (Monad m, Encoder a (KIND a) m, ArgumentsConstraint p) => Encoder (p -> Either String a) WRAPPER m where
+ __encode (WithGQLKind resolver) selection'@(fieldName, Selection {selectionArguments, selectionPosition}) =
+ case decodeArguments selectionArguments of
+ Left message -> failResolveT message
+ Right value -> liftEither selectionPosition fieldName (resolver value) >>= (`encode` selection')
+
+-- packs Monad in EffectMonad
+instance (ArgumentsConstraint a, Monad m, Encoder b (KIND b) m) =>
+ Encoder (a -> Resolver m b) WRAPPER (EffectT m c) where
+ __encode resolver selection = ExceptT $ EffectT $ Effect [] <$> runExceptT (__encode resolver selection)
+
+--
+-- MAYBE
+--
+instance (Monad m, Encoder a (KIND a) m) => Encoder (Maybe a) WRAPPER m where
+ __encode (WithGQLKind Nothing) = const $ pure Null
+ __encode (WithGQLKind (Just value)) = encode value
+
+--
+-- LIST
+--
+instance (Monad m, Encoder a (KIND a) m) => Encoder [a] WRAPPER m where
+ __encode (WithGQLKind list) query = List <$> mapM (`__encode` query) (map WithGQLKind list :: [GQLKindOf a])
+
+--
+-- Tuple
+--
+instance Encoder (Pair k v) OBJECT m => Encoder (k, v) WRAPPER m where
+ __encode (WithGQLKind (key, value)) = encode (Pair key value)
+
+--
+-- Set
+--
+instance Encoder [a] WRAPPER m => Encoder (Set a) WRAPPER m where
+ __encode (WithGQLKind dataSet) = encode (S.toList dataSet)
+
+--
+-- Map
+--
+instance (Eq k, Monad m, Encoder (MapKind k v (Resolver m)) OBJECT m) => Encoder (Map k v) WRAPPER m where
+ __encode (WithGQLKind value) = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver m))
diff --git a/src/Data/Morpheus/Resolve/Generics/EnumRep.hs b/src/Data/Morpheus/Resolve/Generics/EnumRep.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Generics/EnumRep.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Resolve.Generics.EnumRep
+ ( EnumRep(..)
+ ) where
+
+import Data.Proxy (Proxy (..))
+import Data.Text (Text, pack)
+import GHC.Generics
+
+class EnumRep f where
+ encodeRep :: f a -> Text
+ gToEnum :: Text -> f a
+ tagName :: Proxy f -> Text
+ getTags :: Proxy f -> [Text]
+
+instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where
+ encodeRep (M1 src) = encodeRep src
+ gToEnum = M1 . gToEnum
+ tagName _ = ""
+ getTags _ = getTags (Proxy :: Proxy f)
+
+instance (Constructor c) => EnumRep (M1 C c U1) where
+ encodeRep m@(M1 _) = pack $ conName m
+ gToEnum _ = M1 U1
+ tagName _ = pack $ conName (undefined :: (M1 C c U1 x))
+ getTags proxy = [tagName proxy]
+
+instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where
+ encodeRep (L1 x) = encodeRep x
+ encodeRep (R1 x) = encodeRep x
+ gToEnum name =
+ if tagName (Proxy @a) == name
+ then L1 $ gToEnum name
+ else R1 $ gToEnum name
+ tagName _ = ""
+ getTags _ = getTags (Proxy @a) ++ getTags (Proxy @b)
diff --git a/src/Data/Morpheus/Resolve/Generics/TypeRep.hs b/src/Data/Morpheus/Resolve/Generics/TypeRep.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Generics/TypeRep.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Resolve.Generics.TypeRep
+ ( UnionRep(..)
+ , ObjectRep(..)
+ , TypeUpdater
+ , SelOf
+ , RecSel
+ , resolveTypes
+ ) where
+
+import Control.Monad (foldM)
+import Data.Function ((&))
+import Data.Morpheus.Types.Internal.Data (DataField, DataTypeLib)
+import Data.Morpheus.Types.Internal.Validation (SchemaValidation)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import GHC.Generics
+
+type SelOf s = M1 S s (Rec0 ()) ()
+
+type RecSel s a = M1 S s (Rec0 a)
+
+type TypeUpdater = DataTypeLib -> SchemaValidation DataTypeLib
+
+{-
+ introspect Union Types
+-}
+class UnionRep f where
+ possibleTypes :: Proxy f -> [(DataField (), TypeUpdater)]
+
+instance UnionRep f => UnionRep (M1 D x f) where
+ possibleTypes _ = possibleTypes (Proxy @f)
+
+instance UnionRep f => UnionRep (M1 C x f) where
+ possibleTypes _ = possibleTypes (Proxy @f)
+
+instance (UnionRep a, UnionRep b) => UnionRep (a :+: b) where
+ possibleTypes _ = possibleTypes (Proxy @a) ++ possibleTypes (Proxy @b)
+
+{-
+ introspect Input and Output Object Types
+-}
+resolveTypes :: DataTypeLib -> [TypeUpdater] -> SchemaValidation DataTypeLib
+resolveTypes = foldM (&)
+
+class ObjectRep rep t where
+ objectFieldTypes :: Proxy rep -> [((Text, DataField t), TypeUpdater)]
+
+instance ObjectRep f t => ObjectRep (M1 D x f) t where
+ objectFieldTypes _ = objectFieldTypes (Proxy @f)
+
+instance ObjectRep f t => ObjectRep (M1 C x f) t where
+ objectFieldTypes _ = objectFieldTypes (Proxy @f)
+
+instance (ObjectRep a t, ObjectRep b t) => ObjectRep (a :*: b) t where
+ objectFieldTypes _ = objectFieldTypes (Proxy @a) ++ objectFieldTypes (Proxy @b)
+
+instance ObjectRep U1 t where
+ objectFieldTypes _ = []
diff --git a/src/Data/Morpheus/Resolve/Introspect.hs b/src/Data/Morpheus/Resolve/Introspect.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Introspect.hs
@@ -0,0 +1,244 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Morpheus.Resolve.Introspect
+ ( introspectOutputType
+ ) where
+
+import Data.Map (Map)
+import Data.Morpheus.Error.Schema (nameCollisionError)
+import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION, WRAPPER)
+import Data.Morpheus.Resolve.Generics.EnumRep (EnumRep (..))
+import Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), RecSel, SelOf, TypeUpdater, UnionRep (..),
+ resolveTypes)
+import Data.Morpheus.Types.Custom (MapKind, Pair)
+import Data.Morpheus.Types.GQLScalar (GQLScalar (..))
+import Data.Morpheus.Types.GQLType (GQLType (..))
+import Data.Morpheus.Types.Internal.Data (DataArguments, DataField (..), DataFullType (..),
+ DataInputField, DataLeaf (..), DataType (..),
+ DataTypeKind (..), DataTypeWrapper (..), DataValidator,
+ defineType, isTypeDefined)
+import Data.Morpheus.Types.Resolver (Resolver)
+import Data.Proxy (Proxy (..))
+import Data.Set (Set)
+import Data.Text (Text, pack)
+import GHC.Generics
+
+-- class Types class
+type GQL_TYPE a = (Generic a, GQLType a)
+
+type EnumConstraint a = (GQL_TYPE a, EnumRep (Rep a))
+
+type InputObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) ())
+
+type ObjectConstraint a = (GQL_TYPE a, ObjectRep (Rep a) DataArguments)
+
+type UnionConstraint a = (GQL_TYPE a, UnionRep (Rep a))
+
+scalarTypeOf :: GQLType a => DataValidator -> Proxy a -> DataFullType
+scalarTypeOf validator = Leaf . LeafScalar . buildType validator
+
+enumTypeOf :: GQLType a => [Text] -> Proxy a -> DataFullType
+enumTypeOf tags' = Leaf . LeafEnum . buildType tags'
+
+type InputType = ()
+
+type OutputType = DataArguments
+
+type InputOf t = Context t (KIND t) InputType
+
+type OutputOf t = Context t (KIND t) OutputType
+
+introspectOutputType ::
+ forall a. Introspect a (KIND a) OutputType
+ => Proxy a
+ -> TypeUpdater
+introspectOutputType _ = introspect (Context :: OutputOf a)
+
+-- | context , like Proxy with multiple parameters
+-- contains types of :
+-- * 'a': actual gql type
+-- * 'kind': object, scalar, enum ...
+-- * 'args': InputType | OutputType
+data Context a kind args =
+ Context
+
+buildField :: GQLType a => DataTypeKind -> Proxy a -> t -> Text -> DataField t
+buildField fieldKind proxy' fieldArgs fieldName =
+ DataField
+ { fieldName
+ , fieldKind
+ , fieldArgs
+ , fieldTypeWrappers = [NonNullType]
+ , fieldType = __typeName proxy'
+ , fieldHidden = False
+ }
+
+buildType :: GQLType a => t -> Proxy a -> DataType t
+buildType typeData proxy =
+ DataType
+ { typeName = __typeName proxy
+ , typeFingerprint = __typeFingerprint proxy
+ , typeDescription = description proxy
+ , typeData
+ }
+
+updateLib :: GQLType a => (Proxy a -> DataFullType) -> [TypeUpdater] -> Proxy a -> TypeUpdater
+updateLib typeBuilder stack proxy lib' =
+ case isTypeDefined (__typeName proxy) lib' of
+ Nothing -> resolveTypes (defineType (__typeName proxy, typeBuilder proxy) lib') stack
+ Just fingerprint'
+ | fingerprint' == __typeFingerprint proxy -> return lib'
+ -- throw error if 2 different types has same name
+ Just _ -> Left $ nameCollisionError (__typeName proxy)
+
+-- | Generates internal GraphQL Schema for query validation and introspection rendering
+-- * 'kind': object, scalar, enum ...
+-- * 'args': type of field arguments
+-- * '()' for 'input values' , they are just JSON properties and does not have any argument
+-- * 'DataArguments' for field Resolvers Types, where 'DataArguments' is type of arguments
+class Introspect a kind args where
+ __field :: Context a kind args -> Text -> DataField args
+ -- generates data field representation of object field
+ -- according to parameter 'args' it could be
+ -- * input object field: if args is '()'
+ -- * object: if args is 'DataArguments'
+ introspect :: Context a kind args -> TypeUpdater -- Generates internal GraphQL Schema
+
+type OutputConstraint a = Introspect a (KIND a) DataArguments
+
+--
+-- SCALAR
+--
+instance (GQLScalar a, GQLType a) => Introspect a SCALAR InputType where
+ __field _ = buildField KindScalar (Proxy @a) ()
+ introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)
+
+instance (GQLScalar a, GQLType a) => Introspect a SCALAR OutputType where
+ __field _ = buildField KindScalar (Proxy @a) []
+ introspect _ = updateLib (scalarTypeOf (scalarValidator $ Proxy @a)) [] (Proxy @a)
+
+--
+-- ENUM
+--
+instance EnumConstraint a => Introspect a ENUM InputType where
+ __field _ = buildField KindEnum (Proxy @a) ()
+ introspect _ = introspectEnum (Context :: InputOf a)
+
+instance EnumConstraint a => Introspect a ENUM OutputType where
+ __field _ = buildField KindEnum (Proxy @a) []
+ introspect _ = introspectEnum (Context :: OutputOf a)
+
+introspectEnum ::
+ forall a f. (GQLType a, EnumRep (Rep a))
+ => Context a (KIND a) f
+ -> TypeUpdater
+introspectEnum _ = updateLib (enumTypeOf $ getTags (Proxy @(Rep a))) [] (Proxy @a)
+
+--
+-- OBJECTS , INPUT_OBJECT
+--
+instance InputObjectConstraint a => Introspect a INPUT_OBJECT InputType where
+ __field _ = buildField KindInputObject (Proxy @a) ()
+ introspect _ = updateLib (InputObject . buildType fields') stack' (Proxy @a)
+ where
+ (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))
+
+instance ObjectConstraint a => Introspect a OBJECT OutputType where
+ __field _ = buildField KindObject (Proxy @a) []
+ introspect _ = updateLib (OutputObject . buildType (__typename : fields')) stack' (Proxy @a)
+ where
+ __typename =
+ ( "__typename"
+ , DataField
+ { fieldName = "__typename"
+ , fieldKind = KindScalar
+ , fieldArgs = []
+ , fieldTypeWrappers = []
+ , fieldType = "String"
+ , fieldHidden = True
+ })
+ (fields', stack') = unzip $ objectFieldTypes (Proxy @(Rep a))
+
+-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'
+-- iterates on field types and introspects them recursively
+instance (Selector s, Introspect a (KIND a) f) => ObjectRep (RecSel s a) f where
+ objectFieldTypes _ =
+ [((name, __field (Context :: Context a (KIND a) f) name), introspect (Context :: Context a (KIND a) f))]
+ where
+ name = pack $ selName (undefined :: SelOf s)
+
+--
+-- UNION
+--
+-- | recursion for union types
+-- iterates on possible types for UNION and introspects them recursively
+instance (OutputConstraint a, ObjectConstraint a) => UnionRep (RecSel s a) where
+ possibleTypes _ = [(buildField KindObject (Proxy @a) () "", introspect (Context :: OutputOf a))]
+
+instance UnionConstraint a => Introspect a UNION OutputType where
+ __field _ = buildField KindUnion (Proxy @a) []
+ introspect _ = updateLib (Union . buildType fields) stack (Proxy @a)
+ where
+ (fields, stack) = unzip $ possibleTypes (Proxy @(Rep a))
+
+--
+-- WRAPPER : Maybe, LIST , Resolver
+--
+instance Introspect a (KIND a) f => Introspect (Maybe a) WRAPPER f where
+ __field _ name = maybeField $ __field (Context :: Context a (KIND a) f) name
+ where
+ maybeField :: DataField f -> DataField f
+ maybeField field@DataField {fieldTypeWrappers = NonNullType:xs} = field {fieldTypeWrappers = xs}
+ maybeField field = field
+ introspect _ = introspect (Context :: Context a (KIND a) f)
+
+instance Introspect a (KIND a) f => Introspect [a] WRAPPER f where
+ __field _ name = listField (__field (Context :: Context a (KIND a) f) name)
+ where
+ listField :: DataField f -> DataField f
+ listField x = x {fieldTypeWrappers = [NonNullType, ListType] ++ fieldTypeWrappers x}
+ introspect _ = introspect (Context :: Context a (KIND a) f)
+
+--
+-- CUSTOM Types: Tuple, Map, Set
+--
+instance Introspect (Pair k v) OBJECT f => Introspect (k, v) WRAPPER f where
+ __field _ = __field (Context :: Context (Pair k v) OBJECT f)
+ introspect _ = introspect (Context :: Context (Pair k v) OBJECT f)
+
+instance Introspect [a] WRAPPER f => Introspect (Set a) WRAPPER f where
+ __field _ = __field (Context :: Context [a] WRAPPER f)
+ introspect _ = introspect (Context :: Context [a] WRAPPER f)
+
+-- | introspection Does not care about resolving monad, some fake monad just for mocking
+type MockRes = (Resolver Maybe)
+
+instance Introspect (MapKind k v MockRes) OBJECT f => Introspect (Map k v) WRAPPER f where
+ __field _ = __field (Context :: Context (MapKind k v MockRes) OBJECT f)
+ introspect _ = introspect (Context :: Context (MapKind k v MockRes) OBJECT f)
+
+-- |introspects Of Resolver 'a' as argument and 'b' as output type
+instance (ObjectRep (Rep a) (), OutputConstraint b) => Introspect (a -> Resolver m b) WRAPPER OutputType where
+ __field _ name = (__field (Context :: OutputOf b) name) {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}
+ introspect _ typeLib = resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]
+ where
+ args :: [((Text, DataInputField), TypeUpdater)]
+ args = objectFieldTypes (Proxy @(Rep a))
+
+instance (ObjectRep (Rep a) (), OutputConstraint b) => Introspect (a -> Either String b) WRAPPER OutputType where
+ __field _ name = (__field (Context :: OutputOf b) name) {fieldArgs = map fst $ objectFieldTypes (Proxy @(Rep a))}
+ introspect _ typeLib = resolveTypes typeLib $ map snd args ++ [introspect (Context :: OutputOf b)]
+ where
+ args :: [((Text, DataInputField), TypeUpdater)]
+ args = objectFieldTypes (Proxy @(Rep a))
diff --git a/src/Data/Morpheus/Resolve/Operator.hs b/src/Data/Morpheus/Resolve/Operator.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Operator.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Resolve.Operator
+ ( RootResCon
+ , fullSchema
+ , encodeQuery
+ , effectEncode
+ ) where
+
+import Data.Morpheus.Resolve.Encode (ObjectFieldResolvers (..), resolveBySelection, resolversBy)
+import Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), TypeUpdater, resolveTypes)
+import Data.Morpheus.Schema.SchemaAPI (hiddenRootFields, schemaAPI, schemaTypes)
+import Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)
+import Data.Morpheus.Types.Internal.Data (DataArguments, DataFingerprint (..), DataType (..),
+ DataTypeLib (..), initTypeLib)
+import Data.Morpheus.Types.Internal.Validation (ResolveT, SchemaValidation)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Morpheus.Types.Resolver (EffectT (..))
+import Data.Proxy
+import Data.Text (Text)
+import Data.Typeable (Typeable)
+import GHC.Generics
+
+type RootResCon m a b c = (OperatorCon m a, OperatorEffectCon m b, OperatorEffectCon m c)
+
+type OperatorCon m a = (IntroCon a, EncodeCon m a)
+
+type OperatorEffectCon m a = (IntroCon a, EncodeCon (EffectT m Text) a)
+
+type Encode m a = ResolveT m a -> SelectionSet -> ResolveT m Value
+
+type EncodeCon m a = (Generic a, ObjectFieldResolvers (Rep a) m)
+
+type BaseEncode m a
+ = EncodeCon m a =>
+ DataTypeLib -> Encode m a
+
+type EffectEncode m a
+ = EncodeCon (EffectT m Text) a =>
+ Encode (EffectT m Text) a
+
+encodeQuery :: Monad m => BaseEncode m a
+encodeQuery types rootResolver sel =
+ fmap resolversBy rootResolver >>= resolveBySelection sel . (++) (resolversBy $ schemaAPI types)
+
+effectEncode :: Monad m => EffectEncode m a
+effectEncode rootResolver sel = rootResolver >>= resolveBySelection sel . resolversBy
+
+type IntroCon a = (Generic a, ObjectRep (Rep a) DataArguments, Typeable a)
+
+fullSchema ::
+ forall m a b c. (IntroCon a, IntroCon b, IntroCon c)
+ => ResolveT m a
+ -> ResolveT (EffectT m Text) b
+ -> ResolveT (EffectT m Text) c
+ -> SchemaValidation DataTypeLib
+fullSchema queryRes mutationRes subscriptionRes =
+ querySchema queryRes >>= mutationSchema mutationRes >>= subscriptionSchema subscriptionRes
+ where
+ querySchema _ = resolveTypes queryType (schemaTypes : types)
+ where
+ queryType = initTypeLib (operatorType "Query" (hiddenRootFields ++ fields))
+ (fields, types) = unzip $ objectFieldTypes (Proxy @(Rep a))
+
+mutationSchema ::
+ forall a m. IntroCon a
+ => m a
+ -> TypeUpdater
+mutationSchema _ initialType = resolveTypes mutationType types'
+ where
+ mutationType = initialType {mutation = Just $ operatorType "Mutation" fields'}
+ (fields', types') = unzip $ objectFieldTypes (Proxy :: Proxy (Rep a))
+
+subscriptionSchema ::
+ forall a m. IntroCon a
+ => m a
+ -> TypeUpdater
+subscriptionSchema _ initialType = resolveTypes mutationType types'
+ where
+ mutationType = initialType {subscription = Just $ operatorType "Subscription" fields'}
+ (fields', types') = unzip $ objectFieldTypes (Proxy :: Proxy (Rep a))
+
+operatorType :: Text -> a -> (Text, DataType a)
+operatorType name' fields' =
+ ( name'
+ , DataType {typeData = fields', typeName = name', typeFingerprint = SystemFingerprint name', typeDescription = ""})
diff --git a/src/Data/Morpheus/Resolve/Resolve.hs b/src/Data/Morpheus/Resolve/Resolve.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Resolve/Resolve.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Resolve.Resolve
+ ( resolve
+ , resolveByteString
+ , resolveStreamByteString
+ , resolveStream
+ , packStream
+ ) where
+
+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Data.Aeson (eitherDecode, encode)
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus.Error.Utils (badRequestError, renderErrors)
+import Data.Morpheus.Parser.Parser (parseGQL)
+import Data.Morpheus.Resolve.Operator (RootResCon, effectEncode, encodeQuery, fullSchema)
+import Data.Morpheus.Server.ClientRegister (GQLState, publishUpdates)
+import Data.Morpheus.Types.IO (GQLRequest(..), GQLResponse(..))
+import Data.Morpheus.Types.Internal.AST.Operator (Operator(..), Operator'(..))
+import Data.Morpheus.Types.Internal.WebSocket (OutputAction(..))
+import Data.Morpheus.Types.Resolver (GQLRootResolver(..), unpackEffect, unpackEffect2)
+import Data.Morpheus.Validation.Validation (validateRequest)
+
+resolveByteString ::
+ Monad m
+ => RootResCon m a b c =>
+ GQLRootResolver m a b c -> ByteString -> m ByteString
+resolveByteString rootResolver request =
+ case eitherDecode request of
+ Left aesonError' -> return $ badRequestError aesonError'
+ Right req -> encode <$> resolve rootResolver req
+
+resolveStreamByteString ::
+ Monad m
+ => RootResCon m a b c =>
+ GQLRootResolver m a b c -> ByteString -> m (OutputAction m ByteString)
+resolveStreamByteString rootResolver request =
+ case eitherDecode request of
+ Left aesonError' -> return $ NoEffect $ badRequestError aesonError'
+ Right req -> fmap encode <$> resolveStream rootResolver req
+
+resolve ::
+ Monad m
+ => RootResCon m a b c =>
+ GQLRootResolver m a b c -> GQLRequest -> m GQLResponse
+resolve GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =
+ case fullSchema queryResolver mutationResolver subscriptionResolver of
+ Left error' -> return $ Errors $ renderErrors error'
+ Right validSchema -> do
+ value <- runExceptT $ _resolve validSchema
+ case value of
+ Left x -> return $ Errors $ renderErrors x
+ Right x -> return $ Data x
+ where _resolve gqlSchema = do
+ rootGQL <- ExceptT $ pure (parseGQL request >>= validateRequest gqlSchema)
+ case rootGQL of
+ Query operator' -> encodeQuery gqlSchema queryResolver $ operatorSelection operator'
+ Mutation operator' ->
+ snd <$> unpackEffect2 (effectEncode mutationResolver (operatorSelection operator'))
+ Subscription operator' ->
+ snd <$> unpackEffect2 (effectEncode subscriptionResolver (operatorSelection operator'))
+
+resolveStream ::
+ Monad m
+ => RootResCon m a b c =>
+ GQLRootResolver m a b c -> GQLRequest -> m (OutputAction m GQLResponse)
+resolveStream GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request =
+ case fullSchema queryResolver mutationResolver subscriptionResolver of
+ Left error' -> return $ NoEffect $ Errors $ renderErrors error'
+ Right validSchema -> do
+ value <- runExceptT $ _resolve validSchema
+ case value of
+ Left x -> return $ NoEffect $ Errors $ renderErrors x
+ Right value' -> return $ fmap Data value'
+ where
+ _resolve gqlSchema = (ExceptT $ pure (parseGQL request >>= validateRequest gqlSchema)) >>= resolveOperator
+ where
+ resolveOperator (Query operator') = do
+ value <- encodeQuery gqlSchema queryResolver $ operatorSelection operator'
+ return (NoEffect value)
+ resolveOperator (Mutation operator') = do
+ (channels, response) <- unpackEffect2 $ effectEncode mutationResolver $ operatorSelection operator'
+ return
+ PublishMutation {mutationChannels = channels, mutationResponse = response, currentSubscriptionStateResolver}
+ where
+ currentSubscriptionStateResolver selection' = do
+ value <- unpackEffect (effectEncode subscriptionResolver selection')
+ case value of
+ Left x -> pure $ Errors $ renderErrors x
+ Right (_, x') -> return $ Data x'
+ resolveOperator (Subscription operator') = do
+ (subscriptionChannels, _) <- unpackEffect2 $ effectEncode subscriptionResolver $ operatorSelection operator'
+ return InitSubscription {subscriptionChannels, subscriptionQuery = operatorSelection operator'}
+
+packStream :: GQLState -> (ByteString -> IO (OutputAction IO ByteString)) -> ByteString -> IO ByteString
+packStream state streamAPI request = do
+ value <- streamAPI request
+ case value of
+ PublishMutation {mutationChannels, mutationResponse, currentSubscriptionStateResolver} -> do
+ publishUpdates mutationChannels currentSubscriptionStateResolver state
+ return mutationResponse
+ InitSubscription {} -> pure "subscriptions are only allowed in websocket"
+ NoEffect res' -> return res'
diff --git a/src/Data/Morpheus/Schema/Directive.hs b/src/Data/Morpheus/Schema/Directive.hs
--- a/src/Data/Morpheus/Schema/Directive.hs
+++ b/src/Data/Morpheus/Schema/Directive.hs
@@ -1,21 +1,27 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Schema.Directive
( Directive(..)
) where
-import Data.Data (Data)
-import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation)
-import Data.Morpheus.Schema.Utils.Utils (InputValue)
-import Data.Morpheus.Types.Describer (EnumOf (..))
-import Data.Text (Text)
-import GHC.Generics
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation)
+import Data.Morpheus.Schema.Internal.RenderIntrospection (InputValue)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+type instance KIND Directive = OBJECT
+
+instance GQLType Directive where
+ __typeName = const "__Directive"
+
data Directive = Directive
{ name :: Text
, description :: Maybe Text
- , locations :: [EnumOf DirectiveLocation]
+ , locations :: [DirectiveLocation]
, args :: [InputValue]
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
diff --git a/src/Data/Morpheus/Schema/DirectiveLocation.hs b/src/Data/Morpheus/Schema/DirectiveLocation.hs
--- a/src/Data/Morpheus/Schema/DirectiveLocation.hs
+++ b/src/Data/Morpheus/Schema/DirectiveLocation.hs
@@ -1,13 +1,17 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Schema.DirectiveLocation
( DirectiveLocation(..)
) where
-import Data.Data (Data)
+import Data.Morpheus.Kind (ENUM, KIND)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
import GHC.Generics
+type instance KIND DirectiveLocation = ENUM
+
data DirectiveLocation
= QUERY
| MUTATION
@@ -16,6 +20,7 @@
| FRAGMENT_DEFINITION
| FRAGMENT_SPREAD
| INLINE_FRAGMENT
+ | VARIABLE_DEFINITION
| SCHEMA
| SCALAR
| OBJECT
@@ -27,4 +32,7 @@
| ENUM_VALUE
| INPUT_OBJECT
| INPUT_FIELD_DEFINITION
- deriving (Show, Data, Generic)
+ deriving (Generic)
+
+instance GQLType DirectiveLocation where
+ __typeName = const "__DirectiveLocation"
diff --git a/src/Data/Morpheus/Schema/EnumValue.hs b/src/Data/Morpheus/Schema/EnumValue.hs
--- a/src/Data/Morpheus/Schema/EnumValue.hs
+++ b/src/Data/Morpheus/Schema/EnumValue.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Schema.EnumValue
( EnumValue(..)
@@ -7,16 +8,22 @@
, isEnumOf
) where
-import Data.Data (Data)
-import Data.Text (Text)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Text (Text)
import GHC.Generics
+type instance KIND EnumValue = OBJECT
+
+instance GQLType EnumValue where
+ __typeName = const "__EnumValue"
+
data EnumValue = EnumValue
{ name :: Text
, description :: Maybe Text
, isDeprecated :: Bool
, deprecationReason :: Maybe Text
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
createEnumValue :: Text -> EnumValue
createEnumValue enumName =
diff --git a/src/Data/Morpheus/Schema/Field.hs b/src/Data/Morpheus/Schema/Field.hs
--- a/src/Data/Morpheus/Schema/Field.hs
+++ b/src/Data/Morpheus/Schema/Field.hs
@@ -1,29 +1,38 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Schema.Field where
-import Data.Data (Data)
-import Data.Morpheus.Schema.InputValue (InputValue)
-import Data.Text (Text)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Schema.InputValue (InputValue)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Morpheus.Types.Internal.Value (convertToJSONName)
+import Data.Text (Text)
+import Data.Typeable (Typeable)
import GHC.Generics
+type instance KIND (Field a) = OBJECT
+
+instance Typeable a => GQLType (Field a) where
+ __typeName = const "__Field"
+
data Field t = Field
{ name :: Text
, description :: Maybe Text
, args :: [InputValue t]
- , _type :: t
+ , type' :: t
, isDeprecated :: Bool
, deprecationReason :: Maybe Text
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
createFieldWith :: Text -> a -> [InputValue a] -> Field a
createFieldWith _name fieldType fieldArgs =
Field
- { name = _name
+ { name = convertToJSONName _name
, description = Nothing
, args = fieldArgs
- , _type = fieldType
+ , type' = fieldType
, isDeprecated = False
, deprecationReason = Nothing
}
diff --git a/src/Data/Morpheus/Schema/InputValue.hs b/src/Data/Morpheus/Schema/InputValue.hs
--- a/src/Data/Morpheus/Schema/InputValue.hs
+++ b/src/Data/Morpheus/Schema/InputValue.hs
@@ -1,22 +1,31 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Schema.InputValue
( InputValue(..)
, createInputValueWith
) where
-import Data.Data (Data)
-import Data.Text (Text)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Text (Text)
+import Data.Typeable (Typeable)
import GHC.Generics
+type instance KIND (InputValue a) = OBJECT
+
+instance Typeable a => GQLType (InputValue a) where
+ __typeName = const "__InputValue"
+
data InputValue t = InputValue
{ name :: Text
, description :: Maybe Text
- , _type :: t
+ , type' :: t
, defaultValue :: Maybe Text
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
createInputValueWith :: Text -> a -> InputValue a
createInputValueWith _name ofType =
- InputValue {name = _name, description = Nothing, _type = ofType, defaultValue = Nothing}
+ InputValue {name = _name, description = Nothing, type' = ofType, defaultValue = Nothing}
diff --git a/src/Data/Morpheus/Schema/Internal/RenderIntrospection.hs b/src/Data/Morpheus/Schema/Internal/RenderIntrospection.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Schema/Internal/RenderIntrospection.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Schema.Internal.RenderIntrospection
+ ( Type
+ , Field
+ , InputValue
+ , renderType
+ , createObjectType
+ ) where
+
+import Data.Morpheus.Schema.EnumValue (EnumValue, createEnumValue)
+import qualified Data.Morpheus.Schema.Field as F (Field (..), createFieldWith)
+import qualified Data.Morpheus.Schema.InputValue as IN (InputValue (..), createInputValueWith)
+import Data.Morpheus.Schema.Type (Type (..))
+import Data.Morpheus.Schema.TypeKind (TypeKind (..))
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataInputField, DataInputObject,
+ DataLeaf (..), DataOutputField, DataOutputObject, DataType (..),
+ DataTypeKind (..), DataTypeWrapper (..), DataUnion)
+import Data.Text (Text)
+
+renderType :: (Text, DataFullType) -> Type
+renderType (name', Leaf leaf') = typeFromLeaf (name', leaf')
+renderType (name', InputObject iObject') = typeFromInputObject (name', iObject')
+renderType (name', OutputObject object') = typeFromObject (name', object')
+renderType (name', Union union') = typeFromUnion (name', union')
+
+type InputValue = IN.InputValue Type
+
+type Field = F.Field Type
+
+inputValueFromArg :: (Text, DataInputField) -> InputValue
+inputValueFromArg (key', input') = IN.createInputValueWith key' (createInputObjectType input')
+
+renderTypeKind :: DataTypeKind -> TypeKind
+renderTypeKind KindScalar = SCALAR
+renderTypeKind KindObject = OBJECT
+renderTypeKind KindUnion = UNION
+renderTypeKind KindEnum = ENUM
+renderTypeKind KindInputObject = INPUT_OBJECT
+renderTypeKind KindList = LIST
+renderTypeKind KindNonNull = NON_NULL
+
+createInputObjectType :: DataInputField -> Type
+createInputObjectType field' =
+ wrap field' $ createType (renderTypeKind $ fieldKind field') (fieldType field') "" $ Just []
+
+wrap :: DataField a -> Type -> Type
+wrap field' = wrapRec (fieldTypeWrappers field')
+
+wrapRec :: [DataTypeWrapper] -> Type -> Type
+wrapRec xs type' = foldr wrapByTypeWrapper type' xs
+
+wrapByTypeWrapper :: DataTypeWrapper -> Type -> Type
+wrapByTypeWrapper ListType = wrapAs LIST
+wrapByTypeWrapper NonNullType = wrapAs NON_NULL
+
+fieldFromObjectField :: (Text, DataOutputField) -> Field
+fieldFromObjectField (key', field'@DataField {fieldType = type', fieldKind = kind', fieldArgs = args'}) =
+ F.createFieldWith
+ key'
+ (wrap field' $ createType (renderTypeKind kind') type' "" $ Just [])
+ (map inputValueFromArg args')
+
+typeFromLeaf :: (Text, DataLeaf) -> Type
+typeFromLeaf (key', LeafScalar DataType {typeDescription = desc'}) = createLeafType SCALAR key' desc' Nothing
+typeFromLeaf (key', LeafEnum DataType {typeDescription = desc', typeData = tags'}) =
+ createLeafType ENUM key' desc' (Just $ map createEnumValue tags')
+
+createLeafType :: TypeKind -> Text -> Text -> Maybe [EnumValue] -> Type
+createLeafType kind' name' desc' enums' =
+ Type
+ { kind = kind'
+ , name = Just name'
+ , description = Just desc'
+ , fields = const $ return Nothing
+ , ofType = Nothing
+ , interfaces = Nothing
+ , possibleTypes = Nothing
+ , enumValues = const $ return enums'
+ , inputFields = Nothing
+ }
+
+typeFromUnion :: (Text, DataUnion) -> Type
+typeFromUnion (name', DataType {typeData = fields', typeDescription = description'}) =
+ Type
+ { kind = UNION
+ , name = Just name'
+ , description = Just description'
+ , fields = const $ return Nothing
+ , ofType = Nothing
+ , interfaces = Nothing
+ , possibleTypes = Just (map (\x -> createObjectType (fieldType x) "" $ Just []) fields')
+ , enumValues = const $ return Nothing
+ , inputFields = Nothing
+ }
+
+typeFromObject :: (Text, DataOutputObject) -> Type
+typeFromObject (key', DataType {typeData = fields', typeDescription = description'}) =
+ createObjectType key' description' (Just $ map fieldFromObjectField $ filter (not . fieldHidden . snd) fields')
+
+typeFromInputObject :: (Text, DataInputObject) -> Type
+typeFromInputObject (key', DataType {typeData = fields', typeDescription = description'}) =
+ createInputObject key' description' (map inputValueFromArg fields')
+
+createObjectType :: Text -> Text -> Maybe [Field] -> Type
+createObjectType name' desc' fields' =
+ Type
+ { kind = OBJECT
+ , name = Just name'
+ , description = Just desc'
+ , fields = const $ return fields'
+ , ofType = Nothing
+ , interfaces = Just []
+ , possibleTypes = Nothing
+ , enumValues = const $ return Nothing
+ , inputFields = Nothing
+ }
+
+createInputObject :: Text -> Text -> [InputValue] -> Type
+createInputObject name' desc' fields' =
+ Type
+ { kind = INPUT_OBJECT
+ , name = Just name'
+ , description = Just desc'
+ , fields = const $ return Nothing
+ , ofType = Nothing
+ , interfaces = Nothing
+ , possibleTypes = Nothing
+ , enumValues = const $ return Nothing
+ , inputFields = Just fields'
+ }
+
+createType :: TypeKind -> Text -> Text -> Maybe [Field] -> Type
+createType kind' name' desc' fields' =
+ Type
+ { kind = kind'
+ , name = Just name'
+ , description = Just desc'
+ , fields = const $ return fields'
+ , ofType = Nothing
+ , interfaces = Nothing
+ , possibleTypes = Nothing
+ , enumValues = const $ return $ Just []
+ , inputFields = Nothing
+ }
+
+wrapAs :: TypeKind -> Type -> Type
+wrapAs kind' contentType =
+ Type
+ { kind = kind'
+ , name = Nothing
+ , description = Nothing
+ , fields = const $ return Nothing
+ , ofType = Just contentType
+ , interfaces = Nothing
+ , possibleTypes = Nothing
+ , enumValues = const $ return Nothing
+ , inputFields = Nothing
+ }
diff --git a/src/Data/Morpheus/Schema/Internal/Types.hs b/src/Data/Morpheus/Schema/Internal/Types.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Schema/Internal/Types.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-module Data.Morpheus.Schema.Internal.Types
- ( OutputType
- , InternalType(..)
- , Core(..)
- , Field(..)
- , ObjectField(..)
- , InputType
- , InputField(..)
- , TypeLib(..)
- , GObject(..)
- , Leaf(..)
- , InputObject
- , OutputObject
- , isTypeDefined
- , initTypeLib
- , defineType
- , LibType(..)
- ) where
-
-import Data.Morpheus.Schema.TypeKind (TypeKind)
-import Data.Text (Text)
-
-type EnumValue = Text
-
-newtype InputField = InputField
- { unpackInputField :: Field
- }
-
-data Core = Core
- { name :: Text
- , typeDescription :: Text
- }
-
-data Field = Field
- { fieldName :: Text
- , notNull :: Bool
- , kind :: TypeKind
- , fieldType :: Text
- , asList :: Bool
- }
-
-data ObjectField = ObjectField
- { args :: [(Text, InputField)]
- , fieldContent :: Field
- }
-
-data GObject a =
- GObject [(Text, a)]
- Core
-
-data InternalType a
- = Scalar Core
- | Enum [EnumValue]
- Core
- | Object (GObject a)
-
-type OutputType = InternalType ObjectField
-
-type InputType = InternalType InputField
-
-type InputObject = GObject InputField
-
-type OutputObject = GObject ObjectField
-
-data Leaf
- = LScalar Core
- | LEnum [EnumValue]
- Core
-
-data TypeLib = TypeLib
- { leaf :: [(Text, Leaf)]
- , inputObject :: [(Text, InputObject)]
- , object :: [(Text, OutputObject)]
- , query :: (Text, OutputObject)
- , mutation :: Maybe (Text, OutputObject)
- }
-
-initTypeLib :: (Text, OutputObject) -> TypeLib
-initTypeLib query' = TypeLib {leaf = [], inputObject = [], query = query', object = [], mutation = Nothing}
-
-data LibType
- = Leaf Leaf
- | InputObject InputObject
- | OutputObject OutputObject
-
-mutationName :: Maybe (Text, OutputObject) -> [Text]
-mutationName (Just (key', _)) = [key']
-mutationName Nothing = []
-
-getAllTypeKeys :: TypeLib -> [Text]
-getAllTypeKeys (TypeLib leaf' inputObject' object' (queryName, _) mutation') =
- [queryName] ++ map fst leaf' ++ map fst inputObject' ++ map fst object' ++ mutationName mutation'
-
-isTypeDefined :: Text -> TypeLib -> Bool
-isTypeDefined name' lib' = name' `elem` getAllTypeKeys lib'
-
-defineType :: (Text, LibType) -> TypeLib -> TypeLib
-defineType (key', Leaf type') lib = lib {leaf = (key', type') : leaf lib}
-defineType (key', InputObject type') lib = lib {inputObject = (key', type') : inputObject lib}
-defineType (key', OutputObject type') lib = lib {object = (key', type') : object lib}
diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs
--- a/src/Data/Morpheus/Schema/Schema.hs
+++ b/src/Data/Morpheus/Schema/Schema.hs
@@ -1,44 +1,52 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
-module Data.Morpheus.Schema.Schema where
+module Data.Morpheus.Schema.Schema
+ ( initSchema
+ , findType
+ , Schema
+ , Type
+ ) where
-import Data.Data (Data)
-import Data.Morpheus.Schema.Directive (Directive)
-import Data.Morpheus.Schema.Internal.Types (OutputObject, TypeLib (..))
-import Data.Morpheus.Schema.Utils.Utils (Type, createObjectType, typeFromInputObject, typeFromLeaf,
- typeFromObject)
-import Data.Text (Text)
-import GHC.Generics (Generic)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Schema.Directive (Directive)
+import Data.Morpheus.Schema.Internal.RenderIntrospection (Type, createObjectType, renderType)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
+import Data.Morpheus.Types.Internal.Data (DataOutputObject, DataTypeLib (..), allDataTypes)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+type instance KIND Schema = OBJECT
+
+instance GQLType Schema where
+ __typeName = const "__Schema"
+
data Schema = Schema
{ types :: [Type]
, queryType :: Type
, mutationType :: Maybe Type
, subscriptionType :: Maybe Type
, directives :: [Directive]
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
-convertTypes :: TypeLib -> [Type]
-convertTypes lib' =
- [typeFromObject $ query lib'] ++
- typeFromMutation (mutation lib') ++
- map typeFromObject (object lib') ++ map typeFromInputObject (inputObject lib') ++ map typeFromLeaf (leaf lib')
+convertTypes :: DataTypeLib -> [Type]
+convertTypes lib' = map renderType (allDataTypes lib')
-typeFromMutation :: Maybe (Text, OutputObject) -> [Type]
-typeFromMutation (Just x) = [typeFromObject x]
-typeFromMutation Nothing = []
+buildSchemaLinkType :: (Text, DataOutputObject) -> Type
+buildSchemaLinkType (key', _) = createObjectType key' "" $ Just []
-buildSchemaLinkType :: (Text, OutputObject) -> Type
-buildSchemaLinkType (key', _) = createObjectType key' "Query Description" []
+findType :: Text -> DataTypeLib -> Maybe Type
+findType name lib = renderType . (name, ) <$> lookup name (allDataTypes lib)
-initSchema :: TypeLib -> Schema
+initSchema :: DataTypeLib -> Schema
initSchema types' =
Schema
{ types = convertTypes types'
, queryType = buildSchemaLinkType $ query types'
, mutationType = buildSchemaLinkType <$> mutation types'
- , subscriptionType = Nothing
+ , subscriptionType = buildSchemaLinkType <$> subscription types'
, directives = []
}
diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Schema/SchemaAPI.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Schema.SchemaAPI
+ ( hiddenRootFields
+ , schemaTypes
+ , schemaAPI
+ ) where
+
+import Data.Proxy
+import Data.Text (Text)
+import GHC.Generics
+
+-- MORPHEUS
+import Data.Morpheus.Resolve.Generics.TypeRep (ObjectRep (..), TypeUpdater)
+import Data.Morpheus.Resolve.Introspect (introspectOutputType)
+import Data.Morpheus.Schema.Schema (Schema, Type, findType, initSchema)
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataOutputField, DataTypeLib (..))
+
+newtype TypeArgs = TypeArgs
+ { name :: Text
+ } deriving (Generic)
+
+data SchemaAPI = SchemaAPI
+ { __type :: TypeArgs -> Either String (Maybe Type)
+ , __schema :: Schema
+ } deriving (Generic)
+
+hideFields :: (Text, DataField a) -> (Text, DataField a)
+hideFields (key', field) = (key', field {fieldHidden = True})
+
+hiddenRootFields :: [(Text, DataOutputField)]
+hiddenRootFields = map (hideFields . fst) $ objectFieldTypes $ Proxy @(Rep SchemaAPI)
+
+schemaTypes :: TypeUpdater
+schemaTypes = introspectOutputType (Proxy @Schema)
+
+schemaAPI :: DataTypeLib -> SchemaAPI
+schemaAPI lib = SchemaAPI {__type = \TypeArgs {name} -> return $ findType name lib, __schema = initSchema lib}
diff --git a/src/Data/Morpheus/Schema/Type.hs b/src/Data/Morpheus/Schema/Type.hs
--- a/src/Data/Morpheus/Schema/Type.hs
+++ b/src/Data/Morpheus/Schema/Type.hs
@@ -1,33 +1,39 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Schema.Type
( Type(..)
, DeprecationArgs(..)
) where
-import Data.Data (Data)
+import Data.Morpheus.Kind (KIND, OBJECT)
import Data.Morpheus.Schema.EnumValue (EnumValue)
import qualified Data.Morpheus.Schema.Field as F (Field (..))
import qualified Data.Morpheus.Schema.InputValue as I (InputValue (..))
import Data.Morpheus.Schema.TypeKind (TypeKind)
-import Data.Morpheus.Types.Describer (EnumOf, WithDeprecationArgs (..))
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
import Data.Text (Text)
import GHC.Generics (Generic)
+type instance KIND Type = OBJECT
+
+instance GQLType Type where
+ __typeName = const "__Type"
+
data Type = Type
- { kind :: EnumOf TypeKind
+ { kind :: TypeKind
, name :: Maybe Text
, description :: Maybe Text
- , fields :: Maybe (WithDeprecationArgs [F.Field Type])
- , ofType :: Maybe Type
+ , fields :: DeprecationArgs -> Either String (Maybe [F.Field Type])
, interfaces :: Maybe [Type]
, possibleTypes :: Maybe [Type]
- , enumValues :: Maybe (WithDeprecationArgs [EnumValue])
+ , enumValues :: DeprecationArgs -> Either String (Maybe [EnumValue])
, inputFields :: Maybe [I.InputValue Type]
- } deriving (Show, Data, Generic)
+ , ofType :: Maybe Type
+ } deriving (Generic)
newtype DeprecationArgs = DeprecationArgs
{ includeDeprecated :: Maybe Bool
- } deriving (Show, Data, Generic)
+ } deriving (Generic)
diff --git a/src/Data/Morpheus/Schema/TypeKind.hs b/src/Data/Morpheus/Schema/TypeKind.hs
--- a/src/Data/Morpheus/Schema/TypeKind.hs
+++ b/src/Data/Morpheus/Schema/TypeKind.hs
@@ -1,13 +1,20 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Schema.TypeKind
( TypeKind(..)
) where
-import Data.Data (Data)
+import Data.Morpheus.Kind (ENUM, KIND)
+import Data.Morpheus.Types.GQLType (GQLType (__typeName))
import GHC.Generics
+type instance KIND TypeKind = ENUM
+
+instance GQLType TypeKind where
+ __typeName = const "__TypeKind"
+
data TypeKind
= SCALAR
| OBJECT
@@ -17,4 +24,4 @@
| INPUT_OBJECT
| LIST
| NON_NULL
- deriving (Show, Eq, Data, Generic)
+ deriving (Eq, Generic, Show)
diff --git a/src/Data/Morpheus/Schema/Utils/Utils.hs b/src/Data/Morpheus/Schema/Utils/Utils.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Schema/Utils/Utils.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Schema.Utils.Utils
- ( Type
- , Field
- , InputValue
- , createObjectType
- , typeFromObject
- , typeFromInputObject
- , typeFromLeaf
- ) where
-
-import Data.Morpheus.Schema.EnumValue (EnumValue, createEnumValue)
-import qualified Data.Morpheus.Schema.Field as F (Field (..), createFieldWith)
-import qualified Data.Morpheus.Schema.InputValue as IN (InputValue (..), createInputValueWith)
-import qualified Data.Morpheus.Schema.Internal.Types as I (Core (..), Field (..), GObject (..), InputField (..),
- InputObject, Leaf (..), ObjectField (..), OutputObject)
-import Data.Morpheus.Schema.Type (Type (..))
-import Data.Morpheus.Schema.TypeKind (TypeKind (..))
-import Data.Morpheus.Types.Describer (EnumOf (..), WithDeprecationArgs (..))
-import Data.Text (Text)
-
-type InputValue = IN.InputValue Type
-
-type Field = F.Field Type
-
-inputValueFromArg :: (Text, I.InputField) -> InputValue
-inputValueFromArg (key', input') = IN.createInputValueWith key' (createInputObjectType input')
-
-createInputObjectType :: I.InputField -> Type
-createInputObjectType (I.InputField field') = createType (I.kind field') (I.fieldType field') "" []
-
-wrapNotNull :: I.ObjectField -> Type -> Type
-wrapNotNull field' type' =
- if I.notNull $ I.fieldContent field'
- then wrapAs NON_NULL type'
- else type'
-
-wrapList :: I.ObjectField -> Type -> Type
-wrapList field' type' =
- if I.asList $ I.fieldContent field'
- then wrapAs LIST type'
- else type'
-
-fieldFromObjectField :: (Text, I.ObjectField) -> Field
-fieldFromObjectField (key', field') =
- F.createFieldWith key' (wrapNotNull field' $ wrapList field' $ createObjectType getType "" []) args'
- where
- getType = I.fieldType $ I.fieldContent field'
- args' = map inputValueFromArg $ I.args field'
-
-typeFromLeaf :: (Text, I.Leaf) -> Type
-typeFromLeaf (key', I.LScalar (I.Core _ desc')) = createLeafType SCALAR key' desc' []
-typeFromLeaf (key', I.LEnum tags' (I.Core _ desc')) = createLeafType ENUM key' desc' (map createEnumValue tags')
-
-createLeafType :: TypeKind -> Text -> Text -> [EnumValue] -> Type
-createLeafType kind' name' desc' enums' =
- Type
- { kind = EnumOf kind'
- , name = Just name'
- , description = Just desc'
- , fields = Nothing
- , ofType = Nothing
- , interfaces = Nothing
- , possibleTypes = Nothing
- , enumValues = Just $ WithDeprecationArgs enums'
- , inputFields = Nothing
- }
-
-typeFromObject :: (Text, I.OutputObject) -> Type
-typeFromObject (key', I.GObject fields' (I.Core _ description')) =
- createObjectType key' description' (map fieldFromObjectField fields')
-
-typeFromInputObject :: (Text, I.InputObject) -> Type
-typeFromInputObject (key', I.GObject fields' (I.Core _ description')) =
- createInputObject key' description' (map inputValueFromArg fields')
-
-createObjectType :: Text -> Text -> [Field] -> Type
-createObjectType = createType OBJECT
-
-createInputObject :: Text -> Text -> [InputValue] -> Type
-createInputObject name' desc' fields' =
- Type
- { kind = EnumOf INPUT_OBJECT
- , name = Just name'
- , description = Just desc'
- , fields = Just $ WithDeprecationArgs []
- , ofType = Nothing
- , interfaces = Nothing
- , possibleTypes = Nothing
- , enumValues = Nothing
- , inputFields = Just fields'
- }
-
-createType :: TypeKind -> Text -> Text -> [Field] -> Type
-createType kind' name' desc' fields' =
- Type
- { kind = EnumOf kind'
- , name = Just name'
- , description = Just desc'
- , fields = Just $ WithDeprecationArgs fields'
- , ofType = Nothing
- , interfaces = Just []
- , possibleTypes = Just []
- , enumValues = Just $ WithDeprecationArgs []
- , inputFields = Just []
- }
-
-wrapAs :: TypeKind -> Type -> Type
-wrapAs kind' contentType =
- Type
- { kind = EnumOf kind'
- , name = Nothing
- , description = Nothing
- , fields = Nothing
- , ofType = Just contentType
- , interfaces = Nothing
- , possibleTypes = Nothing
- , enumValues = Nothing
- , inputFields = Nothing
- }
diff --git a/src/Data/Morpheus/Server.hs b/src/Data/Morpheus/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Server.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | GraphQL Wai Server Applications
+module Data.Morpheus.Server
+ ( gqlSocketApp
+ , initGQLState
+ , GQLState
+ , GQLAPI
+ ) where
+
+import Control.Exception (finally)
+import Control.Monad (forever)
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus.Server.Apollo (ApolloSubscription (..), apolloProtocol, parseApolloRequest)
+import Data.Morpheus.Server.ClientRegister (GQLState, addClientSubscription, connectClient,
+ disconnectClient, initGQLState, publishUpdates,
+ removeClientSubscription)
+import Data.Morpheus.Types (GQLRequest (..))
+import Data.Morpheus.Types.Internal.WebSocket (GQLClient (..), OutputAction (..))
+import Network.WebSockets (ServerApp, acceptRequestWith, forkPingThread, receiveData,
+ sendTextData)
+
+-- | statefull GraphQL interpreter
+type GQLAPI = GQLRequest -> IO (OutputAction IO ByteString)
+
+handleGQLResponse :: GQLClient -> GQLState -> Int -> OutputAction IO ByteString -> IO ()
+handleGQLResponse GQLClient {clientConnection = connection', clientID = clientId'} state sessionId' msg =
+ case msg of
+ PublishMutation { mutationChannels = channels'
+ , currentSubscriptionStateResolver = resolver'
+ , mutationResponse = response'
+ } -> sendTextData connection' response' >> publishUpdates channels' resolver' state
+ InitSubscription {subscriptionQuery = selection', subscriptionChannels = channels'} ->
+ addClientSubscription clientId' selection' channels' sessionId' state
+ NoEffect response' -> sendTextData connection' response'
+
+queryHandler :: GQLAPI -> GQLClient -> GQLState -> IO ()
+queryHandler interpreter' client'@GQLClient {clientConnection = connection', clientID = id'} state =
+ forever handleRequest
+ where
+ handleRequest = do
+ msg <- receiveData connection'
+ case parseApolloRequest msg of
+ Left x -> print x
+ Right ApolloSubscription {apolloType = "subscription_end", apolloId = Just sid'} ->
+ removeClientSubscription id' sid' state
+ Right ApolloSubscription { apolloType = "subscription_start"
+ , apolloId = Just sid'
+ , apolloQuery = Just query'
+ , apolloOperationName = name'
+ , apolloVariables = variables'
+ } -> interpreter' request >>= handleGQLResponse client' state sid'
+ where request = GQLRequest {query = query', operationName = name', variables = variables'}
+ Right _ -> return ()
+
+-- | Wai Websocket Server App for GraphQL subscriptions
+gqlSocketApp :: GQLAPI -> GQLState -> ServerApp
+gqlSocketApp interpreter' state pending = do
+ connection' <- acceptRequestWith pending apolloProtocol
+ forkPingThread connection' 30
+ client' <- connectClient connection' state
+ finally (queryHandler interpreter' client' state) (disconnectClient client' state)
diff --git a/src/Data/Morpheus/Server/Apollo.hs b/src/Data/Morpheus/Server/Apollo.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Server/Apollo.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Server.Apollo
+ ( ApolloSubscription(..)
+ , apolloProtocol
+ , toApolloResponse
+ , parseApolloRequest
+ ) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode,
+ pairs, withObject, (.:), (.:?), (.=))
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Map (Map)
+import qualified Data.Morpheus.Types.Internal.Value as V (Value)
+import Data.Morpheus.Types.IO (GQLResponse)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Network.WebSockets (AcceptRequest (..))
+
+data ApolloSubscription a = ApolloSubscription
+ { apolloId :: Maybe Int
+ , apolloType :: Text
+ , apolloPayload :: Maybe a
+ , apolloQuery :: Maybe Text
+ , apolloOperationName :: Maybe Text
+ , apolloVariables :: Maybe (Map Text V.Value)
+ } deriving (Generic)
+
+instance FromJSON (ApolloSubscription Value) where
+ parseJSON = withObject "ApolloSubscription" objectParser
+ where
+ objectParser o =
+ ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" <*> o .:? "query" <*>
+ o .:? "operationName" <*>
+ o .:? "variables"
+
+instance ToJSON (ApolloSubscription GQLResponse) where
+ toEncoding (ApolloSubscription id' type' payload' query' operationName' variables') =
+ pairs $
+ "id" .= id' <> "type" .= type' <> "payload" .= payload' <> "query" .= query' <> "operationName" .= operationName' <>
+ "variables" .=
+ variables'
+
+apolloProtocol :: AcceptRequest
+apolloProtocol = AcceptRequest (Just "graphql-subscriptions") []
+
+toApolloResponse :: Int -> GQLResponse -> ByteString
+toApolloResponse sid' val' =
+ encode $ ApolloSubscription (Just sid') "subscription_data" (Just val') Nothing Nothing Nothing
+
+parseApolloRequest :: ByteString -> Either String (ApolloSubscription Value)
+parseApolloRequest = eitherDecode
diff --git a/src/Data/Morpheus/Server/ClientRegister.hs b/src/Data/Morpheus/Server/ClientRegister.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Server/ClientRegister.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Data.Morpheus.Server.ClientRegister
+ ( ClientRegister
+ , GQLState
+ , initGQLState
+ , connectClient
+ , disconnectClient
+ , updateClientByID
+ , publishUpdates
+ , addClientSubscription
+ , removeClientSubscription
+ ) where
+
+import Control.Concurrent (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)
+import Control.Monad (forM_)
+import Data.List (intersect)
+import Data.Morpheus.Server.Apollo (toApolloResponse)
+import Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)
+import Data.Morpheus.Types.Internal.WebSocket (Channel, ClientID, ClientSession (..), GQLClient (..))
+import Data.Morpheus.Types.IO (GQLResponse (..))
+import Data.Text (Text)
+import Data.UUID.V4 (nextRandom)
+import Network.WebSockets (Connection, sendTextData)
+
+type ClientRegister = [(ClientID, GQLClient)]
+
+-- | shared GraphQL state between __websocket__ and __http__ server,
+-- stores information about subscriptions
+type GQLState = MVar ClientRegister -- SharedState
+
+-- | initializes empty GraphQL state
+initGQLState :: IO GQLState
+initGQLState = newMVar []
+
+connectClient :: Connection -> GQLState -> IO GQLClient
+connectClient clientConnection varState' = do
+ client' <- newClient
+ modifyMVar_ varState' (addClient client')
+ return (snd client')
+ where
+ newClient = do
+ clientID <- nextRandom
+ return (clientID, GQLClient {clientID, clientConnection, clientSessions = []})
+ addClient client' state' = return (client' : state')
+
+disconnectClient :: GQLClient -> GQLState -> IO ClientRegister
+disconnectClient client state = modifyMVar state removeUser
+ where
+ removeUser state' =
+ let s' = removeClient state'
+ in return (s', s')
+ removeClient :: ClientRegister -> ClientRegister
+ removeClient = filter ((/= clientID client) . fst)
+
+updateClientByID :: ClientID -> (GQLClient -> GQLClient) -> MVar ClientRegister -> IO ()
+updateClientByID id' updateFunc state = modifyMVar_ state (return . map updateClient)
+ where
+ updateClient (key', client')
+ | key' == id' = (key', updateFunc client')
+ updateClient state' = state'
+
+publishUpdates :: [Channel] -> (SelectionSet -> IO GQLResponse) -> GQLState -> IO ()
+publishUpdates channels resolver' state = do
+ state' <- readMVar state
+ forM_ state' sendMessage
+ where
+ sendMessage (_, GQLClient {clientSessions = []}) = return ()
+ sendMessage (_, GQLClient {clientSessions, clientConnection}) = mapM_ __send (filterByChannels clientSessions)
+ where
+ __send ClientSession {sessionQuerySelection, sessionId} =
+ resolver' sessionQuerySelection >>= sendTextData clientConnection . toApolloResponse sessionId
+ filterByChannels :: [ClientSession] -> [ClientSession]
+ filterByChannels = filter (([] /=) . intersect channels . sessionChannels)
+
+removeClientSubscription :: ClientID -> Int -> GQLState -> IO ()
+removeClientSubscription id' sid' = updateClientByID id' stopSubscription
+ where
+ stopSubscription client' = client' {clientSessions = filter ((sid' /=) . sessionId) (clientSessions client')}
+
+addClientSubscription :: ClientID -> SelectionSet -> [Text] -> Int -> GQLState -> IO ()
+addClientSubscription id' sessionQuerySelection sessionChannels sessionId = updateClientByID id' startSubscription
+ where
+ startSubscription client' =
+ client'
+ {clientSessions = ClientSession {sessionId, sessionChannels, sessionQuerySelection} : clientSessions client'}
diff --git a/src/Data/Morpheus/Types.hs b/src/Data/Morpheus/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types.hs
@@ -0,0 +1,27 @@
+-- | GQL Types
+module Data.Morpheus.Types
+ ( gqlResolver
+ , gqlEffectResolver
+ , liftEffectResolver
+ -- Resolver Monad
+ , Resolver
+ , ResM
+ , EffectM
+ -- Type Classes
+ , GQLType(description)
+ , GQLScalar(parseValue, serialize)
+ -- Values
+ , GQLRequest(..)
+ , GQLResponse(..)
+ , ID(..)
+ , ScalarValue(..)
+ , GQLRootResolver(..)
+ ) where
+
+import Data.Morpheus.Types.GQLScalar (GQLScalar (parseValue, serialize))
+import Data.Morpheus.Types.GQLType (GQLType (description))
+import Data.Morpheus.Types.ID (ID (..))
+import Data.Morpheus.Types.Internal.Value (ScalarValue (..))
+import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..))
+import Data.Morpheus.Types.Resolver (EffectM, GQLRootResolver (..), ResM, Resolver, gqlEffectResolver,
+ gqlResolver, liftEffectResolver)
diff --git a/src/Data/Morpheus/Types/Core.hs b/src/Data/Morpheus/Types/Core.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Core.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Data.Morpheus.Types.Core
- ( Key
- , Collection
- , EnhancedKey(..)
- , enhanceKeyWithNull
- ) where
-
-import Data.Text (Text)
-
-type Key = Text
-
-type Collection a = [(Key, a)]
-
--- Text value that includes position for debugging, where EnhancedKey "a" 1 === EnhancedKey "a" 3
-data EnhancedKey = EnhancedKey
- { uid :: Text
- , location :: Int
- }
-
-instance Eq EnhancedKey where
- (EnhancedKey id1 _) == (EnhancedKey id2 _) = id1 == id2
-
-enhanceKeyWithNull :: Key -> EnhancedKey
-enhanceKeyWithNull text = EnhancedKey {uid = text, location = 0}
diff --git a/src/Data/Morpheus/Types/Custom.hs b/src/Data/Morpheus/Types/Custom.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Custom.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Types.Custom
+ ( Pair(..)
+ , MapKind(..)
+ , MapArgs(..)
+ , mapKindFromList
+ ) where
+
+import GHC.Generics (Generic)
+
+-- MORPHEUS
+import Data.Morpheus.Kind (KIND, OBJECT)
+
+type instance KIND (Pair k v) = OBJECT
+
+data Pair k v = Pair
+ { key :: k
+ , value :: v
+ } deriving (Generic)
+
+newtype MapArgs k = MapArgs
+ { oneOf :: Maybe [k]
+ } deriving (Generic)
+
+type instance KIND (MapKind k v m) = OBJECT
+
+data MapKind k v m = MapKind
+ { size :: Int
+ , keys :: () -> m [k]
+ , values :: MapArgs k -> m [v]
+ , pairs :: MapArgs k -> m [Pair k v]
+ } deriving (Generic)
+
+mapKindFromList :: (Eq k, Monad m) => [(k, v)] -> MapKind k v m
+mapKindFromList inputPairs =
+ MapKind {size = length inputPairs, keys = resolveKeys, values = resolveValues, pairs = resolvePairs}
+ where
+ filterBy MapArgs {oneOf = Just list} = filter ((`elem` list) . fst) inputPairs
+ filterBy _ = inputPairs
+ resolveKeys _ = return $ map fst inputPairs
+ resolveValues = return . map snd . filterBy
+ resolvePairs = return . (map toGQLTuple . filterBy)
+ toGQLTuple (x, y) = Pair x y
diff --git a/src/Data/Morpheus/Types/Describer.hs b/src/Data/Morpheus/Types/Describer.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Describer.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Data.Morpheus.Types.Describer
- ( (::->)(..)
- , WithDeprecationArgs(..)
- , EnumOf(..)
- , ScalarOf(..)
- ) where
-
-import Data.Data (Constr, Data, DataType, Fixity (Prefix), dataTypeOf, gfoldl, gunfold, mkConstr,
- mkDataType, toConstr)
-import GHC.Generics (Generic)
-
-newtype EnumOf a = EnumOf
- { unpackEnum :: a
- } deriving (Show, Generic, Data)
-
-instance Functor EnumOf where
- fmap f (EnumOf x) = EnumOf (f x)
-
-instance Applicative EnumOf where
- pure = EnumOf
- (<*>) (EnumOf x) y = x <$> y
-
-newtype ScalarOf a = ScalarOf
- { unpackScalar :: a
- } deriving (Show, Generic, Data)
-
-newtype WithDeprecationArgs a = WithDeprecationArgs
- { unpackDeprecationArgs :: a
- } deriving (Show, Generic, Data)
-
-newtype a ::-> b =
- Resolver (a -> IO (Either String b))
- deriving (Generic)
-
-instance Show (a ::-> b) where
- show _ = "Resolver"
-
-instance (Data a, Data b) => Data (a ::-> b) where
- gfoldl _ z (Resolver _) = z (Resolver $ const undefined)
- gunfold _ z _ = z (Resolver $ const undefined)
- toConstr _ = conResolved
- dataTypeOf _ = tyResolver
-
-conResolved :: Constr
-conResolved = mkConstr tyResolver "Resolved" [] Prefix
-
-tyResolver :: DataType
-tyResolver = mkDataType "Module.Resolver" [conResolved]
diff --git a/src/Data/Morpheus/Types/Error.hs b/src/Data/Morpheus/Types/Error.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Error.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-
-module Data.Morpheus.Types.Error
- ( GQLError(..)
- , ErrorLocation(..)
- , GQLErrors
- , JSONError(..)
- , Validation
- , ResolveIO
- , failResolveIO
- ) where
-
-import Control.Monad.Trans.Except (ExceptT (..))
-import Data.Aeson (ToJSON)
-import Data.Text (Text)
-import GHC.Generics (Generic)
-
-data GQLError = GQLError
- { desc :: Text
- , posIndex :: [Int]
- } deriving (Show)
-
-type GQLErrors = [GQLError]
-
-data ErrorLocation = ErrorLocation
- { line :: Int
- , column :: Int
- } deriving (Show, Generic, ToJSON)
-
-data JSONError = JSONError
- { message :: Text
- , locations :: [ErrorLocation]
- } deriving (Show, Generic, ToJSON)
-
-type Validation a = Either GQLErrors a
-
-type ResolveIO = ExceptT GQLErrors IO
-
-failResolveIO :: GQLErrors -> ResolveIO a
-failResolveIO = ExceptT . pure . Left
diff --git a/src/Data/Morpheus/Types/GQLScalar.hs b/src/Data/Morpheus/Types/GQLScalar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/GQLScalar.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Morpheus.Types.GQLScalar
+ ( GQLScalar(..)
+ , toScalar
+ ) where
+
+import Data.Morpheus.Types.Internal.Data (DataValidator (..))
+import Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..))
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+
+toScalar :: Value -> Either Text ScalarValue
+toScalar (Scalar x) = pure x
+toScalar _ = Left ""
+
+-- | GraphQL Scalar
+--
+-- 'parseValue' and 'serialize' should be provided for every instances manually
+class GQLScalar a where
+ -- | value parsing and validating
+ --
+ -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'
+ --
+ -- invalid values can be reported with 'Left' constructor :
+ --
+ -- @
+ -- parseValue String _ = Left "" -- without error message
+ -- -- or
+ -- parseValue String _ = Left "Error Message"
+ -- @
+ --
+ parseValue :: ScalarValue -> Either Text a
+ -- | serialization of haskell type into scalar value
+ serialize :: a -> ScalarValue
+
+ scalarValidator :: Proxy a -> DataValidator
+ scalarValidator _ = DataValidator {validateValue = validator}
+ where
+ validator value = do
+ scalarValue' <- toScalar value
+ (_ :: a) <- parseValue scalarValue'
+ return value
+
+instance GQLScalar Text where
+ parseValue (String x) = pure x
+ parseValue _ = Left ""
+ serialize = String
+
+instance GQLScalar Bool where
+ parseValue (Boolean x) = pure x
+ parseValue _ = Left ""
+ serialize = Boolean
+
+instance GQLScalar Int where
+ parseValue (Int x) = pure x
+ parseValue _ = Left ""
+ serialize = Int
+
+instance GQLScalar Float where
+ parseValue (Float x) = pure x
+ parseValue _ = Left ""
+ serialize = Float
diff --git a/src/Data/Morpheus/Types/GQLType.hs b/src/Data/Morpheus/Types/GQLType.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/GQLType.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Data.Morpheus.Types.GQLType
+ ( GQLType(..)
+ ) where
+
+import Data.Proxy (Proxy (..))
+import Data.Set (Set)
+import Data.Text (Text, intercalate, pack)
+import Data.Typeable (TyCon, TypeRep, Typeable, splitTyConApp, tyConFingerprint,
+ tyConName, typeRep)
+
+-- MORPHEUS
+import Data.Morpheus.Types.Custom (MapKind, Pair)
+import Data.Morpheus.Types.Internal.Data (DataFingerprint (..))
+import Data.Morpheus.Types.Resolver (Resolver)
+
+resolverCon :: TyCon
+resolverCon = fst $ splitTyConApp $ typeRep $ Proxy @(Resolver Maybe)
+
+-- | replaces typeName (A,B) with Pair_A_B
+replacePairCon :: TyCon -> TyCon
+replacePairCon x
+ | hsPair == x = gqlPair
+ where
+ hsPair = fst $ splitTyConApp $ typeRep $ Proxy @(Int, Int)
+ gqlPair = fst $ splitTyConApp $ typeRep $ Proxy @(Pair Int Int)
+replacePairCon x = x
+
+-- Ignores Resolver name from typeName
+ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]
+ignoreResolver (con, _)
+ | con == resolverCon = []
+ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args
+
+-- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.
+--
+-- @
+-- ... deriving (Generic, GQLType)
+-- @
+--
+-- if you want to add description
+--
+-- @
+-- ... deriving (Generic)
+--
+-- instance GQLType ... where
+-- description = const "your description ..."
+-- @
+class GQLType a where
+ description :: Proxy a -> Text
+ description _ = ""
+ __typeName :: Proxy a -> Text
+ default __typeName :: (Typeable a) =>
+ Proxy a -> Text
+ __typeName _ = intercalate "_" (getName $ Proxy @a)
+ where
+ getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)
+ __typeFingerprint :: Proxy a -> DataFingerprint
+ default __typeFingerprint :: (Typeable a) =>
+ Proxy a -> DataFingerprint
+ __typeFingerprint _ = TypeableFingerprint $ conFingerprints (Proxy @a)
+ where
+ conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)
+
+instance GQLType Int
+
+instance GQLType Float
+
+instance GQLType Text where
+ __typeName = const "String"
+
+instance GQLType Bool where
+ __typeName = const "Boolean"
+
+instance GQLType a => GQLType (Maybe a) where
+ __typeName _ = __typeName (Proxy @a)
+ __typeFingerprint _ = __typeFingerprint (Proxy @a)
+
+instance GQLType a => GQLType [a] where
+ __typeName _ = __typeName (Proxy @a)
+ __typeFingerprint _ = __typeFingerprint (Proxy @a)
+
+instance GQLType a => GQLType (Set a) where
+ __typeName _ = __typeName (Proxy @a)
+ __typeFingerprint _ = __typeFingerprint (Proxy @a)
+
+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where
+ __typeName _ = __typeName $ Proxy @(Pair a b)
+
+instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b)
+
+instance (Typeable a, Typeable b, Typeable m, GQLType a, GQLType b) => GQLType (MapKind a b m)
diff --git a/src/Data/Morpheus/Types/ID.hs b/src/Data/Morpheus/Types/ID.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/ID.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Morpheus.Types.ID
+ ( ID(..)
+ ) where
+
+import Data.Morpheus.Kind (KIND, SCALAR)
+import Data.Morpheus.Types.GQLScalar (GQLScalar (..))
+import Data.Morpheus.Types.GQLType (GQLType)
+import Data.Morpheus.Types.Internal.Value (ScalarValue (..))
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+
+type instance KIND ID = SCALAR
+
+-- | default GraphQL type,
+-- parses only 'String' and 'Int' values,
+-- serialized always as 'String'
+newtype ID = ID
+ { unpackID :: Text
+ } deriving (Generic, GQLType)
+
+instance GQLScalar ID where
+ parseValue (Int x) = return (ID $ pack $ show x)
+ parseValue (String x) = return (ID x)
+ parseValue _ = Left ""
+ serialize (ID x) = String x
diff --git a/src/Data/Morpheus/Types/IO.hs b/src/Data/Morpheus/Types/IO.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/IO.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Types.IO
+ ( GQLRequest(..)
+ , GQLResponse(..)
+ ) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), pairs, (.=))
+import Data.Map (Map)
+import GHC.Generics (Generic)
+
+-- MORPHEUS
+import Data.Morpheus.Types.Internal.Base (Key)
+import Data.Morpheus.Types.Internal.Validation (JSONError (..))
+import Data.Morpheus.Types.Internal.Value (Value)
+
+-- | GraphQL HTTP Request Body
+data GQLRequest = GQLRequest
+ { query :: Key
+ , operationName :: Maybe Key
+ , variables :: Maybe (Map Key Value)
+ } deriving (Show, Generic, FromJSON)
+
+-- | GraphQL Response
+data GQLResponse
+ = Data Value
+ | Errors [JSONError]
+ deriving (Show, Generic)
+
+instance ToJSON GQLResponse where
+ toEncoding (Data _data) = pairs $ "data" .= _data
+ toEncoding (Errors _errors) = pairs $ "errors" .= _errors
diff --git a/src/Data/Morpheus/Types/Internal/AST/Operator.hs b/src/Data/Morpheus/Types/Internal/AST/Operator.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/AST/Operator.hs
@@ -0,0 +1,50 @@
+module Data.Morpheus.Types.Internal.AST.Operator
+ ( Operator(..)
+ , ValidOperator
+ , RawOperator
+ , Variable(..)
+ , VariableDefinitions
+ , Operator'(..)
+ , ValidOperator'
+ , RawOperator'
+ , ValidVariables
+ ) where
+
+import Data.Morpheus.Types.Internal.AST.RawSelection (RawSelectionSet)
+import Data.Morpheus.Types.Internal.AST.Selection (Arguments, SelectionSet)
+import Data.Morpheus.Types.Internal.Base (Collection, Key, Position)
+import Data.Morpheus.Types.Internal.Data (DataTypeWrapper)
+import Data.Morpheus.Types.Internal.Value (Value)
+
+type ValidOperator = Operator Arguments SelectionSet
+
+type ValidOperator' = Operator' Arguments SelectionSet
+
+data Variable a = Variable
+ { variableType :: Key
+ , isVariableRequired :: Bool
+ , variableTypeWrappers :: [DataTypeWrapper]
+ , variablePosition :: Position
+ , variableValue :: a
+ } deriving (Show)
+
+type VariableDefinitions = Collection (Variable ())
+
+type ValidVariables = Collection (Variable Value)
+
+type RawOperator = Operator VariableDefinitions RawSelectionSet
+
+type RawOperator' = Operator' VariableDefinitions RawSelectionSet
+
+data Operator' args sel = Operator'
+ { operatorName :: Key
+ , operatorArgs :: args
+ , operatorSelection :: sel
+ , operatorPosition :: Position
+ } deriving (Show)
+
+data Operator args sel
+ = Query (Operator' args sel)
+ | Mutation (Operator' args sel)
+ | Subscription (Operator' args sel)
+ deriving (Show)
diff --git a/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs b/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs
@@ -0,0 +1,52 @@
+module Data.Morpheus.Types.Internal.AST.RawSelection
+ ( Reference(..)
+ , Argument(..)
+ , RawArgument(..)
+ , RawSelection(..)
+ , Fragment(..)
+ , RawSelection'(..)
+ , FragmentLib
+ , RawArguments
+ , RawSelectionSet
+ ) where
+
+import Data.Map (Map)
+import Data.Morpheus.Types.Internal.AST.Selection (Argument (..))
+import Data.Morpheus.Types.Internal.Base (Collection, Key, Position)
+
+data Reference = Reference
+ { referenceName :: Key
+ , referencePosition :: Position
+ } deriving (Show)
+
+data Fragment = Fragment
+ { fragmentType :: Key
+ , fragmentPosition :: Position
+ , fragmentSelection :: RawSelectionSet
+ } deriving (Show)
+
+data RawSelection' a = RawSelection'
+ { rawSelectionArguments :: RawArguments
+ , rawSelectionPosition :: Position
+ , rawSelectionRec :: a
+ } deriving (Show)
+
+type FragmentLib = Map Key Fragment
+
+data RawArgument
+ = VariableReference Reference
+ | RawArgument Argument
+ deriving (Show)
+
+type RawArguments = Collection RawArgument
+
+type RawSelectionSet = Collection RawSelection
+
+data RawSelection
+ = RawSelectionSet (RawSelection' RawSelectionSet)
+ | RawSelectionField (RawSelection' ())
+ | InlineFragment Fragment
+ | Spread Reference
+ | RawAlias { rawAliasPosition :: Position
+ , rawAliasSelection :: (Key, RawSelection) }
+ deriving (Show)
diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs
@@ -0,0 +1,35 @@
+module Data.Morpheus.Types.Internal.AST.Selection
+ ( Argument(..)
+ , Arguments
+ , SelectionSet
+ , Selection(..)
+ , SelectionRec(..)
+ ) where
+
+import Data.Morpheus.Types.Internal.Base (Collection, Key, Position)
+import Data.Morpheus.Types.Internal.Value (Value)
+
+data Argument = Argument
+ { argumentValue :: Value
+ , argumentPosition :: Position
+ } deriving (Show)
+
+type Arguments = Collection Argument
+
+type SelectionSet = Collection Selection
+
+type UnionSelection = Collection SelectionSet
+
+data Selection = Selection
+ { selectionArguments :: Arguments
+ , selectionPosition :: Position
+ , selectionRec :: SelectionRec
+ } deriving (Show)
+
+data SelectionRec
+ = SelectionSet SelectionSet
+ | UnionSelection UnionSelection
+ | SelectionAlias { aliasFieldName :: Key
+ , aliasSelection :: SelectionRec }
+ | SelectionField
+ deriving (Show)
diff --git a/src/Data/Morpheus/Types/Internal/Base.hs b/src/Data/Morpheus/Types/Internal/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/Base.hs
@@ -0,0 +1,28 @@
+module Data.Morpheus.Types.Internal.Base
+ ( Key
+ , Collection
+ , Position
+ , EnhancedKey(..)
+ , enhanceKeyWithNull
+ ) where
+
+import Data.Text (Text)
+import Text.Megaparsec (SourcePos, initialPos)
+
+type Position = SourcePos
+
+type Key = Text
+
+type Collection a = [(Key, a)]
+
+-- Text value that includes position for debugging, where EnhancedKey "a" 1 === EnhancedKey "a" 3
+data EnhancedKey = EnhancedKey
+ { uid :: Text
+ , location :: Position
+ } deriving (Show)
+
+instance Eq EnhancedKey where
+ (EnhancedKey id1 _) == (EnhancedKey id2 _) = id1 == id2
+
+enhanceKeyWithNull :: Key -> EnhancedKey
+enhanceKeyWithNull text = EnhancedKey {uid = text, location = initialPos ""}
diff --git a/src/Data/Morpheus/Types/Internal/Data.hs b/src/Data/Morpheus/Types/Internal/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/Data.hs
@@ -0,0 +1,183 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Types.Internal.Data
+ ( Key
+ , DataScalar
+ , DataEnum
+ , DataObject
+ , DataInputField
+ , DataArgument
+ , DataOutputField
+ , DataInputObject
+ , DataOutputObject
+ , DataUnion
+ , DataOutputType
+ , DataInputType
+ , DataArguments
+ , DataField(..)
+ , DataType(..)
+ , DataLeaf(..)
+ , DataKind(..)
+ , DataFullType(..)
+ , DataTypeLib(..)
+ , DataTypeWrapper(..)
+ , DataValidator(..)
+ , DataTypeKind(..)
+ , DataFingerprint(..)
+ , isTypeDefined
+ , initTypeLib
+ , defineType
+ , showWrappedType
+ , showFullAstType
+ , isFieldNullable
+ , allDataTypes
+ ) where
+
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Text (Text)
+import qualified Data.Text as T (concat)
+import GHC.Fingerprint.Type (Fingerprint)
+
+type Key = Text
+
+data DataTypeKind
+ = KindScalar
+ | KindObject
+ | KindUnion
+ | KindEnum
+ | KindInputObject
+ | KindList
+ | KindNonNull
+ deriving (Eq, Show)
+
+data DataFingerprint
+ = SystemFingerprint Text
+ | TypeableFingerprint [Fingerprint]
+ deriving (Show, Eq, Ord)
+
+newtype DataValidator = DataValidator
+ { validateValue :: Value -> Either Text Value
+ }
+
+instance Show DataValidator where
+ show _ = "DataValidator"
+
+type DataScalar = DataType DataValidator
+
+type DataEnum = DataType [Key]
+
+type DataObject a = DataType [(Key, a)]
+
+type DataInputField = DataField ()
+
+type DataArgument = DataInputField
+
+type DataOutputField = DataField [(Key, DataArgument)]
+
+type DataInputObject = DataObject DataInputField
+
+type DataOutputObject = DataObject DataOutputField
+
+type DataUnion = DataType [DataField ()]
+
+type DataOutputType = DataKind DataOutputField
+
+type DataInputType = DataKind DataInputField
+
+type DataArguments = [(Key, DataArgument)]
+
+data DataTypeWrapper
+ = ListType
+ | NonNullType
+ deriving (Show)
+
+data DataField a = DataField
+ { fieldArgs :: a
+ , fieldName :: Text
+ , fieldKind :: DataTypeKind
+ , fieldType :: Text
+ , fieldTypeWrappers :: [DataTypeWrapper]
+ , fieldHidden :: Bool
+ } deriving (Show)
+
+isFieldNullable :: DataField a -> Bool
+isFieldNullable DataField {fieldTypeWrappers = NonNullType:_} = False
+isFieldNullable _ = True
+
+data DataType a = DataType
+ { typeName :: Text
+ , typeFingerprint :: DataFingerprint
+ , typeDescription :: Text
+ , typeData :: a
+ } deriving (Show)
+
+data DataLeaf
+ = LeafScalar DataScalar
+ | LeafEnum DataEnum
+ deriving (Show)
+
+data DataKind a
+ = ScalarKind DataScalar
+ | EnumKind DataEnum
+ | ObjectKind (DataObject a)
+ deriving (Show)
+
+data DataFullType
+ = Leaf DataLeaf
+ | InputObject DataInputObject
+ | OutputObject DataOutputObject
+ | Union DataUnion
+ deriving (Show)
+
+data DataTypeLib = DataTypeLib
+ { leaf :: [(Text, DataLeaf)]
+ , inputObject :: [(Text, DataInputObject)]
+ , object :: [(Text, DataOutputObject)]
+ , union :: [(Text, DataUnion)]
+ , query :: (Text, DataOutputObject)
+ , mutation :: Maybe (Text, DataOutputObject)
+ , subscription :: Maybe (Text, DataOutputObject)
+ }
+
+showWrappedType :: [DataTypeWrapper] -> Text -> Text
+showWrappedType [] type' = type'
+showWrappedType (ListType:xs) type' = T.concat ["[", showWrappedType xs type', "]"]
+showWrappedType (NonNullType:xs) type' = T.concat [showWrappedType xs type', "!"]
+
+showFullAstType :: [DataTypeWrapper] -> DataKind a -> Text
+showFullAstType wrappers' (ScalarKind x) = showWrappedType wrappers' (typeName x)
+showFullAstType wrappers' (EnumKind x) = showWrappedType wrappers' (typeName x)
+showFullAstType wrappers' (ObjectKind x) = showWrappedType wrappers' (typeName x)
+
+initTypeLib :: (Text, DataOutputObject) -> DataTypeLib
+initTypeLib query' =
+ DataTypeLib
+ {leaf = [], inputObject = [], query = query', object = [], union = [], mutation = Nothing, subscription = Nothing}
+
+allDataTypes :: DataTypeLib -> [(Text, DataFullType)]
+allDataTypes (DataTypeLib leaf' inputObject' object' union' query' mutation' subscription') =
+ packType OutputObject query' :
+ map (packType InputObject) inputObject' ++
+ map (packType OutputObject) object' ++
+ map (packType Leaf) leaf' ++ map (packType Union) union' ++ fromMaybeType mutation' ++ fromMaybeType subscription'
+ where
+ packType f (x, y) = (x, f y)
+ fromMaybeType :: Maybe (Text, DataOutputObject) -> [(Text, DataFullType)]
+ fromMaybeType (Just (key', dataType')) = [(key', OutputObject dataType')]
+ fromMaybeType Nothing = []
+
+isTypeDefined :: Text -> DataTypeLib -> Maybe DataFingerprint
+isTypeDefined name_ lib' = getTypeFingerprint <$> name_ `lookup` allDataTypes lib'
+ where
+ getTypeFingerprint :: DataFullType -> DataFingerprint
+ getTypeFingerprint (Leaf (LeafScalar dataType')) = typeFingerprint dataType'
+ getTypeFingerprint (Leaf (LeafEnum dataType')) = typeFingerprint dataType'
+ getTypeFingerprint (InputObject dataType') = typeFingerprint dataType'
+ getTypeFingerprint (OutputObject dataType') = typeFingerprint dataType'
+ getTypeFingerprint (Union dataType') = typeFingerprint dataType'
+
+defineType :: (Text, DataFullType) -> DataTypeLib -> DataTypeLib
+defineType (key', Leaf type') lib = lib {leaf = (key', type') : leaf lib}
+defineType (key', InputObject type') lib = lib {inputObject = (key', type') : inputObject lib}
+defineType (key', OutputObject type') lib = lib {object = (key', type') : object lib}
+defineType (key', Union type') lib = lib {union = (key', type') : union lib}
diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/Validation.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Data.Morpheus.Types.Internal.Validation
+ ( GQLError(..)
+ , ErrorLocation(..)
+ , GQLErrors
+ , JSONError(..)
+ , Validation
+ , ResolveT
+ , failResolveT
+ , SchemaValidation
+ , ResolveValue
+ ) where
+
+import Control.Monad.Trans.Except (ExceptT (..))
+import Data.Aeson (ToJSON)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Value (Value)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data GQLError = GQLError
+ { desc :: Text
+ , positions :: [Position]
+ } deriving (Show)
+
+type GQLErrors = [GQLError]
+
+data ErrorLocation = ErrorLocation
+ { line :: Int
+ , column :: Int
+ } deriving (Show, Generic, ToJSON)
+
+data JSONError = JSONError
+ { message :: Text
+ , locations :: [ErrorLocation]
+ } deriving (Show, Generic, ToJSON)
+
+type Validation a = Either GQLErrors a
+
+type SchemaValidation a = Validation a
+
+type ResolveT = ExceptT GQLErrors
+
+type ResolveValue m = ExceptT GQLErrors m Value
+
+failResolveT :: Monad m => GQLErrors -> ResolveT m a
+failResolveT = ExceptT . pure . Left
diff --git a/src/Data/Morpheus/Types/Internal/Value.hs b/src/Data/Morpheus/Types/Internal/Value.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/Value.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Types.Internal.Value
+ ( Value(..)
+ , ScalarValue(..)
+ , decodeScientific
+ , convertToJSONName
+ , convertToHaskellName
+ ) where
+
+import qualified Data.Aeson as A (FromJSON (..), ToJSON (..), Value (..), object, pairs, (.=))
+import qualified Data.HashMap.Strict as M (toList)
+import Data.Scientific (Scientific, floatingOrInteger)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import qualified Data.Vector as V (toList)
+import GHC.Generics (Generic)
+
+convertToJSONName :: Text -> Text
+convertToJSONName "type'" = "type"
+convertToJSONName x = x
+
+convertToHaskellName :: Text -> Text
+convertToHaskellName "type" = "type'"
+convertToHaskellName x = x
+
+-- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'.
+-- for performance reason type 'Text' represents GraphQl 'String' value
+data ScalarValue
+ = Int Int
+ | Float Float
+ | String Text
+ | Boolean Bool
+ deriving (Show, Generic)
+
+instance A.ToJSON ScalarValue where
+ toEncoding (Float x) = A.toEncoding x
+ toEncoding (Int x) = A.toEncoding x
+ toEncoding (Boolean x) = A.toEncoding x
+ toEncoding (String x) = A.toEncoding x
+
+data Value
+ = Object [(Text, Value)]
+ | List [Value]
+ | Enum Text
+ | Scalar ScalarValue
+ | Null
+ deriving (Show, Generic)
+
+instance A.ToJSON Value where
+ toEncoding Null = A.toEncoding A.Null
+ toEncoding (Enum x) = A.toEncoding x
+ toEncoding (List x) = A.toEncoding x
+ toEncoding (Scalar x) = A.toEncoding x
+ toEncoding (Object []) = A.toEncoding $ A.object []
+ toEncoding (Object x) = A.pairs $ foldl1 (<>) $ map encodeField x
+ where
+ encodeField (key, value) = convertToJSONName key A..= value
+
+replace :: (a, A.Value) -> (a, Value)
+replace (key, val) = (key, replaceValue val)
+
+decodeScientific :: Scientific -> ScalarValue
+decodeScientific v =
+ case floatingOrInteger v of
+ Left float -> Float float
+ Right int -> Int int
+
+replaceValue :: A.Value -> Value
+replaceValue (A.Bool v) = Scalar $ Boolean v
+replaceValue (A.Number v) = Scalar $ decodeScientific v
+replaceValue (A.String v) = Scalar $ String v
+replaceValue (A.Object v) = Object $ map replace (M.toList v)
+replaceValue (A.Array li) = List (map replaceValue (V.toList li))
+replaceValue A.Null = Null
+
+instance A.FromJSON Value where
+ parseJSON = pure . replaceValue
diff --git a/src/Data/Morpheus/Types/Internal/WebSocket.hs b/src/Data/Morpheus/Types/Internal/WebSocket.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Internal/WebSocket.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Data.Morpheus.Types.Internal.WebSocket
+ ( GQLClient(..)
+ , ClientID
+ , Channel
+ , OutputAction(..)
+ , ClientSession(..)
+ ) where
+
+import Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)
+import Data.Morpheus.Types.IO (GQLResponse (..))
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+import Data.UUID (UUID)
+import Network.WebSockets (Connection)
+
+data OutputAction m a
+ = PublishMutation { mutationChannels :: [Text]
+ , mutationResponse :: a
+ , currentSubscriptionStateResolver :: SelectionSet -> m GQLResponse }
+ | InitSubscription { subscriptionChannels :: [Text]
+ , subscriptionQuery :: SelectionSet }
+ | NoEffect a
+ deriving (Functor)
+
+type ClientID = UUID
+
+type Channel = Text
+
+data ClientSession = ClientSession
+ { sessionId :: Int
+ , sessionChannels :: [Channel]
+ , sessionQuerySelection :: SelectionSet
+ } deriving (Show)
+
+data GQLClient = GQLClient
+ { clientID :: ClientID
+ , clientConnection :: Connection
+ , clientSessions :: [ClientSession]
+ }
+
+instance Show GQLClient where
+ show GQLClient {clientID, clientSessions} =
+ "GQLClient {id:" <> show clientID <> ", sessions:" <> show clientSessions <> "}"
diff --git a/src/Data/Morpheus/Types/JSType.hs b/src/Data/Morpheus/Types/JSType.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/JSType.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Types.JSType
- ( JSType(..)
- , ScalarValue(..)
- , decodeScientific
- ) where
-
-import qualified Data.Aeson as A (FromJSON (..), ToJSON (..), Value (..), pairs, (.=))
-import qualified Data.HashMap.Strict as M (toList)
-import Data.Scientific (Scientific, floatingOrInteger)
-import Data.Text (Text)
-import qualified Data.Vector as V (toList)
-import GHC.Generics (Generic)
-
-replaceType :: Text -> Text
-replaceType "_type" = "type"
-replaceType x = x
-
-data ScalarValue
- = Int Int
- | Float Float
- | String Text
- | Boolean Bool
- deriving (Show, Generic)
-
-instance A.ToJSON ScalarValue where
- toEncoding (Float x) = A.toEncoding x
- toEncoding (Int x) = A.toEncoding x
- toEncoding (Boolean x) = A.toEncoding x
- toEncoding (String x) = A.toEncoding x
-
-data JSType
- = JSObject [(Text, JSType)]
- | JSList [JSType]
- | JSEnum Text
- | Scalar ScalarValue
- | JSNull
- deriving (Show, Generic)
-
-instance A.ToJSON JSType where
- toEncoding JSNull = A.toEncoding A.Null
- toEncoding (JSEnum x) = A.toEncoding x
- toEncoding (JSList x) = A.toEncoding x
- toEncoding (Scalar x) = A.toEncoding x
- toEncoding (JSObject x) = A.pairs $ foldl1 (<>) $ map encodeField x
- where
- encodeField (key, value) = replaceType key A..= value
-
-replace :: (a, A.Value) -> (a, JSType)
-replace (key, val) = (key, replaceValue val)
-
-decodeScientific :: Scientific -> ScalarValue
-decodeScientific v =
- case floatingOrInteger v of
- Left float -> Float float
- Right int -> Int int
-
-replaceValue :: A.Value -> JSType
-replaceValue (A.Bool v) = Scalar $ Boolean v
-replaceValue (A.Number v) = Scalar $ decodeScientific v
-replaceValue (A.String v) = Scalar $ String v
-replaceValue (A.Object v) = JSObject $ map replace (M.toList v)
-replaceValue (A.Array li) = JSList (map replaceValue (V.toList li))
-replaceValue A.Null = JSNull
-
-instance A.FromJSON JSType where
- parseJSON = pure . replaceValue
diff --git a/src/Data/Morpheus/Types/MetaInfo.hs b/src/Data/Morpheus/Types/MetaInfo.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/MetaInfo.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Types.MetaInfo
- ( MetaInfo(..)
- , initialMeta
- , Position
- , LineBreaks
- ) where
-
-import Data.Text (Text)
-
-initialMeta :: MetaInfo
-initialMeta = MetaInfo {position = 0, typeName = "", key = ""}
-
-type LineBreaks = [Position]
-
-type Position = Int
-
-data MetaInfo = MetaInfo
- { position :: Position
- , typeName :: Text
- , key :: Text
- }
diff --git a/src/Data/Morpheus/Types/Query/Fragment.hs b/src/Data/Morpheus/Types/Query/Fragment.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Query/Fragment.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Data.Morpheus.Types.Query.Fragment
- ( Fragment(..)
- , FragmentLib
- ) where
-
-import Data.Map (Map)
-import Data.Morpheus.Types.Core (Key)
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet)
-
-data Fragment = Fragment
- { key :: Key
- , target :: Key
- , position :: Position
- , content :: RawSelectionSet
- } deriving (Show)
-
-type FragmentLib = Map Key Fragment
diff --git a/src/Data/Morpheus/Types/Query/Operator.hs b/src/Data/Morpheus/Types/Query/Operator.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Query/Operator.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Data.Morpheus.Types.Query.Operator
- ( Operator(..)
- , ValidOperator
- , RawOperator
- , Variable(..)
- , VariableDefinitions
- ) where
-
-import Data.Morpheus.Types.Core (Collection, Key)
-import Data.Morpheus.Types.MetaInfo (Position)
-import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet)
-import Data.Morpheus.Types.Query.Selection (Arguments, SelectionSet)
-
-type ValidOperator = Operator Arguments SelectionSet
-
-data Variable =
- Variable Key
- Position
-
-type VariableDefinitions = Collection Variable
-
-type RawOperator = Operator VariableDefinitions RawSelectionSet
-
-data Operator args sel
- = Query Key
- args
- sel
- Position
- | Mutation Key
- args
- sel
- Position
diff --git a/src/Data/Morpheus/Types/Query/RawSelection.hs b/src/Data/Morpheus/Types/Query/RawSelection.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Query/RawSelection.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Data.Morpheus.Types.Query.RawSelection
- ( RawArgument(..)
- , RawArguments
- , RawSelectionSet
- , RawSelection(..)
- ) where
-
-import Data.Morpheus.Types.Core (Collection, Key)
-import Data.Morpheus.Types.JSType (JSType)
-import Data.Morpheus.Types.MetaInfo (Position)
-
-data RawArgument
- = VariableReference Key
- Position
- | Argument JSType
- Position
- deriving (Show)
-
-type RawArguments = Collection RawArgument
-
-type RawSelectionSet = Collection RawSelection
-
-data RawSelection
- = RawSelectionSet RawArguments
- RawSelectionSet
- Position
- | RawField RawArguments
- Key
- Position
- | Spread Key
- Position
- deriving (Show)
diff --git a/src/Data/Morpheus/Types/Query/Selection.hs b/src/Data/Morpheus/Types/Query/Selection.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Query/Selection.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module Data.Morpheus.Types.Query.Selection
- ( Argument(..)
- , Arguments
- , SelectionSet
- , Selection(..)
- ) where
-
-import Data.Morpheus.Types.Core (Collection, Key)
-import Data.Morpheus.Types.JSType (JSType)
-import Data.Morpheus.Types.MetaInfo (Position)
-
-data Argument =
- Argument JSType
- Position
- deriving (Show)
-
-type Arguments = Collection Argument
-
-type SelectionSet = Collection Selection
-
-data Selection
- = SelectionSet Arguments
- SelectionSet
- Position
- | Field Arguments
- Key
- Position
- deriving (Show)
diff --git a/src/Data/Morpheus/Types/Request.hs b/src/Data/Morpheus/Types/Request.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Request.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-
-module Data.Morpheus.Types.Request where
-
-import Data.Aeson (FromJSON (..))
-import Data.Map (Map)
-import Data.Morpheus.Types.Core (Key)
-import Data.Morpheus.Types.JSType (JSType)
-import GHC.Generics (Generic)
-
-data GQLRequest = GQLRequest
- { query :: Key
- , operationName :: Maybe Key
- , variables :: Maybe (Map Key JSType)
- } deriving (Show, Generic, FromJSON)
diff --git a/src/Data/Morpheus/Types/Resolver.hs b/src/Data/Morpheus/Types/Resolver.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Types/Resolver.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Types.Resolver
+ ( Pure
+ , ResM
+ , EffectM
+ , EffectT(..)
+ , Effect(..)
+ , Resolver
+ , GQLRootResolver(..)
+ , gqlResolver
+ , gqlEffectResolver
+ , liftEffectResolver
+ , unpackEffect
+ , unpackEffect2
+ ) where
+
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
+import Data.Text (Text)
+
+-- MORPHEUS
+import Data.Morpheus.Types.Internal.Validation (GQLErrors, ResolveT)
+
+-- | Pure Resolver without effect
+type Pure = Either String
+
+-- | Monad IO resolver without GraphQL effect
+type ResM = Resolver IO
+
+-- | Monad Resolver with GraphQL effects, used for communication between mutation and subscription
+type EffectM = Resolver (EffectT IO Text)
+
+-- | Resolver Monad Transformer
+type Resolver = ExceptT String
+
+-- | GraphQL Resolver
+gqlResolver :: m (Either String a) -> Resolver m a
+gqlResolver = ExceptT
+
+-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.
+--
+-- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,
+-- if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it.
+data GQLRootResolver m a b c = GQLRootResolver
+ { queryResolver :: ResolveT m a
+ , mutationResolver :: ResolveT (EffectT m Text) b
+ , subscriptionResolver :: ResolveT (EffectT m Text) c
+ }
+
+-- | GraphQL Resolver for mutation or subscription resolver , adds effect to normal resolver
+gqlEffectResolver :: Monad m => [c] -> (EffectT m c) (Either String a) -> Resolver (EffectT m c) a
+gqlEffectResolver channels = ExceptT . insertEffect channels
+
+insertEffect :: Monad m => [c] -> EffectT m c a -> EffectT m c a
+insertEffect channels EffectT {runEffectT = monadEffect} = EffectT $ effectPlus <$> monadEffect
+ where
+ effectPlus x = x {resultEffects = channels ++ resultEffects x}
+
+-- | lift Normal resolver inside Effect Resolver
+liftEffectResolver :: Monad m => [c] -> m (Either String a) -> Resolver (EffectT m c) a
+liftEffectResolver channels = ExceptT . EffectT . fmap (Effect channels)
+
+unpackEffect2 :: Monad m => ResolveT (EffectT m Text) v -> ResolveT m ([Text], v)
+unpackEffect2 x = ExceptT $ unpackEffect x
+
+unpackEffect :: Monad m => ResolveT (EffectT m Text) v -> m (Either GQLErrors ([Text], v))
+unpackEffect resolver = do
+ (Effect effects eitherValue) <- runEffectT $ runExceptT resolver
+ case eitherValue of
+ Left errors -> return $ Left errors
+ Right value -> return $ Right (effects, value)
+
+data Effect c v = Effect
+ { resultEffects :: [c]
+ , resultValue :: v
+ } deriving (Functor)
+
+-- | Monad Transformer that sums all effect Together
+newtype EffectT m c v = EffectT
+ { runEffectT :: m (Effect c v)
+ } deriving (Functor)
+
+instance Monad m => Applicative (EffectT m c) where
+ pure = EffectT . return . Effect []
+ EffectT app1 <*> EffectT app2 =
+ EffectT $ do
+ (Effect effect1 func) <- app1
+ (Effect effect2 val) <- app2
+ return $ Effect (effect1 ++ effect2) (func val)
+
+instance Monad m => Monad (EffectT m c) where
+ return = pure
+ (EffectT m1) >>= mFunc =
+ EffectT $ do
+ (Effect e1 v1) <- m1
+ (Effect e2 v2) <- runEffectT $ mFunc v1
+ return $ Effect (e1 ++ e2) v2
diff --git a/src/Data/Morpheus/Types/Response.hs b/src/Data/Morpheus/Types/Response.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Types/Response.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Data.Morpheus.Types.Response where
-
-import Data.Aeson (ToJSON (..), pairs, (.=))
-import Data.Morpheus.Types.Error (JSONError (..))
-import Data.Morpheus.Types.JSType (JSType)
-import GHC.Generics (Generic)
-
-data GQLResponse
- = Data JSType
- | Errors [JSONError]
- deriving (Show, Generic)
-
-instance ToJSON GQLResponse where
- toEncoding (Data _data) = pairs $ "data" .= _data
- toEncoding (Errors _errors) = pairs $ "errors" .= _errors
diff --git a/src/Data/Morpheus/Types/Types.hs b/src/Data/Morpheus/Types/Types.hs
--- a/src/Data/Morpheus/Types/Types.hs
+++ b/src/Data/Morpheus/Types/Types.hs
@@ -1,24 +1,18 @@
module Data.Morpheus.Types.Types
( GQLQueryRoot(..)
, Variables
- , GQLRoot(..)
) where
-import Data.Map (Map)
-import Data.Morpheus.Types.Core (Key)
-import Data.Morpheus.Types.JSType (JSType)
-import Data.Morpheus.Types.Query.Fragment (FragmentLib)
-import Data.Morpheus.Types.Query.Operator (RawOperator)
+import Data.Map (Map)
+import Data.Morpheus.Types.Internal.AST.Operator (RawOperator)
+import Data.Morpheus.Types.Internal.AST.RawSelection (FragmentLib)
+import Data.Morpheus.Types.Internal.Base (Key)
+import Data.Morpheus.Types.Internal.Value (Value)
-type Variables = Map Key JSType
+type Variables = Map Key Value
data GQLQueryRoot = GQLQueryRoot
{ fragments :: FragmentLib
, queryBody :: RawOperator
- , inputVariables :: [(Key, JSType)]
- }
-
-data GQLRoot a b = GQLRoot
- { query :: a
- , mutation :: b
+ , inputVariables :: [(Key, Value)]
}
diff --git a/src/Data/Morpheus/Validation/Arguments.hs b/src/Data/Morpheus/Validation/Arguments.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Arguments.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+
+module Data.Morpheus.Validation.Arguments
+ ( validateArguments
+ ) where
+
+import Data.Morpheus.Error.Arguments (argumentGotInvalidValue, argumentNameCollision,
+ undefinedArgument, unknownArguments)
+import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage)
+import Data.Morpheus.Error.Internal (internalUnknownTypeMessage)
+import Data.Morpheus.Error.Variable (incompatibleVariableType, undefinedVariable)
+import Data.Morpheus.Types.Internal.AST.Operator (ValidVariables, Variable (..))
+import Data.Morpheus.Types.Internal.AST.RawSelection (RawArgument (..), RawArguments, Reference (..))
+import Data.Morpheus.Types.Internal.AST.Selection (Argument (..), Arguments)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position)
+import Data.Morpheus.Types.Internal.Data (DataArgument, DataField (..), DataInputField,
+ DataOutputField, DataTypeLib, DataTypeWrapper (..),
+ isFieldNullable, showWrappedType)
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Types.Internal.Value (Value (Null))
+import Data.Morpheus.Validation.Input.Object (validateInputValue)
+import Data.Morpheus.Validation.Utils.Utils (checkForUnknownKeys, checkNameCollision, getInputType)
+import Data.Text (Text)
+
+resolveArgumentVariables :: Text -> ValidVariables -> DataOutputField -> RawArguments -> Validation Arguments
+resolveArgumentVariables operatorName variables DataField {fieldName, fieldArgs} = mapM resolveVariable
+ where
+ resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument)
+ resolveVariable (key', RawArgument argument') = pure (key', argument')
+ resolveVariable (key', VariableReference Reference {referenceName, referencePosition}) =
+ (key', ) . (`Argument` referencePosition) <$> lookupVar
+ where
+ stricter [] [] = True
+ stricter (NonNullType:xs1) (NonNullType:xs2) = stricter xs1 xs2
+ stricter (NonNullType:xs1) xs2 = stricter xs1 xs2
+ stricter (ListType:xs1) (ListType:xs2) = stricter xs1 xs2
+ stricter _ _ = False
+ lookupVar =
+ case lookup referenceName variables of
+ Nothing -> Left $ undefinedVariable operatorName referencePosition referenceName
+ Just Variable {variableValue, variableType, variableTypeWrappers} ->
+ case lookup key' fieldArgs of
+ Nothing -> Left $ unknownArguments fieldName [EnhancedKey key' referencePosition]
+ Just DataField {fieldType, fieldTypeWrappers} ->
+ if variableType == fieldType && stricter variableTypeWrappers fieldTypeWrappers
+ then return variableValue
+ else Left $ incompatibleVariableType referenceName varSignature fieldSignature referencePosition
+ where varSignature = showWrappedType variableTypeWrappers variableType
+ fieldSignature = showWrappedType fieldTypeWrappers fieldType
+
+handleInputError :: Text -> Position -> InputValidation a -> Validation ()
+handleInputError key' position' (Left error') = Left $ argumentGotInvalidValue key' (inputErrorMessage error') position'
+handleInputError _ _ _ = pure ()
+
+validateArgumentValue :: DataTypeLib -> DataField a -> (Text, Argument) -> Validation (Text, Argument)
+validateArgumentValue lib' DataField {fieldType = typeName', fieldTypeWrappers = wrappers'} (key', Argument value' position') =
+ getInputType typeName' lib' (internalUnknownTypeMessage typeName') >>= checkType >>
+ pure (key', Argument value' position')
+ where
+ checkType type' = handleInputError key' position' (validateInputValue lib' [] wrappers' type' (key', value'))
+
+validateArgument :: DataTypeLib -> Position -> Arguments -> (Text, DataArgument) -> Validation (Text, Argument)
+validateArgument types position' requestArgs (key', arg) =
+ case lookup key' requestArgs of
+ Nothing -> handleNullable
+ Just (Argument Null _) -> handleNullable
+ Just (Argument value pos) -> validateArgumentValue types arg (key', Argument value pos)
+ where
+ handleNullable =
+ if isFieldNullable arg
+ then pure (key', Argument Null position')
+ else Left $ undefinedArgument (EnhancedKey key' position')
+
+checkForUnknownArguments :: (Text, DataOutputField) -> Arguments -> Validation [(Text, DataInputField)]
+checkForUnknownArguments (fieldKey', DataField {fieldArgs = astArgs'}) args' =
+ checkForUnknownKeys enhancedKeys' fieldKeys error' >> checkNameCollision enhancedKeys' fieldKeys argumentNameCollision >>
+ pure astArgs'
+ where
+ error' = unknownArguments fieldKey'
+ enhancedKeys' = map argToKey args'
+ argToKey (key', Argument _ pos) = EnhancedKey key' pos
+ fieldKeys = map fst astArgs'
+
+validateArguments ::
+ DataTypeLib
+ -> Text
+ -> ValidVariables
+ -> (Text, DataOutputField)
+ -> Position
+ -> RawArguments
+ -> Validation Arguments
+validateArguments typeLib operatorName variables inputs pos rawArgs = do
+ args <- resolveArgumentVariables operatorName variables (snd inputs) rawArgs
+ dataArgs <- checkForUnknownArguments inputs args
+ mapM (validateArgument typeLib pos args) dataArgs
diff --git a/src/Data/Morpheus/Validation/Fragment.hs b/src/Data/Morpheus/Validation/Fragment.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Fragment.hs
@@ -0,0 +1,60 @@
+module Data.Morpheus.Validation.Fragment
+ ( validateFragments
+ ) where
+
+import qualified Data.Map as M (toList)
+import Data.Morpheus.Error.Fragment (cannotSpreadWithinItself)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawSelection (..), RawSelection' (..),
+ Reference (..))
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..))
+import Data.Morpheus.Types.Internal.Data (DataTypeLib)
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Types.Types (GQLQueryRoot (..))
+import Data.Morpheus.Validation.Utils.Utils (existsObjectType)
+import Data.Text (Text)
+
+type Node = EnhancedKey
+
+type NodeEdges = (Node, [Node])
+
+type Graph = [NodeEdges]
+
+scanForSpread :: DataTypeLib -> GQLQueryRoot -> (Text, RawSelection) -> [Node]
+scanForSpread lib' root' (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) =
+ concatMap (scanForSpread lib' root') selection'
+scanForSpread lib' root' (_, RawAlias {rawAliasSelection = selection'}) =
+ concatMap (scanForSpread lib' root') [selection']
+scanForSpread lib' root' (_, InlineFragment Fragment {fragmentSelection = selection'}) =
+ concatMap (scanForSpread lib' root') selection'
+scanForSpread _ _ (_, RawSelectionField {}) = []
+scanForSpread _ _ (_, Spread Reference {referenceName = name', referencePosition = position'}) =
+ [EnhancedKey name' position']
+
+validateFragment :: DataTypeLib -> GQLQueryRoot -> (Text, Fragment) -> Validation NodeEdges
+validateFragment lib' root (fName, Fragment { fragmentSelection = selection'
+ , fragmentType = target'
+ , fragmentPosition = position'
+ }) =
+ existsObjectType position' target' lib' >>
+ pure (EnhancedKey fName position', concatMap (scanForSpread lib' root) selection')
+
+validateFragments :: DataTypeLib -> GQLQueryRoot -> Validation ()
+validateFragments lib root = mapM (validateFragment lib root) (M.toList $ fragments root) >>= detectLoopOnFragments
+
+detectLoopOnFragments :: Graph -> Validation ()
+detectLoopOnFragments lib = mapM_ checkFragment lib
+ where
+ checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID]
+
+checkForCycle :: Graph -> Node -> [Node] -> Validation Graph
+checkForCycle lib parentNode history =
+ case lookup parentNode lib of
+ Just node -> concat <$> mapM checkNode node
+ Nothing -> pure []
+ where
+ checkNode x =
+ if x `elem` history
+ then cycleError x
+ else recurse x
+ recurse node = checkForCycle lib node $ history ++ [node]
+ cycleError n = Left $ cannotSpreadWithinItself $ history ++ [n]
diff --git a/src/Data/Morpheus/Validation/Input/Enum.hs b/src/Data/Morpheus/Validation/Input/Enum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Input/Enum.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Validation.Input.Enum
+ ( validateEnum
+ ) where
+
+import Data.List (elem)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Text (Text)
+
+validateEnum :: error -> [Text] -> Value -> Either error Value
+validateEnum error' tags' (Enum enumValue) =
+ if enumValue `elem` tags'
+ then pure (Enum enumValue)
+ else Left error'
+validateEnum error' _ _ = Left error'
diff --git a/src/Data/Morpheus/Validation/Input/Object.hs b/src/Data/Morpheus/Validation/Input/Object.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Input/Object.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Morpheus.Validation.Input.Object
+ ( validateInputValue
+ ) where
+
+import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataInputType, DataKind (..), DataType (..),
+ DataTypeLib (..), DataTypeWrapper (..), DataValidator (..),
+ showFullAstType)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Morpheus.Validation.Input.Enum (validateEnum)
+import Data.Morpheus.Validation.Utils.Utils (getInputType, lookupField)
+import Data.Text (Text)
+
+typeMismatch :: Value -> Text -> [Prop] -> InputError
+typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing
+
+-- Validate Variable Argument or all Possible input Values
+validateInputValue ::
+ DataTypeLib -> [Prop] -> [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value
+validateInputValue lib' prop' = validate
+ where
+ throwError :: [DataTypeWrapper] -> DataInputType -> Value -> InputValidation Value
+ throwError wrappers' type' value' = Left $ UnexpectedType prop' (showFullAstType wrappers' type') value' Nothing
+ {-- VALIDATION --}
+ {-- 1. VALIDATE WRAPPERS -}
+ validate :: [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value
+ -- throw error on not nullable type if value = null
+ validate (NonNullType:wrappers') type' (_, Null) = throwError wrappers' type' Null
+ -- resolves nullable value as null
+ validate _ _ (_, Null) = return Null
+ -- ignores NonNUllTypes if value /= null
+ validate (NonNullType:wrappers') type' value' = validateInputValue lib' prop' wrappers' type' value'
+ {-- VALIDATE LIST -}
+ validate (ListType:wrappers') type' (key', List list') = List <$> mapM validateElement list'
+ where
+ validateElement element' = validateInputValue lib' prop' wrappers' type' (key', element')
+ {-- 2. VALIDATE TYPES, all wrappers are already Processed --}
+ {-- VALIDATE OBJECT--}
+ validate [] (ObjectKind DataType {typeData = parentFields'}) (_, Object fields) =
+ Object <$> mapM validateField fields
+ where
+ validateField (_name, value') = do
+ (type', currentProp') <- validationData value'
+ wrappers' <- fieldTypeWrappers <$> getField
+ value'' <- validateInputValue lib' currentProp' wrappers' type' (_name, value')
+ return (_name, value'')
+ where
+ validationData x = do
+ fieldTypeName' <- fieldType <$> getField
+ let currentProp = prop' ++ [Prop _name fieldTypeName']
+ type' <- getInputType fieldTypeName' lib' (typeMismatch x fieldTypeName' currentProp)
+ return (type', currentProp)
+ getField = lookupField _name parentFields' (UnknownField prop' _name)
+ {-- VALIDATE SCALAR --}
+ validate [] (EnumKind DataType {typeData = tags', typeName = name'}) (_, value') =
+ validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'
+ {-- VALIDATE ENUM --}
+ validate [] (ScalarKind DataType {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =
+ case validator' value' of
+ Right _ -> return value'
+ Left "" -> Left $ UnexpectedType prop' name' value' Nothing
+ Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage)
+ {-- 3. THROW ERROR: on invalid values --}
+ validate wrappers' type' (_, value') = throwError wrappers' type' value'
diff --git a/src/Data/Morpheus/Validation/Selection.hs b/src/Data/Morpheus/Validation/Selection.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Selection.hs
@@ -0,0 +1,161 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Validation.Selection
+ ( validateSelectionSet
+ ) where
+
+import Data.Morpheus.Error.Selection (cannotQueryField, duplicateQuerySelections,
+ hasNoSubfields)
+import Data.Morpheus.Types.Internal.AST.Operator (ValidVariables)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),
+ RawSelection' (..), RawSelectionSet)
+import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..))
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataOutputObject, DataType (..),
+ DataTypeKind (..), DataTypeLib (..))
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Validation.Arguments (validateArguments)
+import Data.Morpheus.Validation.Spread (castFragmentType, resolveSpread)
+import Data.Morpheus.Validation.Utils.Selection (lookupFieldAsSelectionSet, lookupSelectionField,
+ lookupUnionTypes, notObject)
+import Data.Morpheus.Validation.Utils.Utils (checkNameCollision)
+import Data.Text (Text)
+
+checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet
+checkDuplicatesOn DataType {typeName = name'} keys = checkNameCollision enhancedKeys (map fst keys) error' >> pure keys
+ where
+ error' = duplicateQuerySelections name'
+ enhancedKeys = map selToKey keys
+ selToKey (key', Selection {selectionPosition = position'}) = EnhancedKey key' position'
+
+clusterUnionSelection ::
+ FragmentLib -> Text -> [DataOutputObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet)
+clusterUnionSelection fragments' type' possibleTypes' = splitFrag
+ where
+ packFragment fragment' = return ([fragment'], [])
+ typeNames = map typeName possibleTypes'
+ splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet)
+ splitFrag (_, Spread reference') = resolveSpread fragments' typeNames reference' >>= packFragment
+ splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) =
+ return
+ ( []
+ , [ ( "__typename"
+ , Selection {selectionRec = SelectionField, selectionArguments = [], selectionPosition = position'})
+ ])
+ splitFrag (key', RawSelectionSet RawSelection' {rawSelectionPosition = position'}) =
+ Left $ cannotQueryField key' type' position'
+ splitFrag (key', RawSelectionField RawSelection' {rawSelectionPosition = position'}) =
+ Left $ cannotQueryField key' type' position'
+ splitFrag (key', RawAlias {rawAliasPosition = position'}) = Left $ cannotQueryField key' type' position'
+ splitFrag (_, InlineFragment fragment') =
+ castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment
+
+categorizeTypes :: [DataOutputObject] -> [Fragment] -> [(DataOutputObject, [Fragment])]
+categorizeTypes types' fragments' = map categorizeType types'
+ where
+ categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])
+ categorizeType type' = (type', filter matches fragments')
+ where
+ matches fragment' = fragmentType fragment' == typeName type'
+
+flatTuple :: [([a], [b])] -> ([a], [b])
+flatTuple list' = (concatMap fst list', concatMap snd list')
+ {-
+ - all Variable and Fragment references will be: resolved and validated
+ - unionTypes: will be clustered under type names
+ ...A on T1 {}
+ ...B on T2 {}
+ ...C on T2 {}
+ will be become : [
+ ("T1",[]),
+ ("T2",[,])
+ ]
+ -}
+
+validateSelectionSet ::
+ DataTypeLib
+ -> FragmentLib
+ -> Text
+ -> ValidVariables
+ -> DataOutputObject
+ -> RawSelectionSet
+ -> Validation SelectionSet
+validateSelectionSet lib' fragments' operatorName variables = __validate
+ where
+ __validate dataType'@DataType {typeName = typeName'} selectionSet' =
+ concat <$> mapM validateSelection selectionSet' >>= checkDuplicatesOn dataType'
+ where
+ validateFragment Fragment {fragmentSelection = selection'} = __validate dataType' selection'
+ {-
+ get dataField and validated arguments for RawSelection
+ -}
+ getValidationData key' RawSelection' {rawSelectionArguments, rawSelectionPosition} = do
+ selectionField <- lookupSelectionField rawSelectionPosition key' dataType'
+ arguments' <-
+ validateArguments
+ lib'
+ operatorName
+ variables
+ (key', selectionField)
+ rawSelectionPosition
+ rawSelectionArguments
+ return (selectionField, arguments')
+ {-
+ validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet
+ -}
+ validateSelection :: (Text, RawSelection) -> Validation SelectionSet
+ validateSelection (key', RawAlias {rawAliasSelection = rawSelection', rawAliasPosition = position'}) =
+ fmap processSingleSelection <$> validateSelection rawSelection'
+ where
+ processSingleSelection (selKey', selection') =
+ ( key'
+ , selection'
+ { selectionRec = SelectionAlias {aliasFieldName = selKey', aliasSelection = selectionRec selection'}
+ , selectionPosition = position'
+ })
+ validateSelection (key', RawSelectionSet fullRawSelection'@RawSelection' { rawSelectionRec = rawSelectors
+ , rawSelectionPosition = position'
+ }) = do
+ (dataField', arguments') <- getValidationData key' fullRawSelection'
+ case fieldKind dataField' of
+ KindUnion -> do
+ (categories', __typename') <- clusterTypes
+ mapM (validateCluster __typename') categories' >>= returnSelection arguments' . UnionSelection
+ where clusterTypes = do
+ unionTypes' <- lookupUnionTypes position' key' lib' dataField'
+ (spreads', __typename') <-
+ flatTuple <$> mapM (clusterUnionSelection fragments' typeName' unionTypes') rawSelectors
+ return (categorizeTypes unionTypes' spreads', __typename')
+ {--
+ second arguments will be added to every selection cluster
+ -}
+ validateCluster :: SelectionSet -> (DataOutputObject, [Fragment]) -> Validation (Text, SelectionSet)
+ validateCluster sysSelection' (type', frags') = do
+ selection' <- __validate type' (concatMap fragmentSelection frags')
+ return (typeName type', sysSelection' ++ selection')
+ KindObject -> do
+ fieldType' <- lookupFieldAsSelectionSet position' key' lib' dataField'
+ __validate fieldType' rawSelectors >>= returnSelection arguments' . SelectionSet
+ _ -> Left $ hasNoSubfields key' (fieldType dataField') position'
+ where
+ returnSelection arguments' selection' =
+ pure
+ [ ( key'
+ , Selection
+ {selectionArguments = arguments', selectionRec = selection', selectionPosition = position'})
+ ]
+ validateSelection (key', RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition = position'}) = do
+ (dataField', arguments') <- getValidationData key' fullRawSelection'
+ _ <- notObject (key', position') dataField'
+ pure
+ [ ( key'
+ , Selection
+ {selectionArguments = arguments', selectionRec = SelectionField, selectionPosition = position'})
+ ]
+ validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment
+ validateSelection (_, InlineFragment fragment') =
+ castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment
diff --git a/src/Data/Morpheus/Validation/Spread.hs b/src/Data/Morpheus/Validation/Spread.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Spread.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Data.Morpheus.Validation.Spread
+ ( getFragment
+ , resolveSpread
+ , castFragmentType
+ ) where
+
+import qualified Data.Map as M (lookup)
+import Data.Morpheus.Error.Spread (cannotBeSpreadOnType, unknownFragment)
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, Reference (..))
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Text (Text)
+import qualified Data.Text as T (concat)
+
+getFragment :: Reference -> FragmentLib -> Validation Fragment
+getFragment Reference {referenceName, referencePosition} lib =
+ case M.lookup referenceName lib of
+ Nothing -> Left $ unknownFragment referenceName referencePosition
+ Just fragment -> pure fragment
+
+castFragmentType :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment
+castFragmentType key' position' targets' fragment@Fragment {fragmentType = type'} =
+ if type' `elem` targets'
+ then pure fragment
+ else Left $ cannotBeSpreadOnType key' type' position' (T.concat targets')
+
+resolveSpread :: FragmentLib -> [Text] -> Reference -> Validation Fragment
+resolveSpread fragments' allowedTargets' reference@Reference {referenceName = key', referencePosition = position'} =
+ getFragment reference fragments' >>= castFragmentType (Just key') position' allowedTargets'
diff --git a/src/Data/Morpheus/Validation/Utils/Selection.hs b/src/Data/Morpheus/Validation/Utils/Selection.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Utils/Selection.hs
@@ -0,0 +1,46 @@
+module Data.Morpheus.Validation.Utils.Selection
+ ( lookupFieldAsSelectionSet
+ , mustBeObject
+ , notObject
+ , lookupSelectionField
+ , lookupUnionTypes
+ ) where
+
+import Data.Morpheus.Error.Selection (cannotQueryField, hasNoSubfields, subfieldsNotSelected)
+import Data.Morpheus.Types.Internal.Base (Position)
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataOutputField, DataOutputObject,
+ DataType (..), DataTypeKind (..), DataTypeLib (..))
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Validation.Utils.Utils (lookupField, lookupType)
+import Data.Text (Text)
+
+isObjectKind :: DataField a -> Bool
+isObjectKind field' = KindObject == fieldKind field'
+
+mustBeObject :: (Text, Position) -> DataOutputField -> Validation DataOutputField
+mustBeObject (key', position') field' =
+ if isObjectKind field'
+ then pure field'
+ else Left $ hasNoSubfields key' (fieldType field') position'
+
+notObject :: (Text, Position) -> DataOutputField -> Validation DataOutputField
+notObject (key', position') field' =
+ if isObjectKind field'
+ then Left $ subfieldsNotSelected key' (fieldType field') position'
+ else pure field'
+
+lookupUnionTypes :: Position -> Text -> DataTypeLib -> DataOutputField -> Validation [DataOutputObject]
+lookupUnionTypes position' key' lib' DataField {fieldType = type'} =
+ lookupType error' (union lib') type' >>= mapM (lookupType error' (object lib') . fieldType) . typeData
+ where
+ error' = hasNoSubfields key' type' position'
+
+lookupFieldAsSelectionSet :: Position -> Text -> DataTypeLib -> DataOutputField -> Validation DataOutputObject
+lookupFieldAsSelectionSet position' key' lib' DataField {fieldType = type'} = lookupType error' (object lib') type'
+ where
+ error' = hasNoSubfields key' type' position'
+
+lookupSelectionField :: Position -> Text -> DataOutputObject -> Validation DataOutputField
+lookupSelectionField position' key' DataType {typeData = fields', typeName = name'} = lookupField key' fields' error'
+ where
+ error' = cannotQueryField key' name' position'
diff --git a/src/Data/Morpheus/Validation/Utils/Utils.hs b/src/Data/Morpheus/Validation/Utils/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Utils/Utils.hs
@@ -0,0 +1,68 @@
+module Data.Morpheus.Validation.Utils.Utils
+ ( differKeys
+ , existsObjectType
+ , lookupType
+ , getInputType
+ , lookupField
+ , checkNameCollision
+ , checkForUnknownKeys
+ ) where
+
+import Data.List ((\\))
+import Data.Morpheus.Error.Variable (unknownType)
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Key, Position, enhanceKeyWithNull)
+import Data.Morpheus.Types.Internal.Data (DataInputType, DataKind (..), DataLeaf (..), DataOutputObject,
+ DataTypeLib (..))
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import qualified Data.Set as S
+import Data.Text (Text)
+
+type GenError error a = error -> Either error a
+
+lookupType :: error -> [(Text, a)] -> Text -> Either error a
+lookupType error' lib' typeName' =
+ case lookup typeName' lib' of
+ Nothing -> Left error'
+ Just x -> pure x
+
+lookupField :: Text -> [(Text, fType)] -> GenError error fType
+lookupField id' lib' error' =
+ case lookup id' lib' of
+ Nothing -> Left error'
+ Just field -> pure field
+
+getInputType :: Text -> DataTypeLib -> GenError error DataInputType
+getInputType typeName' lib error' =
+ case lookup typeName' (inputObject lib) of
+ Just x -> pure (ObjectKind x)
+ Nothing ->
+ case lookup typeName' (leaf lib) of
+ Nothing -> Left error'
+ Just (LeafScalar x) -> pure (ScalarKind x)
+ Just (LeafEnum x) -> pure (EnumKind x)
+
+existsObjectType :: Position -> Text -> DataTypeLib -> Validation DataOutputObject
+existsObjectType position' typeName' lib = lookupType error' (object lib) typeName'
+ where
+ error' = unknownType typeName' position'
+
+differKeys :: [EnhancedKey] -> [Key] -> [EnhancedKey]
+differKeys enhanced keys = enhanced \\ map enhanceKeyWithNull keys
+
+removeDuplicates :: Ord a => [a] -> [a]
+removeDuplicates = S.toList . S.fromList
+
+elementOfKeys :: [Text] -> EnhancedKey -> Bool
+elementOfKeys keys' EnhancedKey {uid = id'} = id' `elem` keys'
+
+checkNameCollision :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]
+checkNameCollision enhancedKeys' keys' errorGenerator' =
+ case differKeys enhancedKeys' (removeDuplicates keys') of
+ [] -> pure enhancedKeys'
+ duplicates' -> Left $ errorGenerator' duplicates'
+
+checkForUnknownKeys :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]
+checkForUnknownKeys enhancedKeys' keys' errorGenerator' =
+ case filter (not . elementOfKeys keys') enhancedKeys' of
+ [] -> pure enhancedKeys'
+ unknownKeys' -> Left $ errorGenerator' unknownKeys'
diff --git a/src/Data/Morpheus/Validation/Validation.hs b/src/Data/Morpheus/Validation/Validation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Validation.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Data.Morpheus.Validation.Validation
+ ( validateRequest
+ ) where
+
+import Data.Map (fromList)
+import Data.Morpheus.Error.Mutation (mutationIsNotDefined)
+import Data.Morpheus.Error.Subscription (subscriptionIsNotDefined)
+import Data.Morpheus.Types.Internal.AST.Operator (Operator (..), Operator' (..), RawOperator, RawOperator',
+ ValidOperator)
+import Data.Morpheus.Types.Internal.AST.Selection (SelectionSet)
+import Data.Morpheus.Types.Internal.Data (DataOutputObject, DataTypeLib (..))
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Types.Types (GQLQueryRoot (..))
+import Data.Morpheus.Validation.Fragment (validateFragments)
+import Data.Morpheus.Validation.Selection (validateSelectionSet)
+import Data.Morpheus.Validation.Variable (resolveOperatorVariables)
+
+updateQuery :: RawOperator -> SelectionSet -> ValidOperator
+updateQuery (Query (Operator' name' _ _ pos)) sel = Query (Operator' name' [] sel pos)
+updateQuery (Mutation (Operator' name' _ _ pos)) sel = Mutation (Operator' name' [] sel pos)
+updateQuery (Subscription (Operator' name' _ _ pos)) sel = Subscription (Operator' name' [] sel pos)
+
+getOperator :: RawOperator -> DataTypeLib -> Validation (DataOutputObject, RawOperator')
+getOperator (Query operator') lib' = pure (snd $ query lib', operator')
+getOperator (Mutation operator') lib' =
+ case mutation lib' of
+ Just (_, mutation') -> pure (mutation', operator')
+ Nothing -> Left $ mutationIsNotDefined (operatorPosition operator')
+getOperator (Subscription operator') lib' =
+ case subscription lib' of
+ Just (_, subscription') -> pure (subscription', operator')
+ Nothing -> Left $ subscriptionIsNotDefined (operatorPosition operator')
+
+validateRequest :: DataTypeLib -> GQLQueryRoot -> Validation ValidOperator
+validateRequest lib' root' = do
+ (operatorType', operator') <- getOperator (queryBody root') lib'
+ variables' <- resolveOperatorVariables lib' (fragments root') (fromList $ inputVariables root') operator'
+ validateFragments lib' root'
+ selectors <-
+ validateSelectionSet
+ lib'
+ (fragments root')
+ (operatorName operator')
+ variables'
+ operatorType'
+ (operatorSelection operator')
+ pure $ updateQuery (queryBody root') selectors
diff --git a/src/Data/Morpheus/Validation/Variable.hs b/src/Data/Morpheus/Validation/Variable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Morpheus/Validation/Variable.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Data.Morpheus.Validation.Variable
+ ( resolveOperatorVariables
+ ) where
+
+import Data.List ((\\))
+import qualified Data.Map as M (lookup)
+import Data.Maybe (maybe)
+import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage)
+import Data.Morpheus.Error.Variable (uninitializedVariable, unknownType, unusedVariables,
+ variableGotInvalidValue)
+import Data.Morpheus.Types.Internal.AST.Operator (Operator' (..), RawOperator', ValidVariables,
+ Variable (..))
+import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawArgument (..),
+ RawSelection (..), RawSelection' (..), RawSelectionSet,
+ Reference (..))
+import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position)
+import Data.Morpheus.Types.Internal.Data (DataInputType, DataTypeLib)
+import Data.Morpheus.Types.Internal.Validation (Validation)
+import Data.Morpheus.Types.Internal.Value (Value (..))
+import Data.Morpheus.Types.Types (Variables)
+import Data.Morpheus.Validation.Input.Object (validateInputValue)
+import Data.Morpheus.Validation.Spread (getFragment)
+import Data.Morpheus.Validation.Utils.Utils (getInputType)
+import Data.Semigroup ((<>))
+import Data.Text (Text)
+
+getVariableType :: Text -> Position -> DataTypeLib -> Validation DataInputType
+getVariableType type' position' lib' = getInputType type' lib' error'
+ where
+ error' = unknownType type' position'
+
+lookupVariable :: Variables -> Text -> (Text -> error) -> Either error Value
+lookupVariable variables' key' error' =
+ case M.lookup key' variables' of
+ Nothing -> Left $ error' key'
+ Just value -> pure value
+
+handleInputError :: Text -> Position -> InputValidation Value -> Validation (Text, Value)
+handleInputError key' position' (Left error') = Left $ variableGotInvalidValue key' (inputErrorMessage error') position'
+handleInputError key' _ (Right value') = pure (key', value')
+
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f = fmap concat . mapM f
+
+allVariableReferences :: FragmentLib -> [RawSelectionSet] -> Validation [EnhancedKey]
+allVariableReferences fragmentLib = concatMapM (concatMapM searchReferences)
+ where
+ referencesFromArgument :: (Text, RawArgument) -> [EnhancedKey]
+ referencesFromArgument (_, RawArgument {}) = []
+ referencesFromArgument (_, VariableReference Reference {referenceName, referencePosition}) =
+ [EnhancedKey referenceName referencePosition]
+ -- | search used variables in every arguments
+ searchReferences :: (Text, RawSelection) -> Validation [EnhancedKey]
+ searchReferences (_, RawSelectionSet RawSelection' {rawSelectionArguments, rawSelectionRec}) =
+ getArgs <$> concatMapM searchReferences rawSelectionRec
+ where
+ getArgs :: [EnhancedKey] -> [EnhancedKey]
+ getArgs x = concatMap referencesFromArgument rawSelectionArguments <> x
+ searchReferences (_, InlineFragment Fragment {fragmentSelection}) = concatMapM searchReferences fragmentSelection
+ searchReferences (_, RawAlias {rawAliasSelection}) = searchReferences rawAliasSelection
+ searchReferences (_, RawSelectionField RawSelection' {rawSelectionArguments}) =
+ return $ concatMap referencesFromArgument rawSelectionArguments
+ searchReferences (_, Spread reference) =
+ getFragment reference fragmentLib >>= concatMapM searchReferences . fragmentSelection
+
+resolveOperatorVariables :: DataTypeLib -> FragmentLib -> Variables -> RawOperator' -> Validation ValidVariables
+resolveOperatorVariables typeLib fragmentLib root operator' = do
+ allVariableReferences fragmentLib [operatorSelection operator'] >>= checkUnusedVariables
+ mapM (lookupAndValidateValueOnBody typeLib root) (operatorArgs operator')
+ where
+ varToKey :: (Text, Variable ()) -> EnhancedKey
+ varToKey (key', Variable {variablePosition}) = EnhancedKey key' variablePosition
+ --
+ checkUnusedVariables :: [EnhancedKey] -> Validation ()
+ checkUnusedVariables references' =
+ case map varToKey (operatorArgs operator') \\ references' of
+ [] -> pure ()
+ unused' -> Left $ unusedVariables (operatorName operator') unused'
+
+lookupAndValidateValueOnBody :: DataTypeLib -> Variables -> (Text, Variable ()) -> Validation (Text, Variable Value)
+lookupAndValidateValueOnBody typeLib bodyVariables (key', var@Variable { variableType
+ , variablePosition
+ , isVariableRequired
+ , variableTypeWrappers
+ }) =
+ toVariable <$> (getVariableType variableType variablePosition typeLib >>= checkType isVariableRequired)
+ where
+ toVariable (k, x) = (k, var {variableValue = x})
+ checkType True _type =
+ lookupVariable bodyVariables key' (uninitializedVariable variablePosition variableType) >>= validator _type
+ checkType False _type = maybe (pure (key', Null)) (validator _type) (M.lookup key' bodyVariables)
+ validator _type varValue =
+ handleInputError key' variablePosition $ validateInputValue typeLib [] variableTypeWrappers _type (key', varValue)
diff --git a/src/Data/Morpheus/Wrapper.hs b/src/Data/Morpheus/Wrapper.hs
deleted file mode 100644
--- a/src/Data/Morpheus/Wrapper.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-module Data.Morpheus.Wrapper
- ( GQLRoot(..)
- , EnumOf
- , ScalarOf
- , (::->)(..)
- , wrap
- , unwrap
- ) where
-
-import Data.Morpheus.Types.Describer ((::->) (Resolver), EnumOf (..), ScalarOf (..))
-import Data.Morpheus.Types.Types (GQLRoot (..))
-
-class Wrapper m where
- wrap :: a -> m a
- unwrap :: m a -> a
-
-instance Wrapper EnumOf where
- wrap = EnumOf
- unwrap (EnumOf x) = x
-
-instance Wrapper ScalarOf where
- wrap = ScalarOf
- unwrap (ScalarOf x) = x
diff --git a/test/Feature/Holistic/API.gql b/test/Feature/Holistic/API.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/API.gql
@@ -0,0 +1,44 @@
+scalar TestScalar
+
+enum TestEnum {
+ EnumA
+ EnumB
+ EnumC
+}
+
+input NestedInputObject {
+ fieldTestID: ID!
+}
+
+input TestInputObject {
+ fieldTestScalar: TestScalar!
+ fieldNestedInputObject: [NestedInputObject]!
+}
+
+type Address {
+ city: String!
+ street(
+ argInputObject: TestInputObject!
+ argMaybeString: String
+ ): [[[[String!]!]!]]
+ houseNumber: Int!
+}
+
+type User {
+ name(id: ID!): String!
+ email: String!
+ address: Address
+ testEnum: TestEnum
+}
+
+union TestUnion = User | Address
+
+type Query {
+ user: User!
+ myUnion: TestUnion!
+ fieldID: ID!
+}
+
+type Mutation {
+ createUser: User!
+}
diff --git a/test/Feature/Holistic/API.hs b/test/Feature/Holistic/API.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/API.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Feature.Holistic.API
+ ( api
+ ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, KIND, OBJECT, SCALAR, UNION)
+import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), ResM,
+ ScalarValue (..))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+type instance KIND TestEnum = ENUM
+
+type instance KIND TestScalar = SCALAR
+
+type instance KIND NestedInputObject = INPUT_OBJECT
+
+type instance KIND Coordinates = INPUT_OBJECT
+
+type instance KIND TestInputObject = INPUT_OBJECT
+
+type instance KIND Address = OBJECT
+
+type instance KIND User = OBJECT
+
+type instance KIND TestUnion = UNION
+
+data TestEnum
+ = EnumA
+ | EnumB
+ | EnumC
+ deriving (Generic, GQLType)
+
+data TestScalar =
+ TestScalar Int
+ Int
+ deriving (Generic, GQLType)
+
+instance GQLScalar TestScalar where
+ parseValue _ = pure (TestScalar 1 0)
+ serialize (TestScalar x y) = Int (x * 100 + y)
+
+newtype NestedInputObject = NestedInputObject
+ { fieldTestID :: ID
+ } deriving (Generic, GQLType)
+
+data TestInputObject = TestInputObject
+ { fieldTestScalar :: TestScalar
+ , fieldNestedInputObject :: [Maybe NestedInputObject]
+ } deriving (Generic, GQLType)
+
+data StreetArgs = StreetArgs
+ { argInputObject :: TestInputObject
+ , argMaybeString :: Maybe Text
+ } deriving (Generic)
+
+data Address = Address
+ { city :: Text
+ , street :: StreetArgs -> ResM (Maybe [Maybe [[[Text]]]])
+ , houseNumber :: Int
+ } deriving (Generic, GQLType)
+
+data TestUnion
+ = UnionA User
+ | UnionB Address
+ deriving (Generic, GQLType)
+
+data Coordinates = Coordinates
+ { latitude :: TestScalar
+ , longitude :: Int
+ } deriving (Generic, GQLType)
+
+data AddressArgs = AddressArgs
+ { coordinates :: Coordinates
+ , comment :: Maybe Text
+ } deriving (Generic)
+
+data OfficeArgs = OfficeArgs
+ { zipCode :: Maybe [Int]
+ , cityID :: TestEnum
+ } deriving (Generic)
+
+data User = User
+ { name :: Text
+ , email :: Text
+ , address :: AddressArgs -> ResM Address
+ , office :: OfficeArgs -> ResM Address
+ , friend :: () -> ResM (Maybe User)
+ } deriving (Generic)
+
+instance GQLType User where
+ description _ = "Custom Description for Client Defined User Type"
+
+data Query = Query
+ { user :: () -> ResM User
+ , testUnion :: Maybe TestUnion
+ } deriving (Generic)
+
+newtype Mutation = Mutation
+ { createUser :: AddressArgs -> ResM User
+ } deriving (Generic)
+
+newtype Subscription = Subscription
+ { newUser :: AddressArgs -> ResM User
+ } deriving (Generic)
+
+resolveAddress :: a -> ResM Address
+resolveAddress _ = return Address {city = "", houseNumber = 1, street = const $ return Nothing}
+
+resolveUser :: a -> ResM User
+resolveUser _ =
+ return $
+ User
+ {name = "testName", email = "", address = resolveAddress, office = resolveAddress, friend = const $ return Nothing}
+
+createUserMutation :: AddressArgs -> ResM User
+createUserMutation = resolveUser
+
+newUserSubscription :: AddressArgs -> ResM User
+newUserSubscription = resolveUser
+
+rootResolver :: GQLRootResolver IO Query Mutation Subscription
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {user = resolveUser, testUnion = Nothing}
+ , mutationResolver = return Mutation {createUser = createUserMutation}
+ , subscriptionResolver = return Subscription {newUser = newUserSubscription}
+ }
+
+api :: ByteString -> IO ByteString
+api = interpreter rootResolver
diff --git a/test/Feature/Holistic/arguments/nameConflict/query.gql b/test/Feature/Holistic/arguments/nameConflict/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/nameConflict/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ address(comment: "", comment: "") {
+ city
+ }
+ }
+}
diff --git a/test/Feature/Holistic/arguments/nameConflict/response.json b/test/Feature/Holistic/arguments/nameConflict/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/nameConflict/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "There can Be only One Argument Named \"comment\"",
+ "locations": [
+ {
+ "line": 3,
+ "column": 35
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/arguments/undefinedArgument/query.gql b/test/Feature/Holistic/arguments/undefinedArgument/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/undefinedArgument/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ address {
+ city
+ }
+ }
+}
diff --git a/test/Feature/Holistic/arguments/undefinedArgument/response.json b/test/Feature/Holistic/arguments/undefinedArgument/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/undefinedArgument/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Required Argument: \"coordinates\" was not Defined",
+ "locations": [
+ {
+ "line": 3,
+ "column": 13
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/arguments/unknownArguments/query.gql b/test/Feature/Holistic/arguments/unknownArguments/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/unknownArguments/query.gql
@@ -0,0 +1,5 @@
+{
+ user (name:bal , parent:sa ){
+ name
+ }
+}
diff --git a/test/Feature/Holistic/arguments/unknownArguments/response.json b/test/Feature/Holistic/arguments/unknownArguments/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/arguments/unknownArguments/response.json
@@ -0,0 +1,22 @@
+{
+ "errors": [
+ {
+ "message": "Unknown Argument \"name\" on Field \"user\".",
+ "locations": [
+ {
+ "line": 2,
+ "column": 14
+ }
+ ]
+ },
+ {
+ "message": "Unknown Argument \"parent\" on Field \"user\".",
+ "locations": [
+ {
+ "line": 2,
+ "column": 27
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/cases.json b/test/Feature/Holistic/cases.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/cases.json
@@ -0,0 +1,154 @@
+[
+ {
+ "path": "fragment/loopingFragment",
+ "description": "fail when: fragment directly or indirectly references itself"
+ },
+ {
+ "path": "arguments/unknownArguments",
+ "description": "fail when: argument on field is not recognised by the schema"
+ },
+ {
+ "path": "arguments/nameConflict",
+ "description": "fail when: argument names on field are not unique"
+ },
+ {
+ "path": "arguments/undefinedArgument",
+ "description": "fail when: required argument is not defined in selection "
+ },
+ {
+ "path": "selection/unknownField",
+ "description": "fail when: selected field does not exist on type"
+ },
+ {
+ "path": "selection/hasNoSubFields",
+ "description": "fail when: selected subFields on non object type"
+ },
+ {
+ "path": "selection/mustHaveSubFields",
+ "description": "fail when: is not selected subFields on object type"
+ },
+ {
+ "path": "selection/nameConflict",
+ "description": "fail when: selected fields has same name"
+ },
+ {
+ "path": "selection/AliasNameConflict",
+ "description": "fail when: selected alias has same name"
+ },
+ {
+ "path": "selection/AliasResolve",
+ "description": "resolves same field with different name"
+ },
+ {
+ "path": "selection/AliasUnknownField",
+ "description": "fail when: selected field in alias does not exist on type"
+ },
+ {
+ "path": "fragment/inlineFragment",
+ "description": "returns field selected by inline Fragment"
+ },
+ {
+ "path": "fragment/inlineFragmentTypeMismatch",
+ "description": "fail when: inline fragment type is incompatible with object type"
+ },
+ {
+ "path": "fragment/cannotBeSpreadOnType",
+ "description": "fail when: fragment type is incompatible with object type"
+ },
+ {
+ "path": "parsing/invalidNotNullOperator",
+ "description": "fail when: user supplies '@' instead of '!'"
+ },
+ {
+ "path": "parsing/missingCloseBrace",
+ "description": "fail when: user misses out a closing '}'"
+ },
+ {
+ "path": "parsing/generousSpaces",
+ "description": "returns query even when spacing is extremely liberal"
+ },
+ {
+ "path": "parsing/complex",
+ "description": "returns on a complex query that exercises all features"
+ },
+ {
+ "path": "parsing/extraCommas",
+ "description": "fails on a query with too many commas"
+ },
+ {
+ "path": "parsing/notNullSpacing",
+ "description": "returns on a query that pads all '!' chars with whitespace"
+ },
+ {
+ "path": "introspection/schemaTypes/__Type",
+ "description": "benchmark __Type"
+ },
+ {
+ "path": "introspection/schemaTypes/__InputValue",
+ "description": "benchmark __InputValue"
+ },
+ {
+ "path": "introspection/schemaTypes/__Field",
+ "description": "benchmark __Field"
+ },
+ {
+ "path": "introspection/schemaTypes/__EnumValue",
+ "description": "benchmark __EnumValue"
+ },
+ {
+ "path": "introspection/schemaTypes/__TypeKind",
+ "description": "benchmark __TypeKind"
+ },
+ {
+ "path": "introspection/schemaTypes/__Directive",
+ "description": "benchmark __Directive"
+ },
+ {
+ "path": "introspection/schemaTypes/__DirectiveLocation",
+ "description": "benchmark __DirectiveLocation"
+ },
+ {
+ "path": "introspection/schemaTypes/__Schema",
+ "description": "benchmark __Schema"
+ },
+ {
+ "path": "introspection/defaultTypes/String",
+ "description": "benchmark String"
+ },
+ {
+ "path": "introspection/defaultTypes/Boolean",
+ "description": "benchmark Boolean"
+ },
+ {
+ "path": "introspection/defaultTypes/Int",
+ "description": "benchmark Int"
+ },
+ {
+ "path": "introspection/defaultTypes/Float",
+ "description": "Float returns null, if it is not defined by schema"
+ },
+ {
+ "path": "introspection/defaultTypes/ID",
+ "description": "benchmark ID"
+ },
+ {
+ "path": "introspection/kinds/OBJECT",
+ "description": "test introspection of OBJECT kind with args, NonNull and List wrappers"
+ },
+ {
+ "path": "introspection/kinds/INPUT_OBJECT",
+ "description": "test introspection of INPUT_OBJECT kind"
+ },
+ {
+ "path": "introspection/kinds/SCALAR",
+ "description": "test introspection of SCALAR kind"
+ },
+ {
+ "path": "introspection/kinds/ENUM",
+ "description": "test introspection of ENUM kind"
+ },
+ {
+ "path": "introspection/kinds/UNION",
+ "description": "test introspection of UNION kind"
+ }
+]
diff --git a/test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql b/test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql
@@ -0,0 +1,8 @@
+{
+ user {
+ ...UserFragment
+ }
+}
+fragment UserFragment on Address {
+ aText
+}
diff --git a/test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json b/test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json
@@ -0,0 +1,9 @@
+{
+ "errors": [{
+ "message": "Fragment \"UserFragment\" cannot be spread here as objects of type \"User\" can never be of type \"Address\".",
+ "locations": [{
+ "line": 3,
+ "column": 5
+ }]
+ }]
+}
diff --git a/test/Feature/Holistic/fragment/inlineFragment/query.gql b/test/Feature/Holistic/fragment/inlineFragment/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/inlineFragment/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ ... on User {
+ name
+ }
+ }
+}
diff --git a/test/Feature/Holistic/fragment/inlineFragment/response.json b/test/Feature/Holistic/fragment/inlineFragment/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/inlineFragment/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "user": {
+ "name": "testName"
+ }
+ }
+}
diff --git a/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql b/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ ... on Address {
+ name
+ }
+ }
+}
diff --git a/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json b/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Fragment cannot be spread here as objects of type \"User\" can never be of type \"Address\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/fragment/loopingFragment/query.gql b/test/Feature/Holistic/fragment/loopingFragment/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/loopingFragment/query.gql
@@ -0,0 +1,22 @@
+{
+ user {
+ email
+ }
+}
+
+fragment A on User {
+ ...D
+ ...C
+}
+
+fragment B on User {
+ ...C
+}
+
+fragment C on User {
+ ...A
+}
+
+fragment D on User {
+ name
+}
diff --git a/test/Feature/Holistic/fragment/loopingFragment/response.json b/test/Feature/Holistic/fragment/loopingFragment/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/loopingFragment/response.json
@@ -0,0 +1,21 @@
+{
+ "errors": [
+ {
+ "message": "Cannot spread fragment \"A\" within itself via A,C,A.",
+ "locations": [
+ {
+ "line": 7,
+ "column": 1
+ },
+ {
+ "line": 9,
+ "column": 3
+ },
+ {
+ "line": 17,
+ "column": 3
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/fragment/unknownTargetType/query.gql b/test/Feature/Holistic/fragment/unknownTargetType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/unknownTargetType/query.gql
@@ -0,0 +1,9 @@
+{
+ user {
+ name
+ }
+}
+
+fragment Bo on XYZ {
+ name
+}
diff --git a/test/Feature/Holistic/fragment/unknownTargetType/response.json b/test/Feature/Holistic/fragment/unknownTargetType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/fragment/unknownTargetType/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Unknown type \"XYZ\".",
+ "locations": [
+ {
+ "line": 7,
+ "column": 0
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql b/test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Boolean") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json b/test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json
@@ -0,0 +1,13 @@
+{
+ "data": {
+ "__type": {
+ "kind": "SCALAR",
+ "name": "Boolean",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Float/query.gql b/test/Feature/Holistic/introspection/defaultTypes/Float/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Float/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Float") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Float/response.json b/test/Feature/Holistic/introspection/defaultTypes/Float/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Float/response.json
@@ -0,0 +1,5 @@
+{
+ "data": {
+ "__type": null
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/ID/query.gql b/test/Feature/Holistic/introspection/defaultTypes/ID/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/ID/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "ID") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/ID/response.json b/test/Feature/Holistic/introspection/defaultTypes/ID/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/ID/response.json
@@ -0,0 +1,13 @@
+{
+ "data": {
+ "__type": {
+ "kind": "SCALAR",
+ "name": "ID",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Int/query.gql b/test/Feature/Holistic/introspection/defaultTypes/Int/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Int/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Int") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/Int/response.json b/test/Feature/Holistic/introspection/defaultTypes/Int/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/Int/response.json
@@ -0,0 +1,13 @@
+{
+ "data": {
+ "__type": {
+ "kind": "SCALAR",
+ "name": "Int",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/String/query.gql b/test/Feature/Holistic/introspection/defaultTypes/String/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/String/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "String") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/defaultTypes/String/response.json b/test/Feature/Holistic/introspection/defaultTypes/String/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/defaultTypes/String/response.json
@@ -0,0 +1,13 @@
+{
+ "data": {
+ "__type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/ENUM/query.gql b/test/Feature/Holistic/introspection/kinds/ENUM/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/ENUM/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "TestEnum") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/ENUM/response.json b/test/Feature/Holistic/introspection/kinds/ENUM/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/ENUM/response.json
@@ -0,0 +1,29 @@
+{
+ "data": {
+ "__type": {
+ "kind": "ENUM",
+ "name": "TestEnum",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": [
+ {
+ "name": "EnumA",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "EnumB",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "EnumC",
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql b/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "TestInputObject") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json b/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json
@@ -0,0 +1,44 @@
+{
+ "data": {
+ "__type": {
+ "kind": "INPUT_OBJECT",
+ "name": "TestInputObject",
+ "fields": null,
+ "inputFields": [
+ {
+ "name": "fieldTestScalar",
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "TestScalar",
+ "ofType": null
+ }
+ },
+ "defaultValue": null
+ },
+ {
+ "name": "fieldNestedInputObject",
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "INPUT_OBJECT",
+ "name": "NestedInputObject",
+ "ofType": null
+ }
+ }
+ },
+ "defaultValue": null
+ }
+ ],
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/OBJECT/query.gql b/test/Feature/Holistic/introspection/kinds/OBJECT/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/OBJECT/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Address") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/OBJECT/response.json b/test/Feature/Holistic/introspection/kinds/OBJECT/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/OBJECT/response.json
@@ -0,0 +1,105 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "Address",
+ "fields": [
+ {
+ "name": "city",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "street",
+ "args": [
+ {
+ "name": "argInputObject",
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "INPUT_OBJECT",
+ "name": "TestInputObject",
+ "ofType": null
+ }
+ },
+ "defaultValue": null
+ },
+ {
+ "name": "argMaybeString",
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "defaultValue": null
+ }
+ ],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String"
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "houseNumber",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "Int",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/SCALAR/query.gql b/test/Feature/Holistic/introspection/kinds/SCALAR/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/SCALAR/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "TestScalar") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/SCALAR/response.json b/test/Feature/Holistic/introspection/kinds/SCALAR/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/SCALAR/response.json
@@ -0,0 +1,13 @@
+{
+ "data": {
+ "__type": {
+ "kind": "SCALAR",
+ "name": "TestScalar",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/UNION/query.gql b/test/Feature/Holistic/introspection/kinds/UNION/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/UNION/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "TestUnion") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/kinds/UNION/response.json b/test/Feature/Holistic/introspection/kinds/UNION/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/kinds/UNION/response.json
@@ -0,0 +1,24 @@
+{
+ "data": {
+ "__type": {
+ "kind": "UNION",
+ "name": "TestUnion",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": null,
+ "possibleTypes": [
+ {
+ "kind": "OBJECT",
+ "name": "User",
+ "ofType": null
+ },
+ {
+ "kind": "OBJECT",
+ "name": "Address",
+ "ofType": null
+ }
+ ]
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__Directive") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Directive/response.json b/test/Feature/Holistic/introspection/schemaTypes/__Directive/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Directive/response.json
@@ -0,0 +1,86 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__Directive",
+ "fields": [
+ {
+ "name": "name",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "description",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "locations",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "ENUM",
+ "name": "__DirectiveLocation",
+ "ofType": null
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "args",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__InputValue",
+ "ofType": null
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__DirectiveLocation") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json b/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json
@@ -0,0 +1,109 @@
+{
+ "data": {
+ "__type": {
+ "kind": "ENUM",
+ "name": "__DirectiveLocation",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": [
+ {
+ "name": "QUERY",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "MUTATION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "SUBSCRIPTION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "FIELD",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "FRAGMENT_DEFINITION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "FRAGMENT_SPREAD",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INLINE_FRAGMENT",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "VARIABLE_DEFINITION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "SCHEMA",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "SCALAR",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "OBJECT",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "FIELD_DEFINITION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "ARGUMENT_DEFINITION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INTERFACE",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "UNION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "ENUM",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "ENUM_VALUE",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INPUT_OBJECT",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INPUT_FIELD_DEFINITION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__EnumValue") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/response.json b/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__EnumValue/response.json
@@ -0,0 +1,66 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__EnumValue",
+ "fields": [
+ {
+ "name": "name",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "description",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "isDeprecated",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "Boolean",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "deprecationReason",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__Field") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Field/response.json b/test/Feature/Holistic/introspection/schemaTypes/__Field/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Field/response.json
@@ -0,0 +1,104 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__Field",
+ "fields": [
+ {
+ "name": "name",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "description",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "args",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__InputValue",
+ "ofType": null
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "type",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "isDeprecated",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "Boolean",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "deprecationReason",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__InputValue") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__InputValue/response.json b/test/Feature/Holistic/introspection/schemaTypes/__InputValue/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__InputValue/response.json
@@ -0,0 +1,66 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__InputValue",
+ "fields": [
+ {
+ "name": "name",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "description",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "type",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "defaultValue",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__Schema") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json b/test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json
@@ -0,0 +1,97 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__Schema",
+ "fields": [
+ {
+ "name": "types",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "queryType",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "mutationType",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "subscriptionType",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "directives",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Directive",
+ "ofType": null
+ }
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__Type") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__Type/response.json b/test/Feature/Holistic/introspection/schemaTypes/__Type/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__Type/response.json
@@ -0,0 +1,177 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "fields": [
+ {
+ "name": "kind",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "ENUM",
+ "name": "__TypeKind",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "name",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "description",
+ "args": [],
+ "type": {
+ "kind": "SCALAR",
+ "name": "String",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "fields",
+ "args": [
+ {
+ "name": "includeDeprecated",
+ "type": {
+ "kind": "SCALAR",
+ "name": "Boolean",
+ "ofType": null
+ },
+ "defaultValue": null
+ }
+ ],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Field",
+ "ofType": null
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "interfaces",
+ "args": [],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "possibleTypes",
+ "args": [],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "enumValues",
+ "args": [
+ {
+ "name": "includeDeprecated",
+ "type": {
+ "kind": "SCALAR",
+ "name": "Boolean",
+ "ofType": null
+ },
+ "defaultValue": null
+ }
+ ],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__EnumValue",
+ "ofType": null
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "inputFields",
+ "args": [],
+ "type": {
+ "kind": "LIST",
+ "name": null,
+ "ofType": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "__InputValue",
+ "ofType": null
+ }
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "ofType",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "__Type",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql b/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "__TypeKind") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json b/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json
@@ -0,0 +1,54 @@
+{
+ "data": {
+ "__type": {
+ "kind": "ENUM",
+ "name": "__TypeKind",
+ "fields": null,
+ "inputFields": null,
+ "interfaces": null,
+ "enumValues": [
+ {
+ "name": "SCALAR",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "OBJECT",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INTERFACE",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "UNION",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "ENUM",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "INPUT_OBJECT",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "LIST",
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "NON_NULL",
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/Holistic/parsing/complex/query.gql b/test/Feature/Holistic/parsing/complex/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/complex/query.gql
@@ -0,0 +1,55 @@
+query GetUsers($v: [[[ID!]]!]) {
+ bla: user {
+ name
+ }
+ user {
+ email2: email
+ name
+ address1: address(coordinates: {longitude: [null,[[], [{uid: "1"}]]] , latitude: "" }) {
+ street
+ }
+ address2: address(coordinates: {longitude: [], latitude: ""}) {
+ street: street
+ street2: street
+ }
+ office(zipCode: $v, cityID: HH) {
+ city
+ houseNumber
+ ... on Address {
+ street
+ }
+ owner {
+ name
+ }
+ }
+ home
+ un1: myUnion {
+ __typename
+ ...UInfo
+ ...AInfo
+ ...City
+ }
+ un2: myUnion {
+ __typename
+ ...UInfo
+ ...AInfo
+ ...City
+ }
+ }
+}
+
+fragment UInfo on User {
+ name
+ myUnion {
+ ...City
+ __typename
+ }
+}
+
+fragment City on Address {
+ city
+}
+
+fragment AInfo on Address {
+ street
+}
diff --git a/test/Feature/Holistic/parsing/complex/response.json b/test/Feature/Holistic/parsing/complex/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/complex/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Argument coordinates got invalid value ;on longitude Expected type \"Int\" found [null,[[],[{\"uid\":\"1\"}]]].",
+ "locations": [
+ {
+ "line": 8,
+ "column": 36
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/extraCommas/query.gql b/test/Feature/Holistic/parsing/extraCommas/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/extraCommas/query.gql
@@ -0,0 +1,24 @@
+{
+ user {name,,,address}
+
+ user {name, ,address}
+
+ user {name , address , }
+
+ user {
+ name,
+ address
+ }
+
+ user {
+ name,address
+ }
+
+ user {
+ name, address
+ }
+
+ user {
+ name ,address
+ }
+}
diff --git a/test/Feature/Holistic/parsing/extraCommas/response.json b/test/Feature/Holistic/parsing/extraCommas/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/extraCommas/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Required Argument: \"coordinates\" was not Defined",
+ "locations": [
+ {
+ "line": 2,
+ "column": 18
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/generousSpaces/query.gql b/test/Feature/Holistic/parsing/generousSpaces/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/generousSpaces/query.gql
@@ -0,0 +1,7 @@
+
+ query e1 ( $v1 : [ [ Int ! ] ] ) {
+
+ q1 {
+ a2 ( a : $v1 , b : 2 )
+ }
+ }
diff --git a/test/Feature/Holistic/parsing/generousSpaces/response.json b/test/Feature/Holistic/parsing/generousSpaces/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/generousSpaces/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Cannot query field \"q1\" on type \"Query\".",
+ "locations": [
+ {
+ "line": 4,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/invalidFields/query.gql b/test/Feature/Holistic/parsing/invalidFields/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/invalidFields/query.gql
@@ -0,0 +1,1 @@
+{ user { address { street< }}}
diff --git a/test/Feature/Holistic/parsing/invalidFields/response.json b/test/Feature/Holistic/parsing/invalidFields/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/invalidFields/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "offset=66:\nunexpected end of input\nexpecting '}', entry, or white space\n",
+ "locations": [
+ {
+ "line": 5,
+ "column": 1
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql b/test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql
@@ -0,0 +1,5 @@
+query q1($v1: [[[Int@]@]]@) {
+ q1 {
+ a2(argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json b/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "offset=20:\nunexpected '@'\nexpecting '!', ']', '_', digit, letter, or white space\n",
+ "locations": [
+ {
+ "line": 1,
+ "column": 21
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/missingCloseBrace/query.gql b/test/Feature/Holistic/parsing/missingCloseBrace/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/missingCloseBrace/query.gql
@@ -0,0 +1,4 @@
+query q1($v1: [[[Int!]!]]!) {
+ q1 {
+ a2(argNestedList: $v1)
+}
diff --git a/test/Feature/Holistic/parsing/missingCloseBrace/response.json b/test/Feature/Holistic/parsing/missingCloseBrace/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/missingCloseBrace/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "offset=66:\nunexpected end of input\nexpecting ',', '}', entry, or white space\n",
+ "locations": [
+ {
+ "line": 5,
+ "column": 1
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/notNullSpacing/query.gql b/test/Feature/Holistic/parsing/notNullSpacing/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/notNullSpacing/query.gql
@@ -0,0 +1,5 @@
+query q1($v1: [[[Int ! ] ! ]] ! ) {
+ q1 {
+ a2(argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/Holistic/parsing/notNullSpacing/response.json b/test/Feature/Holistic/parsing/notNullSpacing/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/notNullSpacing/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Cannot query field \"q1\" on type \"Query\".",
+ "locations": [
+ {
+ "line": 2,
+ "column": 6
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/parsing/notNullSpacing/variables.json b/test/Feature/Holistic/parsing/notNullSpacing/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/parsing/notNullSpacing/variables.json
@@ -0,0 +1,5 @@
+{
+ "v1": [
+ null
+ ]
+}
diff --git a/test/Feature/Holistic/selection/AliasNameConflict/query.gql b/test/Feature/Holistic/selection/AliasNameConflict/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasNameConflict/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ name: name
+ name: name
+ name: name
+ }
+}
diff --git a/test/Feature/Holistic/selection/AliasNameConflict/response.json b/test/Feature/Holistic/selection/AliasNameConflict/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasNameConflict/response.json
@@ -0,0 +1,22 @@
+{
+ "errors": [
+ {
+ "message": "duplicate selection of key \"name\" on type \"User\".",
+ "locations": [
+ {
+ "line": 4,
+ "column": 5
+ }
+ ]
+ },
+ {
+ "message": "duplicate selection of key \"name\" on type \"User\".",
+ "locations": [
+ {
+ "line": 5,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/selection/AliasResolve/query.gql b/test/Feature/Holistic/selection/AliasResolve/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasResolve/query.gql
@@ -0,0 +1,6 @@
+{
+ user {
+ name1: name
+ name2 : name
+ }
+}
diff --git a/test/Feature/Holistic/selection/AliasResolve/response.json b/test/Feature/Holistic/selection/AliasResolve/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasResolve/response.json
@@ -0,0 +1,8 @@
+{
+ "data": {
+ "user": {
+ "name1": "testName",
+ "name2": "testName"
+ }
+ }
+}
diff --git a/test/Feature/Holistic/selection/AliasUnknownField/query.gql b/test/Feature/Holistic/selection/AliasUnknownField/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasUnknownField/query.gql
@@ -0,0 +1,5 @@
+{
+ user {
+ myAlias: bla
+ }
+}
diff --git a/test/Feature/Holistic/selection/AliasUnknownField/response.json b/test/Feature/Holistic/selection/AliasUnknownField/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/AliasUnknownField/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Cannot query field \"bla\" on type \"User\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 14
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/selection/hasNoSubFields/query.gql b/test/Feature/Holistic/selection/hasNoSubFields/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/hasNoSubFields/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ name {
+ id
+ }
+ }
+}
diff --git a/test/Feature/Holistic/selection/hasNoSubFields/response.json b/test/Feature/Holistic/selection/hasNoSubFields/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/hasNoSubFields/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Field \"name\" must not have a selection since type \"String\" has no subfields.",
+ "locations": [
+ {
+ "line": 3,
+ "column": 10
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/selection/mustHaveSubFields/query.gql b/test/Feature/Holistic/selection/mustHaveSubFields/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/mustHaveSubFields/query.gql
@@ -0,0 +1,3 @@
+{
+ user
+}
diff --git a/test/Feature/Holistic/selection/mustHaveSubFields/response.json b/test/Feature/Holistic/selection/mustHaveSubFields/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/mustHaveSubFields/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Field \"user\" of type \"User\" must have a selection of subfields",
+ "locations": [
+ {
+ "line": 2,
+ "column": 3
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/selection/nameConflict/query.gql b/test/Feature/Holistic/selection/nameConflict/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/nameConflict/query.gql
@@ -0,0 +1,7 @@
+{
+ user {
+ name
+ name
+ name
+ }
+}
diff --git a/test/Feature/Holistic/selection/nameConflict/response.json b/test/Feature/Holistic/selection/nameConflict/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/nameConflict/response.json
@@ -0,0 +1,22 @@
+{
+ "errors": [
+ {
+ "message": "duplicate selection of key \"name\" on type \"User\".",
+ "locations": [
+ {
+ "line": 4,
+ "column": 5
+ }
+ ]
+ },
+ {
+ "message": "duplicate selection of key \"name\" on type \"User\".",
+ "locations": [
+ {
+ "line": 5,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Holistic/selection/unknownField/query.gql b/test/Feature/Holistic/selection/unknownField/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/unknownField/query.gql
@@ -0,0 +1,5 @@
+{
+ user {
+ bla
+ }
+}
diff --git a/test/Feature/Holistic/selection/unknownField/response.json b/test/Feature/Holistic/selection/unknownField/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Holistic/selection/unknownField/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Cannot query field \"bla\" on type \"User\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/API.hs b/test/Feature/InputType/API.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/API.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Feature.InputType.API
+ ( api
+ ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (GQLRootResolver (..), GQLType (..), ResM)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+type instance KIND A = OBJECT
+
+data F1Args = F1Args
+ { arg1 :: Text
+ , arg2 :: Maybe Int
+ } deriving (Generic)
+
+data F2Args = F2Args
+ { argList :: [Text]
+ , argNestedList :: [Maybe [[Int]]]
+ } deriving (Generic)
+
+data A = A
+ { a1 :: F1Args -> ResM Text
+ , a2 :: F2Args -> ResM Int
+ } deriving (Generic, GQLType)
+
+newtype Query = Query
+ { q1 :: A
+ } deriving (Generic)
+
+rootResolver :: GQLRootResolver IO Query () ()
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {q1 = A {a1 = const $ return "a1Test", a2 = const $ return 1}}
+ , mutationResolver = return ()
+ , subscriptionResolver = return ()
+ }
+
+api :: ByteString -> IO ByteString
+api = interpreter rootResolver
diff --git a/test/Feature/InputType/cases.json b/test/Feature/InputType/cases.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/cases.json
@@ -0,0 +1,66 @@
+[
+ {
+ "path": "variables/unusedVariable/unusedVariables",
+ "description": "fail when: variable is defined by the operation but did not used in selection"
+ },
+ {
+ "path": "variables/unusedVariable/variableUsedInFragment",
+ "description": "don't fail when: variable is defined by the operation and used in Fragment"
+ },
+ {
+ "path": "variables/unusedVariable/variableUsedInInlineFragment",
+ "description": "don't fail when: variable is defined by the operation and used in inline Fragment"
+ },
+ {
+ "path": "variables/unusedVariable/variableUsedInAlias",
+ "description": "don't fail when: variable is defined by the operation and used in Alias"
+ },
+ {
+ "path": "variables/valueNotProvided/nonNullVariable",
+ "description": "fail when: variable is defined by the operation but can't found on request body"
+ },
+ {
+ "path": "variables/nullableVariable",
+ "description": "don't fail when: variable is defined by the operation but can't found on request body"
+ },
+ {
+ "path": "variables/invalidValue/invalidListVariable",
+ "description": "fail when: variable receives invalid List value"
+ },
+ {
+ "path": "variables/invalidValue/nestedListNonNullListReceivedNull",
+ "description": "fail: if list of nonNull elements receives null"
+ },
+ {
+ "path": "variables/nestedListNullableListReceivedNull",
+ "description": "resolve: if list of nullable elements receives null"
+ },
+ {
+ "path": "variables/unknownType",
+ "description": "fail when: variable type does not exists"
+ },
+ {
+ "path": "variables/undefinedVariable",
+ "description": "fail when: referenced variable is not defined"
+ },
+ {
+ "path": "variables/incompatibleType/equalType",
+ "description": "equal types are valid"
+ },
+ {
+ "path": "variables/incompatibleType/stricterType",
+ "description": "stricter types are valid"
+ },
+ {
+ "path": "variables/incompatibleType/weakerType1",
+ "description": "weaker types are invalid"
+ },
+ {
+ "path": "variables/incompatibleType/weakerType2",
+ "description": "weaker types are invalid"
+ },
+ {
+ "path": "variables/incompatibleType/weakerType3",
+ "description": "weaker types are invalid"
+ }
+]
diff --git a/test/Feature/InputType/variables/incompatibleType/equalType/query.gql b/test/Feature/InputType/variables/incompatibleType/equalType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/equalType/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [[[Int!]!]]! ) {
+ q1 {
+ a2(argList: [],argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/equalType/response.json b/test/Feature/InputType/variables/incompatibleType/equalType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/equalType/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a2": 1
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/equalType/variables.json b/test/Feature/InputType/variables/incompatibleType/equalType/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/equalType/variables.json
@@ -0,0 +1,4 @@
+{
+ "v1": [
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/stricterType/query.gql b/test/Feature/InputType/variables/incompatibleType/stricterType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/stricterType/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [[[Int!]!]!]! ) {
+ q1 {
+ a2(argList: [],argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/stricterType/response.json b/test/Feature/InputType/variables/incompatibleType/stricterType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/stricterType/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a2": 1
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/stricterType/variables.json b/test/Feature/InputType/variables/incompatibleType/stricterType/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/stricterType/variables.json
@@ -0,0 +1,4 @@
+{
+ "v1": [
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql b/test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [[[Int]!]!]! ) {
+ q1 {
+ a2(argList: [],argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType1/response.json b/test/Feature/InputType/variables/incompatibleType/weakerType1/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType1/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v1\" of type \"[[[Int]!]!]!\" used in position expecting type \"[[[Int!]!]]!\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 35
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType1/variables.json b/test/Feature/InputType/variables/incompatibleType/weakerType1/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType1/variables.json
@@ -0,0 +1,4 @@
+{
+ "v1": [
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql b/test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [[[Int!]!]!] ) {
+ q1 {
+ a2(argList: [],argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType2/response.json b/test/Feature/InputType/variables/incompatibleType/weakerType2/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType2/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v1\" of type \"[[[Int!]!]!]\" used in position expecting type \"[[[Int!]!]]!\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 35
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType2/variables.json b/test/Feature/InputType/variables/incompatibleType/weakerType2/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType2/variables.json
@@ -0,0 +1,4 @@
+{
+ "v1": [
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql b/test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [[[Int!]]!]! ) {
+ q1 {
+ a2(argList: [],argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType3/response.json b/test/Feature/InputType/variables/incompatibleType/weakerType3/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType3/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v1\" of type \"[[[Int!]]!]!\" used in position expecting type \"[[[Int!]!]]!\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 35
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json b/test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json
@@ -0,0 +1,4 @@
+{
+ "v1": [
+ ]
+}
diff --git a/test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql b/test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [String!] ) {
+ q1 {
+ a2(argList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json b/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v1\" got invalid value; Expected type \"String\" found null.",
+ "locations": [
+ {
+ "line": 1,
+ "column": 27
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json b/test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json
@@ -0,0 +1,5 @@
+{
+ "v1": [
+ null
+ ]
+}
diff --git a/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql
@@ -0,0 +1,5 @@
+query NonNullListReceivedNull($v1: [[[Int!]!]]!) {
+ q1 {
+ a2(argNestedList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v1\" got invalid value; Expected type \"[Int!]\" found null.",
+ "locations": [
+ {
+ "line": 1,
+ "column": 31
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json
@@ -0,0 +1,11 @@
+{
+ "v1": [
+ [
+ [
+ 1
+ ],
+ null
+ ],
+ null
+ ]
+}
diff --git a/test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql
@@ -0,0 +1,5 @@
+query NullableListReceivedNull($v1: [[[Int!]!]]!) {
+ q1 {
+ a2(argNestedList: $v1, argList:[])
+ }
+}
diff --git a/test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a2": 1
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json
@@ -0,0 +1,10 @@
+{
+ "v1": [
+ [
+ [
+ 1
+ ]
+ ],
+ null
+ ]
+}
diff --git a/test/Feature/InputType/variables/nullableVariable/query.gql b/test/Feature/InputType/variables/nullableVariable/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/nullableVariable/query.gql
@@ -0,0 +1,5 @@
+query TestNullableVariable($i1: Int) {
+ q1 {
+ a1(arg1:"",arg2: $i1)
+ }
+}
diff --git a/test/Feature/InputType/variables/nullableVariable/response.json b/test/Feature/InputType/variables/nullableVariable/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/nullableVariable/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a1": "a1Test"
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/undefinedVariable/query.gql b/test/Feature/InputType/variables/undefinedVariable/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/undefinedVariable/query.gql
@@ -0,0 +1,5 @@
+query testUnknownType {
+ q1 {
+ a1(arg1:$bo)
+ }
+}
diff --git a/test/Feature/InputType/variables/undefinedVariable/response.json b/test/Feature/InputType/variables/undefinedVariable/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/undefinedVariable/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"bo\" is not defined by operation \"testUnknownType\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 15
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/unknownType/query.gql b/test/Feature/InputType/variables/unknownType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unknownType/query.gql
@@ -0,0 +1,5 @@
+query testUnknownType ($bo: BA ){
+ q1 {
+ a1(arg1:$bo)
+ }
+}
diff --git a/test/Feature/InputType/variables/unknownType/response.json b/test/Feature/InputType/variables/unknownType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unknownType/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Unknown type \"BA\".",
+ "locations": [
+ {
+ "line": 1,
+ "column": 24
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql b/test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql
@@ -0,0 +1,5 @@
+query TestUnusedVariables ($v1: String, $v2: String, $v3: Int) {
+ q1 {
+ a1(arg1: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json b/test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json
@@ -0,0 +1,22 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$v2\" is never used in operation \"TestUnusedVariables\".",
+ "locations": [
+ {
+ "line": 1,
+ "column": 41
+ }
+ ]
+ },
+ {
+ "message": "Variable \"$v3\" is never used in operation \"TestUnusedVariables\".",
+ "locations": [
+ {
+ "line": 1,
+ "column": 54
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql
@@ -0,0 +1,5 @@
+query TestUsedVariable ($v1: String!) {
+ q1 {
+ x1: a1(arg1: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/response.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "x1": "a1Test"
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/variables.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/variables.json
@@ -0,0 +1,3 @@
+{
+ "v1": ""
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql
@@ -0,0 +1,9 @@
+query TestUsedVariable ($v1: String!) {
+ q1 {
+ ...F1
+ }
+}
+
+fragment F1 on A {
+ a1(arg1: $v1)
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/response.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a1": "a1Test"
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/variables.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/variables.json
@@ -0,0 +1,3 @@
+{
+ "v1": ""
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql
@@ -0,0 +1,7 @@
+query TestUsedVariable ($v1: String!) {
+ q1 {
+ ...on A {
+ a1(arg1: $v1)
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/response.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a1": "a1Test"
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/variables.json b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/variables.json
@@ -0,0 +1,3 @@
+{
+ "v1": ""
+}
diff --git a/test/Feature/InputType/variables/validListVariable/query.gql b/test/Feature/InputType/variables/validListVariable/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/validListVariable/query.gql
@@ -0,0 +1,5 @@
+query invalidListVariable($v1: [String!]! ) {
+ q1 {
+ a2(argList: $v1)
+ }
+}
diff --git a/test/Feature/InputType/variables/validListVariable/response.json b/test/Feature/InputType/variables/validListVariable/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/validListVariable/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "q1": {
+ "a2": 1
+ }
+ }
+}
diff --git a/test/Feature/InputType/variables/validListVariable/variables.json b/test/Feature/InputType/variables/validListVariable/variables.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/validListVariable/variables.json
@@ -0,0 +1,5 @@
+{
+ "v1": [
+ "a"
+ ]
+}
diff --git a/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql b/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql
@@ -0,0 +1,5 @@
+query TestNonNullVariable($i1: String!) {
+ q1 {
+ a1(arg1: $i1)
+ }
+}
diff --git a/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json b/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Variable \"$i1\" of required type \"String!\" was not provided.",
+ "locations": [
+ {
+ "line": 1,
+ "column": 27
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/Schema/A2.hs b/test/Feature/Schema/A2.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/Schema/A2.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Feature.Schema.A2
+ ( A(..)
+ ) where
+
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (GQLType (..))
+import GHC.Generics (Generic)
+
+type instance KIND A = OBJECT
+
+newtype A = A
+ { bla :: Int
+ } deriving (Generic, GQLType)
diff --git a/test/Feature/Schema/API.hs b/test/Feature/Schema/API.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/Schema/API.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Feature.Schema.API
+ ( api
+ ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (GQLRootResolver (..), GQLType (..))
+import Data.Text (Text)
+import qualified Feature.Schema.A2 as A2 (A (..))
+import GHC.Generics (Generic)
+
+type instance KIND A = OBJECT
+
+data A = A
+ { aText :: Text
+ , aInt :: Int
+ } deriving (Generic, GQLType)
+
+data Query = Query
+ { a1 :: A
+ , a2 :: A2.A
+ } deriving (Generic)
+
+rootResolver :: GQLRootResolver IO Query () ()
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {a1 = A "" 0, a2 = A2.A 0}
+ , mutationResolver = return ()
+ , subscriptionResolver = return ()
+ }
+
+api :: ByteString -> IO ByteString
+api = interpreter rootResolver
diff --git a/test/Feature/Schema/cases.json b/test/Feature/Schema/cases.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Schema/cases.json
@@ -0,0 +1,6 @@
+[
+ {
+ "path": "nameCollision",
+ "description": "fail: if types are defined with same name"
+ }
+]
diff --git a/test/Feature/Schema/nameCollision/query.gql b/test/Feature/Schema/nameCollision/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/Schema/nameCollision/query.gql
@@ -0,0 +1,3 @@
+{
+ name
+}
diff --git a/test/Feature/Schema/nameCollision/response.json b/test/Feature/Schema/nameCollision/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/Schema/nameCollision/response.json
@@ -0,0 +1,9 @@
+{
+ "errors": [
+ {
+ "message": "Schema Validation Error, Name collision: \"A\" is used for different dataTypes in two separate modules",
+ "locations": [
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/UnionType/API.hs b/test/Feature/UnionType/API.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/API.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Feature.UnionType.API
+ ( api
+ ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Kind (KIND, OBJECT, UNION)
+import Data.Morpheus.Types (GQLRootResolver (..), GQLType (..), ResM)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+type instance KIND A = OBJECT
+
+type instance KIND B = OBJECT
+
+type instance KIND C = OBJECT
+
+type instance KIND AOrB = UNION
+
+data A = A
+ { aText :: Text
+ , aInt :: Int
+ } deriving (Generic, GQLType)
+
+data B = B
+ { bText :: Text
+ , bInt :: Int
+ } deriving (Generic, GQLType)
+
+data C = C
+ { cText :: Text
+ , cInt :: Int
+ } deriving (Generic, GQLType)
+
+data AOrB
+ = A' A
+ | B' B
+ deriving (Generic, GQLType)
+
+data Query = Query
+ { union :: () -> ResM [AOrB]
+ , fc :: C
+ } deriving (Generic)
+
+resolveUnion :: () -> ResM [AOrB]
+resolveUnion _ = return [A' A {aText = "at", aInt = 1}, B' B {bText = "bt", bInt = 2}]
+
+rootResolver :: GQLRootResolver IO Query () ()
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {union = resolveUnion, fc = C {cText = "", cInt = 3}}
+ , mutationResolver = return ()
+ , subscriptionResolver = return ()
+ }
+
+api :: ByteString -> IO ByteString
+api = interpreter rootResolver
diff --git a/test/Feature/UnionType/cannotBeSpreadOnType/query.gql b/test/Feature/UnionType/cannotBeSpreadOnType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/cannotBeSpreadOnType/query.gql
@@ -0,0 +1,9 @@
+{
+ union {
+ ...FC
+ }
+}
+
+fragment FC on C {
+ aText
+}
diff --git a/test/Feature/UnionType/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/cannotBeSpreadOnType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/cannotBeSpreadOnType/response.json
@@ -0,0 +1,9 @@
+{
+ "errors": [{
+ "message": "Fragment \"FC\" cannot be spread here as objects of type \"AB\" can never be of type \"C\".",
+ "locations": [{
+ "line": 3,
+ "column": 5
+ }]
+ }]
+}
diff --git a/test/Feature/UnionType/cases.json b/test/Feature/UnionType/cases.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/cases.json
@@ -0,0 +1,26 @@
+[
+ {
+ "path": "fragmentOnAAndB",
+ "description": "returns field __typename and fields by Fragment Type "
+ },
+ {
+ "path": "fragmentOnlyOnA",
+ "description": "returns empty object {}, when there is no any fragment for Type this Type"
+ },
+ {
+ "path": "cannotBeSpreadOnType",
+ "description": "Fail when: there is fragment with incompatible type"
+ },
+ {
+ "path": "selectionWithoutFragmentNotAllowed",
+ "description": "Fail when: user tries to directly select field without any Fragment"
+ },
+ {
+ "path": "inlineFragment/fragmentOnAAndB",
+ "description": "returns field __typename and fields by InlineFragment Type "
+ },
+ {
+ "path": "inlineFragment/cannotBeSpreadOnType",
+ "description": "Fail when: there is inlineFragment with incompatible type"
+ }
+]
diff --git a/test/Feature/UnionType/fragmentOnAAndB/query.gql b/test/Feature/UnionType/fragmentOnAAndB/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/fragmentOnAAndB/query.gql
@@ -0,0 +1,15 @@
+{
+ union {
+ __typename
+ ...FA
+ ...FB
+ }
+}
+
+fragment FA on A {
+ aText
+}
+
+fragment FB on B {
+ bText
+}
diff --git a/test/Feature/UnionType/fragmentOnAAndB/response.json b/test/Feature/UnionType/fragmentOnAAndB/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/fragmentOnAAndB/response.json
@@ -0,0 +1,14 @@
+{
+ "data": {
+ "union": [
+ {
+ "__typename": "A",
+ "aText": "at"
+ },
+ {
+ "__typename": "B",
+ "bText": "bt"
+ }
+ ]
+ }
+}
diff --git a/test/Feature/UnionType/fragmentOnlyOnA/query.gql b/test/Feature/UnionType/fragmentOnlyOnA/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/fragmentOnlyOnA/query.gql
@@ -0,0 +1,9 @@
+{
+ union {
+ ...FA
+ }
+}
+
+fragment FA on A {
+ aText
+}
diff --git a/test/Feature/UnionType/fragmentOnlyOnA/response.json b/test/Feature/UnionType/fragmentOnlyOnA/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/fragmentOnlyOnA/response.json
@@ -0,0 +1,11 @@
+{
+ "data": {
+ "union": [
+ {
+ "aText": "at"
+ },
+ {
+ }
+ ]
+ }
+}
diff --git a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql
@@ -0,0 +1,7 @@
+{
+ union {
+ ... on C {
+ aText
+ }
+ }
+}
diff --git a/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Fragment cannot be spread here as objects of type \"AB\" can never be of type \"C\".",
+ "locations": [
+ {
+ "line": 3,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql b/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql
@@ -0,0 +1,11 @@
+{
+ union {
+ __typename
+ ... on A {
+ aText
+ }
+ ... on B {
+ bText
+ }
+ }
+}
diff --git a/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/response.json b/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/inlineFragment/fragmentOnAAndB/response.json
@@ -0,0 +1,14 @@
+{
+ "data": {
+ "union": [
+ {
+ "__typename": "A",
+ "aText": "at"
+ },
+ {
+ "__typename": "B",
+ "bText": "bt"
+ }
+ ]
+ }
+}
diff --git a/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql
@@ -0,0 +1,10 @@
+{
+ union {
+ ...FA
+ aText
+ }
+}
+
+fragment FA on A {
+ aText
+}
diff --git a/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json
@@ -0,0 +1,13 @@
+{
+ "errors": [
+ {
+ "message": "Cannot query field \"aText\" on type \"Query\".",
+ "locations": [
+ {
+ "line": 4,
+ "column": 5
+ }
+ ]
+ }
+ ]
+}
diff --git a/test/Feature/WrappedTypeName/API.hs b/test/Feature/WrappedTypeName/API.hs
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/API.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Feature.WrappedTypeName.API
+ ( api
+ ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Morpheus (interpreter)
+import Data.Morpheus.Kind (KIND, OBJECT)
+import Data.Morpheus.Types (EffectM, GQLRootResolver (..), GQLType (..), ResM)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+type instance KIND (WA a) = OBJECT
+
+type instance KIND (Wrapped a b) = OBJECT
+
+data Wrapped a b = Wrapped
+ { fieldA :: a
+ , fieldB :: b
+ } deriving (Generic, GQLType)
+
+data WA m = WA
+ { aText :: () -> m Text
+ , aInt :: Int
+ } deriving (Generic, GQLType)
+
+data Query = Query
+ { a1 :: WA ResM
+ , a2 :: Maybe (Wrapped Int Int)
+ , a3 :: Maybe (Wrapped (Wrapped Text Int) Text)
+ } deriving (Generic)
+
+data Mutation = Mutation
+ { mut1 :: Maybe (WA EffectM)
+ , mut2 :: Maybe (Wrapped Int Int)
+ , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text)
+ } deriving (Generic)
+
+data Subscription = Subscription
+ { sub1 :: Maybe (WA EffectM)
+ , sub2 :: Maybe (Wrapped Int Int)
+ , sub3 :: Maybe (Wrapped (Wrapped Text Int) Text)
+ } deriving (Generic)
+
+rootResolver :: GQLRootResolver IO Query Mutation Subscription
+rootResolver =
+ GQLRootResolver
+ { queryResolver = return Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing}
+ , mutationResolver = return Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing}
+ , subscriptionResolver = return Subscription {sub1 = Nothing, sub2 = Nothing, sub3 = Nothing}
+ }
+
+api :: ByteString -> IO ByteString
+api = interpreter rootResolver
diff --git a/test/Feature/WrappedTypeName/cases.json b/test/Feature/WrappedTypeName/cases.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/cases.json
@@ -0,0 +1,18 @@
+[
+ {
+ "path": "validWrappedTypes",
+ "description": "don't fail: if Mutation, Query, or Subscription Resolver is packed inside GQLType"
+ },
+ {
+ "path": "ignoreQueryResolver",
+ "description": "ignore Query Resolver monad from typeName, but concatenates other wrapped types with _"
+ },
+ {
+ "path": "ignoreMutationResolver",
+ "description": "ignore Mutation Resolver monad from typeName, but concatenates other wrapped types with _"
+ },
+ {
+ "path": "ignoreSubscriptionResolver",
+ "description": "ignore Subscription Resolver monad from typeName, but concatenates other wrapped types with _"
+ }
+]
diff --git a/test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql b/test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Mutation") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/ignoreMutationResolver/response.json b/test/Feature/WrappedTypeName/ignoreMutationResolver/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreMutationResolver/response.json
@@ -0,0 +1,47 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "Mutation",
+ "fields": [
+ {
+ "name": "mut1",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "WA",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "mut2",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Int_Int",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "mut3",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Wrapped_Text_Int_Text",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql b/test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Query") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/ignoreQueryResolver/response.json b/test/Feature/WrappedTypeName/ignoreQueryResolver/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreQueryResolver/response.json
@@ -0,0 +1,51 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "Query",
+ "fields": [
+ {
+ "name": "a1",
+ "args": [],
+ "type": {
+ "kind": "NON_NULL",
+ "name": null,
+ "ofType": {
+ "kind": "OBJECT",
+ "name": "WA",
+ "ofType": null
+ }
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "a2",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Int_Int",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "a3",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Wrapped_Text_Int_Text",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql b/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql
@@ -0,0 +1,76 @@
+query Get__Type {
+ __type(name: "Subscription") {
+ ...FullType
+ }
+}
+
+fragment FullType on __Type {
+ kind
+ name
+ fields(includeDeprecated: true) {
+ name
+ args {
+ ...InputValue
+ }
+ type {
+ ...TypeRef
+ }
+ isDeprecated
+ deprecationReason
+ }
+ inputFields {
+ ...InputValue
+ }
+ interfaces {
+ ...TypeRef
+ }
+ enumValues(includeDeprecated: true) {
+ name
+ isDeprecated
+ deprecationReason
+ }
+ possibleTypes {
+ ...TypeRef
+ }
+}
+
+fragment InputValue on __InputValue {
+ name
+ type {
+ ...TypeRef
+ }
+ defaultValue
+}
+
+fragment TypeRef on __Type {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ ofType {
+ kind
+ name
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json b/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json
@@ -0,0 +1,47 @@
+{
+ "data": {
+ "__type": {
+ "kind": "OBJECT",
+ "name": "Subscription",
+ "fields": [
+ {
+ "name": "sub1",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "WA",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "sub2",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Int_Int",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ },
+ {
+ "name": "sub3",
+ "args": [],
+ "type": {
+ "kind": "OBJECT",
+ "name": "Wrapped_Wrapped_Text_Int_Text",
+ "ofType": null
+ },
+ "isDeprecated": false,
+ "deprecationReason": null
+ }
+ ],
+ "inputFields": null,
+ "interfaces": [],
+ "enumValues": null,
+ "possibleTypes": null
+ }
+ }
+}
diff --git a/test/Feature/WrappedTypeName/validWrappedTypes/query.gql b/test/Feature/WrappedTypeName/validWrappedTypes/query.gql
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/validWrappedTypes/query.gql
@@ -0,0 +1,5 @@
+{
+ a1 {
+ aText
+ }
+}
diff --git a/test/Feature/WrappedTypeName/validWrappedTypes/response.json b/test/Feature/WrappedTypeName/validWrappedTypes/response.json
new file mode 100644
--- /dev/null
+++ b/test/Feature/WrappedTypeName/validWrappedTypes/response.json
@@ -0,0 +1,7 @@
+{
+ "data": {
+ "a1": {
+ "aText": "test1"
+ }
+ }
+}
diff --git a/test/Lib.hs b/test/Lib.hs
new file mode 100644
--- /dev/null
+++ b/test/Lib.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Lib
+ ( getGQLBody
+ , getResponseBody
+ , getCases
+ , maybeVariables
+ ) where
+
+import Control.Applicative ((<|>))
+import Data.Aeson (FromJSON, Value (..), decode)
+import qualified Data.ByteString.Lazy as L (readFile)
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text, unpack)
+
+path :: Text -> String
+path name = "test/" ++ unpack name
+
+gqlLib :: Text -> String
+gqlLib x = path x ++ "/query.gql"
+
+resLib :: Text -> String
+resLib x = path x ++ "/response.json"
+
+maybeVariables :: Text -> IO ByteString
+maybeVariables x = L.readFile (path x ++ "/variables.json") <|> return "{}"
+
+getGQLBody :: Text -> IO ByteString
+getGQLBody p = L.readFile (gqlLib p)
+
+getCases :: FromJSON a => String -> IO [a]
+getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" ++ dir ++ "/cases.json")
+
+getResponseBody :: Text -> IO Value
+getResponseBody p = fromMaybe Null . decode <$> L.readFile (resLib p)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main
+ ( main
+ ) where
+
+import qualified Feature.Holistic.API as Holistic (api)
+import qualified Feature.InputType.API as InputType (api)
+import qualified Feature.Schema.API as Schema (api)
+import qualified Feature.UnionType.API as UnionType (api)
+import qualified Feature.WrappedTypeName.API as TypeName (api)
+import Test.Tasty (defaultMain, testGroup)
+import TestFeature (testFeature)
+
+main :: IO ()
+main = do
+ ioTests <- testFeature Holistic.api "Feature/Holistic"
+ unionTest <- testFeature UnionType.api "Feature/UnionType"
+ inputTest <- testFeature InputType.api "Feature/InputType"
+ schemaTest <- testFeature Schema.api "Feature/Schema"
+ typeName <- testFeature TypeName.api "Feature/WrappedTypeName"
+ defaultMain (testGroup "Morpheus Graphql Tests" [ioTests, unionTest, inputTest, schemaTest, typeName])
diff --git a/test/TestFeature.hs b/test/TestFeature.hs
new file mode 100644
--- /dev/null
+++ b/test/TestFeature.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module TestFeature
+ ( testFeature
+ ) where
+
+import Data.Aeson (FromJSON, decode, encode)
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB (concat, pack, unpack)
+import Data.Semigroup ((<>))
+import Data.Text (Text, unpack)
+import qualified Data.Text as T (concat)
+import GHC.Generics
+import Lib (getCases, getGQLBody, getResponseBody, maybeVariables)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertFailure, testCase)
+
+packGQLRequest :: ByteString -> ByteString -> ByteString
+packGQLRequest x variables' = LB.concat ["{\"query\":", LB.pack $ show x, ",\"variables\":", variables', "}"]
+
+data Case = Case
+ { path :: Text
+ , description :: String
+ } deriving (Generic, FromJSON)
+
+testFeature :: (ByteString -> IO ByteString) -> Text -> IO TestTree
+testFeature api' dir' = do
+ cases' <- getCases (unpack dir')
+ test' <- sequence $ testByFiles api' <$> map (\x -> x {path = T.concat [dir', "/", path x]}) cases'
+ return $ testGroup (unpack dir') test'
+
+testByFiles :: (ByteString -> IO ByteString) -> Case -> IO TestTree
+testByFiles testApi (Case path' description') = do
+ testCaseQuery <- getGQLBody path'
+ testCaseVariables <- maybeVariables path'
+ expectedValue <- getResponseBody path'
+ gqlResponse <- testApi $ packGQLRequest testCaseQuery testCaseVariables
+ case decode gqlResponse of
+ Nothing -> assertFailure "Bad Response"
+ Just response -> return $ testCase (unpack path' ++ " | " ++ description') $ customTest expectedValue response
+ where customTest expected value =
+ if expected == value
+ then return ()
+ else assertFailure generateError
+ where
+ generateError = LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> gqlResponse