packages feed

morpheus-graphql 0.2.1 → 0.2.2

raw patch · 57 files changed

+1786/−1153 lines, 57 files

Files

+ README.md view
@@ -0,0 +1,404 @@+# Morpheus GraphQL [![Hackage](https://img.shields.io/hackage/v/morpheus-graphql.svg)](https://hackage.haskell.org/package/morpheus-graphql) [![Build Status](https://api.travis-ci.com/morpheusgraphql/morpheus-graphql.svg?branch=master)](https://travis-ci.com/morpheusgraphql/morpheus-graphql)++Build GraphQL APIs with your favourite functional language!++Morpheus GraphQL (Server & Client) helps you to build GraphQL APIs in Haskell with native haskell types.+Morpheus will convert your haskell types to a GraphQL schema and all your resolvers are just native Haskell functions. Mopheus GraphQL can also convert your GraphQL Schema or Query to Haskell types and validate them in compile time.++Morpheus is still in an early stage of development, so any feedback is more than welcome, and we appreciate any contribution!+Just open an issue here on GitHub, or join [our Slack channel](https://morpheus-graphql-slack-invite.herokuapp.com/) to get in touch.++## Getting Started++### Setup++To get started with Morpheus, you first need to add it to your project's dependencies, as follows (assuming you're using hpack):++package.yml++```yaml+dependencies:+  - morpheus-graphql+```++Additionally, you should tell stack which version to pick:++stack.yml++```yaml+resolver: lts-12.0 # or greater+extra-deps:+  - megaparsec-7.0.5+  - aeson-1.4.4.0+  - time-compat-1.9.2.2+  - morpheus-graphql-0.2.2+```++As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack update`++### Building your first GrqphQL API++### with GraphQL syntax and Haskell QuasiQuotes++```haskell++[gqlDocument|+  type Query {+    deity (uid: Text!): Deity!+  }++  type Deity {+    name  : Text!+    power : Text+  }+|]++rootResolver :: GQLRootResolver IO () () Query () ()+rootResolver =+  GQLRootResolver {queryResolver = return Query {deity}, mutationResolver = pure (), subscriptionResolver = pure ()}+  where+    deity DeityArgs {uid} = pure Deity {name, power}+      where+        name _ = pure "Morpheus"+        power _ = pure (Just "Shapeshifting")++gqlApi :: ByteString -> IO ByteString+gqlApi = interpreter rootResolver+```++Template Haskell Generates types: `Query` , `Deity`, `DeityArgs`, that can be used by `rootResolver`++generated types are not compatible with `Mutation`, `Subscription`,+they can be used only in `Query`, but this issue will be fixed in next release++### with Native Haskell Types++To define a GraphQL API with Morpheus we start by defining the API Schema as a native Haskell data type,+which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> IORes b`, representing resolving a set of arguments `a` to a concrete value `b`.++```haskell+data Query = Query+  { deity :: DeityArgs -> IORes Deity+  } deriving (Generic)++data Deity = Deity+  { fullName :: Text         -- Non-Nullable Field+  , power    :: Maybe Text   -- Nullable Field+  } deriving (Generic)++instance GQLType Deity where+  type  KIND Deity = OBJECT++data DeityArgs = DeityArgs+  { name      :: Text        -- Required Argument+  , mythology :: Maybe Text  -- Optional Argument+  } deriving (Generic)+```++For each field in the `Query` type defined via `a -> IORes b` (like `deity`) we will define a resolver implementation that provides the values during runtime by referring to+some data source, e.g. a database or another API. Fields that are defined without `a -> IORes b` you can just provide a value.++In above example, the field of `DeityArgs` could also be named using reserved identities (such as: `type`, `where`, etc), in order to avoid conflict, a prime symbol (`'`) must be attached. For example, you can have:++```haskell+data DeityArgs = DeityArgs+  { name      :: Text        -- Required Argument+  , mythology :: Maybe Text  -- Optional Argument+  , type'     :: Text+  } deriving (Generic)+```++The field name in the final request will be `type` instead of `type'`. The Morpheus request parser converts each of the reserved identities in Haskell 2010 to their corresponding names internally. This also applies to selections.++```haskell+resolveDeity :: DeityArgs -> IORes Deity+resolveDeity args = gqlResolver $ askDB (name args) (mythology args)++askDB :: Text -> Maybe Text -> IO (Either String Deity)+askDB = ...+```++Note that the type `a -> IORes b` is just Synonym for `a -> ExceptT String IO b`++To make this `Query` type available as an API, we define a `GQLRootResolver` and feed it to the Morpheus `interpreter`. A `GQLRootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example:++```haskell+rootResolver :: GQLRootResolver IO () () Query () ()+rootResolver =+  GQLRootResolver+    { queryResolver = return Query {deity = resolveDeity}+    , mutationResolver = return ()+    , subscriptionResolver = return ()+    }++gqlApi :: ByteString -> IO ByteString+gqlApi = interpreter rootResolver+```++As you can see, the API is defined as `ByteString -> IO ByteString` which we can either invoke directly or use inside an arbitrary web framework+such as `scotty` or `serverless-haskell`. We'll go for `scotty` in this example:++```haskell+main :: IO ()+main = scotty 3000 $ post "/api" $ raw =<< (liftIO . gqlApi =<< body)+```++If we now send a POST request to `http://localhost:3000/api` with a GraphQL Query as body for example in a tool like `Insomnia`:++```GraphQL+query GetDeity {+  deity (name: "Morpheus") {+    fullName+    power+  }+}+```++our query will be resolved!++```JSON+{+  "data": {+    "deity": {+      "fullName": "Morpheus",+      "power": "Shapeshifting"+    }+  }+}+```++## Serverless Example++If you are interested in creating a `Morpheus GraphQL` API with `Serverless`, you should take a look at our example in this repository:+[_Mythology API_](https://github.com/morpheusgraphql/mythology-api) it is our example project build with `Morpheus GraphQL` and `Serverless-Haskell`,+where you can query different mythology characters with `GraphiQL`.++Mythology API is deployed on : [_api.morpheusgraphql.com_](https://api.morpheusgraphql.com) where you can test it with `GraphiQL`++![Mythology Api](./assets/img/mythology-api.png "mythology-api")++## Advanced topics++### Enums++You can use Union Types as Enums, but they're not allowed to have any parameters.++```haskell+data City+  = Athens+  | Sparta+  | Corinth+  | Delphi+  | Argos+  deriving (Generic)++instance GQLType City where+  type KIND City = ENUM+```++### Union types++To use union type, all you have to do is derive the `GQLType` class. Using GraphQL [_fragments_](https://graphql.org/learn/queries/#fragments), the arguments of each data constructor can be accessed from the GraphQL client.++```haskell+data Character+  = DEITY Deity+  | HUMAN Human+  deriving (Generic)++instance GQLType Character where+  type KIND City = UNION+```++### Scalar types++To use custom scalar types, you need to provide implementations for `parseValue` and `serialize` respectively.++```haskell+data Odd = Odd Int  deriving (Generic)++instance GQLScalar Odd where+  parseValue (Int x) = pure $ Odd (...  )+  parseValue (String x) = pure $ Odd (...  )+  serialize  (Odd value) = Int value++instance GQLType Odd where+  type KIND Odd = SCALAR+```++### Applicative and Monad instance++The `Resolver` type has `Applicative` and `Monad` instances that can be used to compose resolvers.++### Introspection++Morpheus converts your schema to a GraphQL introspection automatically. You can use tools like `Insomnia` to take a+look at the introspection and validate your schema.+If you need a description for your GQLType inside of the introspection you can define the GQLType instance manually+and provide an implementation for the `description` function:++```haskell+data Deity = Deity+{ ...+} deriving (Generic)++instance GQLType Deity where+  description = const "A supernatural being considered divine and sacred"+```++screenshots from `Insomnia`++![alt text](./assets/img/introspection/spelling.png "spelling")+![alt text](./assets/img/introspection/autocomplete.png "autocomplete")+![alt text](./assets/img/introspection/type.png "type")++### Mutations++In addition to queries, Morpheus also supports mutations. The behave just like regular queries and are defined similarly:+Just exchange deriving `GQLQuery` for `GQLMutation` and declare them separately at the `GQLRootResolver` definition++```haskell+newtype Mutation = Mutation+  { createDeity :: Form -> IOMutRes Deity+  } deriving (Generic)++createDeityMutation :: Form -> IOMutRes Deity+createDeityMutation = ...++rootResolver :: GQLRootResolver IO Query Mutation ()+rootResolver =+  GQLRootResolver+    { queryResolver = return Query {...}+    , mutationResolver = return Mutation {+       createDeity = createDeityMutation+    }+    , subscriptionResolver = return ()+    }++gqlApi :: ByteString -> IO ByteString+gqlApi = interpreter rootResolver+```++### Subscriptions++im morpheus subscription and mutation communicating with Events,+`Event` consists with user defined `Channel` and `Content`.++every subscription has own Channel by which will be triggered++```haskell++data Channel+  = ChannelA+  | ChannelB++data Content+  = ContentA Int+  | ContentB Text++newtype Query = Query+  { deity :: () -> IORes Deity+  } deriving (Generic)++newtype Mutation = Mutation+  { createDeity :: () -> IOMutRes Channel Content Deity+  } deriving (Generic)++newtype Subscription = Subscription+  { newDeity :: () -> IOSubRes Channel Content Deity+  } deriving (Generic)++rootResolver :: GQLRootResolver IO Channel Content Query Mutation Subscription+rootResolver =+  GQLRootResolver+    { queryResolver = return Query {deity = const fetchDeity}+    , mutationResolver = return Mutation {createDeity}+    , subscriptionResolver = return Subscription {newDeity}+    }+  where+    fetchDeity = resolver $ dbDeity "" Nothing+    createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity+    newDeity _args = Event {channels = [ChannelA], content}+      where+        content (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State+        content (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State+        content _                                    = fetchDeity -- Resolve Old State+```++## Morpheus `GraphQL Client` with Template haskell QuasiQuotes++```haskell+defineByDocumentFile+    "./schema.gql"+  [gql|+    query GetHero ($byRealm: Realm)+      {+        deity (realm:$byRealm) {+          power+          fullName+        }+      }+  |]+```++will validate query and Generate:++- response type `GetHero`, `Deity` with `Lens` Instances+- input types: `GetHeroArgs` , `Realm`+- instance for `Fetch` typeClass++so that++```haskell+  fetchHero :: Args GetHero -> m (Either String GetHero)+  fetchHero = fetch jsonRes args+      where+        args = GetHeroArgs {byRealm = Just Realm {owner = "Zeus", surface = Just 10}}+        jsonRes :: ByteString -> m ByteString+        jsonRes = <GraphQL APi>+```++resolves well typed response `GetHero`.++except: `defineByDocumentFile` you can use:++```haskell+defineByIntrospectionFile "./introspection.json"+```++or++`defineByIntrospection` where you can directly connect it to server++## Morpheus CLI for Code Generating++Generating dummy Morpheus Api from `schema.gql`++```+morpheus build src/schem.gql src/GQLApi.hs+```++this command will generate Haskell API and resolvers,+resolvers will resolve default values for every object++# About++## The name++_Morpheus_ is the greek god of sleep and dreams whose name comes from the greek word _μορφή_ meaning form or shape.+He is said to be able to mimic different forms and GraphQL is good at doing exactly that: Transforming data in the shape+of many different APIs.++## Team++Morpheus is written and maintained by [_nalchevanidze_](https://github.com/nalchevanidze)++## Roadmap++- Medium future:+  - Stabilize API+  - Specification-isomorphic introspection+  - Specification-isomorphic error handling+- Long term:+  - Support all possible GQL features+  - Performance optimization
assets/simple.gql view
@@ -4,6 +4,10 @@   hero: Human! } +interface MyInterface {+    name: String+}+ type Mutation {   createDeity (deityName: [[[[[String!]]!]]], deityMythology: String): Deity!   createCharacter (charRealm: Realm! , charMutID: String! ): Character!
changelog.md view
@@ -1,3 +1,34 @@+## [0.2.2] - 30.08.2019++### Fixed+- Parser Supports GraphQL multiline comments+- Morpheus GraphQL Client: Support GraphQL Alias+- Support of GraphQL Interfaces on GraphQL Document:+    ```gql+    # simple.gql+    interface Node {+      nodeId: ID!+    }++    type SimpleType implements Node {+      nodeId: ID!+      name: String!+    }+    ```++    morpheus compiler will read interfaces and validate implements.+    template haskell will generate haskell types only for types not for interfaces.++    haskell type from `simple.gql`:+    ```haskell+     data SimpleType = SimpleType {+        nodeId :: ID!+        name   :: Text!+      }  deriving (Generic)+    ```++    at the time compiler does not validates field Arguments by interface+ ## [0.2.1] - 23.08.2019  - assets are added to cabal source files
examples/Main.hs view
@@ -22,12 +22,11 @@ import           Data.Morpheus.Types            (ScalarValue (..)) import           Deprecated.API                 (Channel, Content, gqlRoot) import           Mythology.API                  (mythologyApi)-import           TH.API                         (thApi)- 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           TH.API                         (thApi) import           Web.Scotty                     (body, file, get, post, raw, scottyApp)  ioRes :: ByteString -> IO ByteString@@ -42,8 +41,8 @@     # Query Hero with Compile time Validation     query GetUser ($userCoordinates: Coordinates!)       {-        user {-           name+        myUser: user {+           boo3: name            email            address (coordinates: $userCoordinates ){             city
+ examples/Subscription/SimpleSubscription.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Subscription.SimpleSubscription where++import           Data.Morpheus.Types       (Event (..), GQLRootResolver (..), IOMutRes, IORes, IOSubRes, resolver,+                                            toMutResolver)+import           Data.Text                 (Text)+import           GHC.Generics              (Generic)+import           Mythology.Character.Deity (Deity (..), dbDeity)++data Channel+  = ChannelA+  | ChannelB++data Content+  = ContentA Int+  | ContentB Text++newtype Query = Query+  { deity :: () -> IORes Deity+  } deriving (Generic)++newtype Mutation = Mutation+  { createDeity :: () -> IOMutRes Channel Content Deity+  } deriving (Generic)++newtype Subscription = Subscription+  { newDeity :: () -> IOSubRes Channel Content Deity+  } deriving (Generic)++rootResolver :: GQLRootResolver IO Channel Content Query Mutation Subscription+rootResolver =+  GQLRootResolver+    { queryResolver = return Query {deity = const fetchDeity}+    , mutationResolver = return Mutation {createDeity}+    , subscriptionResolver = return Subscription {newDeity}+    }+  where+    fetchDeity = resolver $ dbDeity "" Nothing+    createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity+    newDeity _args = Event {channels = [ChannelA], content}+      where+        content (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State+        content (Event [ChannelA] (ContentB value))  = resolver $ dbDeity value Nothing -- resolve New State+        content _                                    = fetchDeity -- Resolve Old State
examples/TH/API.hs view
@@ -16,7 +16,7 @@ import           Data.Morpheus              (interpreter) import           Data.Morpheus.Document     (gqlDocument) import           Data.Morpheus.Kind         (SCALAR)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLScalar (..), GQLType (..), IORes,+import           Data.Morpheus.Types        (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, IORes,                                              ScalarValue (..))  newtype Euro =@@ -37,6 +37,10 @@     user : User!   } ++  """+    GraphQL Multiline Comment+  """   type User {     name                                      : Text!     email                                     : Text!@@ -62,6 +66,16 @@   input Coordinates {     latitude  : Euro!     longitude : [[UID!]]!+  }++  # simple.gql+  interface Node {+      nodeId: ID!+  }++  type SimpleType implements Node {+    nodeId: ID!+    interfaceName: String!   }    input UID {
morpheus-graphql.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5dffd2e1cb2921b0bc958c61fb047928492b4b4ac933979f6f3cf12e5f2d49b9+-- hash: e5802f5202e1f3d85dbcbbfa5bbeccbe45394f9039335d2315915df0cee9d49a  name:           morpheus-graphql-version:        0.2.1+version:        0.2.2 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -24,6 +24,7 @@     assets/pubsub.gql     assets/simple.gql     changelog.md+    README.md data-files:     test/Feature/Holistic/API.gql     test/Feature/Holistic/arguments/nameConflict/query.gql@@ -97,9 +98,13 @@     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/multilineComments/query.gql+    test/Feature/Holistic/parsing/multilineComments/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/parsing/singleLineComments/query.gql+    test/Feature/Holistic/parsing/singleLineComments/response.json     test/Feature/Holistic/selection/AliasNameConflict/query.gql     test/Feature/Holistic/selection/AliasNameConflict/response.json     test/Feature/Holistic/selection/AliasResolve/query.gql@@ -223,6 +228,7 @@   other-modules:       Data.Morpheus.Error.Arguments       Data.Morpheus.Error.Client.Client+      Data.Morpheus.Error.Document.Interface       Data.Morpheus.Error.Fragment       Data.Morpheus.Error.Input       Data.Morpheus.Error.Internal@@ -254,7 +260,6 @@       Data.Morpheus.Parsing.Client.ParseMeta       Data.Morpheus.Parsing.Client.Parser       Data.Morpheus.Parsing.Document.DataType-      Data.Morpheus.Parsing.Document.Parse       Data.Morpheus.Parsing.Document.Parser       Data.Morpheus.Parsing.Internal.Create       Data.Morpheus.Parsing.Internal.Internal@@ -300,15 +305,16 @@       Data.Morpheus.Types.IO       Data.Morpheus.Types.Resolver       Data.Morpheus.Types.Types-      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.Utils.Selection-      Data.Morpheus.Validation.Utils.Utils-      Data.Morpheus.Validation.Validation-      Data.Morpheus.Validation.Variable+      Data.Morpheus.Validation.Document.Validation+      Data.Morpheus.Validation.Internal.Utils+      Data.Morpheus.Validation.Query.Arguments+      Data.Morpheus.Validation.Query.Fragment+      Data.Morpheus.Validation.Query.Input.Enum+      Data.Morpheus.Validation.Query.Input.Object+      Data.Morpheus.Validation.Query.Selection+      Data.Morpheus.Validation.Query.Utils.Selection+      Data.Morpheus.Validation.Query.Validation+      Data.Morpheus.Validation.Query.Variable       Paths_morpheus_graphql   hs-source-dirs:       src@@ -344,6 +350,7 @@       Mythology.Character.Deity       Mythology.Character.Human       Mythology.Place.Places+      Subscription.SimpleSubscription       TH.API       TH.Simple       Paths_morpheus_graphql
src/Data/Morpheus/Client.hs view
@@ -17,11 +17,11 @@ import           Language.Haskell.TH import           Language.Haskell.TH.Quote +import           Data.Morpheus.Document                  (parseFullGQLDocument) -- MORPHEUS import           Data.Morpheus.Execution.Client.Build    (defineQuery) import           Data.Morpheus.Execution.Client.Compile  (compileSyntax) import           Data.Morpheus.Execution.Client.Fetch    (Fetch (..))-import           Data.Morpheus.Parsing.Document.Parse    (parseFullGQLDocument) import           Data.Morpheus.Parsing.JSONSchema.Parse  (decodeIntrospection) import           Data.Morpheus.Types.Internal.Data       (DataTypeLib) import           Data.Morpheus.Types.Internal.Validation (Validation)
src/Data/Morpheus/Document.hs view
@@ -5,19 +5,39 @@   ( toGraphQLDocument   , toMorpheusHaskellAPi   , gqlDocument+  , parseFullGQLDocument   ) where -import           Data.ByteString.Lazy.Char8               (ByteString, pack)+import           Control.Monad                                ((>=>))+import           Data.ByteString.Lazy.Char8                   (ByteString, pack)+import           Data.Text                                    (Text)+import qualified Data.Text.Lazy                               as LT (toStrict)+import           Data.Text.Lazy.Encoding                      (decodeUtf8) import           Language.Haskell.TH.Quote  -- -- MORPHEUS-import           Data.Morpheus.Execution.Document.Compile (compileDec, compileExp)-import           Data.Morpheus.Execution.Server.Resolve   (RootResCon, fullSchema)-import           Data.Morpheus.Parsing.Document.Parse     (parseGraphQLDocument)-import           Data.Morpheus.Rendering.GQL              (renderGraphQLDocument)-import           Data.Morpheus.Rendering.Haskell.Render   (renderHaskellDocument)-import           Data.Morpheus.Types                      (GQLRootResolver)+import           Data.Morpheus.Execution.Document.Compile     (compileDec, compileExp)+import           Data.Morpheus.Execution.Server.Resolve       (RootResCon, fullSchema)+import           Data.Morpheus.Rendering.GQL                  (renderGraphQLDocument)+import           Data.Morpheus.Rendering.Haskell.Render       (renderHaskellDocument)+import           Data.Morpheus.Types                          (GQLRootResolver)++import           Data.Morpheus.Parsing.Document.Parser        (parseTypes)+import           Data.Morpheus.Parsing.Internal.Create        (createDataTypeLib)+import           Data.Morpheus.Schema.SchemaAPI               (defaultTypes)+import           Data.Morpheus.Types.Internal.Data            (DataTypeLib)+import           Data.Morpheus.Types.Internal.Validation      (Validation)+import           Data.Morpheus.Validation.Document.Validation (validatePartialDocument)++parseDocument :: Text -> Validation DataTypeLib+parseDocument doc = parseTypes doc >>= validatePartialDocument >>= createDataTypeLib++parseGraphQLDocument :: ByteString -> Validation DataTypeLib+parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x)++parseFullGQLDocument :: ByteString -> Validation DataTypeLib+parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes  -- | Generates schema.gql file from 'GQLRootResolver' toGraphQLDocument :: RootResCon m e c query mut sub => proxy (GQLRootResolver m e c query mut sub) -> ByteString
+ src/Data/Morpheus/Error/Document/Interface.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Error.Document.Interface+  ( unknownInterface+  , partialImplements+  , ImplementsError(..)+  ) where++import           Data.Morpheus.Error.Utils               (globalErrorMessage)+import           Data.Morpheus.Types.Internal.Base       (Key)+import           Data.Morpheus.Types.Internal.Validation (GQLError (..), GQLErrors)+import           Data.Semigroup                          ((<>))++unknownInterface :: Key -> GQLErrors+unknownInterface name = globalErrorMessage message+  where+    message = "Unknown Interface \"" <> name <> "\"."++data ImplementsError+  = UnexpectedType { expectedType :: Key+                   , foundType    :: Key }+  | UndefinedField++partialImplements :: Key -> [(Key, Key, ImplementsError)] -> GQLErrors+partialImplements name = map impError+  where+    impError (interfaceName, key, errorType) = GQLError {desc = message, positions = []}+      where+        message =+          "type \"" <> name <> "\" implements Interface \"" <> interfaceName <> "\" Partially," <>+          detailedMessage errorType+        detailedMessage UnexpectedType {expectedType, foundType} =+          " on key \"" <> key <> "\" expected type \"" <> expectedType <> "\" found \"" <> foundType <> "\"."+        detailedMessage UndefinedField = " key \"" <> key <> "\" not found ."
src/Data/Morpheus/Execution/Client/Compile.hs view
@@ -17,13 +17,14 @@ import qualified Data.Morpheus.Types.Internal.AST.Operation as O (Operation (..)) import           Data.Morpheus.Types.Internal.Data          (DataTypeLib) import           Data.Morpheus.Types.IO                     (GQLRequest (..))+ -- --  Morpheus import           Data.Morpheus.Types.Internal.DataD         (QueryD (..)) import           Data.Morpheus.Types.Internal.Validation    (Validation) import           Data.Morpheus.Types.Types                  (GQLQueryRoot (..))-import           Data.Morpheus.Validation.Utils.Utils       (VALIDATION_MODE (..))-import           Data.Morpheus.Validation.Validation        (validateRequest)+import           Data.Morpheus.Validation.Internal.Utils    (VALIDATION_MODE (..))+import           Data.Morpheus.Validation.Query.Validation  (validateRequest)  compileSyntax :: String -> Q Exp compileSyntax queryText =
src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -13,7 +13,7 @@  -- -- MORPHEUS-import           Data.Morpheus.Error.Internal               (internalUnknownTypeMessage)+import           Data.Morpheus.Error.Utils                  (globalErrorMessage) import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation, Variable (..),                                                              VariableDefinitions) import           Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..))@@ -22,10 +22,10 @@                                                              allDataTypes) import           Data.Morpheus.Types.Internal.DataD         (ConsD (..), FieldD (..), TypeD (..), gqlToHSWrappers) import           Data.Morpheus.Types.Internal.Validation    (GQLErrors, Validation)-import           Data.Morpheus.Validation.Utils.Utils       (lookupType)+import           Data.Morpheus.Validation.Internal.Utils    (lookupType)  compileError :: Text -> GQLErrors-compileError x = internalUnknownTypeMessage $ " \"" <> x <> "\" ;"+compileError x = globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;"  operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation ([TypeD], [TypeD]) operationTypes lib variables = genOperation@@ -92,11 +92,13 @@         genFields datatype = mapM typeNameFromField           where             typeNameFromField :: (Text, Selection) -> Validation FieldD-            typeNameFromField (key, _) = FieldD (unpack key) <$> wrType-              where-                wrType = do-                  (newType, wrappers) <- fieldDataType datatype key-                  pure $ gqlToHSWrappers wrappers (unpack $ typeFrom newType)+            typeNameFromField (key, Selection {selectionRec = SelectionAlias {aliasFieldName}}) =+              FieldD (unpack key) <$> lookupFieldType aliasFieldName+            typeNameFromField (key, _) = FieldD (unpack key) <$> lookupFieldType key+            ------------------------------------------------------------+            lookupFieldType key = do+              (newType, wrappers) <- fieldDataType datatype key+              pure $ gqlToHSWrappers wrappers (unpack $ typeFrom newType)     --------------------------------------------     genRecordType name dataType selectionSet = do       (con, subTypes) <- getCon name dataType selectionSet@@ -105,14 +107,16 @@     newFieldTypes parentType = fmap concat <$> mapM validateSelection       where         validateSelection :: (Text, Selection) -> Validation [TypeD]-        validateSelection (key, Selection {selectionRec = SelectionSet selectionSet}) = do-          datatype <- key `typeByField` parentType-          genRecordType (typeFrom datatype) datatype selectionSet         validateSelection (key, Selection {selectionRec = SelectionField}) =           key `typeByField` parentType >>= buildSelField           where             buildSelField (Leaf x) = buildLeaf x             buildSelField _        = Left $ compileError "Invalid schema Expected scalar"+        validateSelection (key, Selection {selectionRec = SelectionSet selectionSet}) = do+          datatype <- key `typeByField` parentType+          genRecordType (typeFrom datatype) datatype selectionSet+        validateSelection (_, selection@Selection {selectionRec = SelectionAlias {aliasFieldName, aliasSelection}}) =+          validateSelection (aliasFieldName, selection {selectionRec = aliasSelection})         validateSelection (key, Selection {selectionRec = UnionSelection unionSelections}) = do           unionTypeName <- typeFrom <$> key `typeByField` parentType           (tCons, subTypes) <- unzip <$> mapM getUnionType unionSelections@@ -121,7 +125,6 @@             getUnionType (typeKey, selSet) = do               conDatatype <- getType lib typeKey               getCon typeKey conDatatype selSet-        validateSelection _ = pure []  buildLeaf :: DataLeaf -> Validation [TypeD] buildLeaf (LeafEnum DataType {typeName, typeData}) =
src/Data/Morpheus/Execution/Document/Compile.hs view
@@ -7,24 +7,25 @@   , compileDec   ) where -import qualified Data.Text                                as T (pack)+import qualified Data.Text                                    as T (pack) import           Language.Haskell.TH  -- --  Morpheus-import           Data.Morpheus.Error.Client.Client        (renderGQLErrors)-import           Data.Morpheus.Execution.Document.Convert (renderTHTypes)-import           Data.Morpheus.Execution.Document.Declare (declareTypes)-import           Data.Morpheus.Parsing.Document.Parser    (parseTypes)+import           Data.Morpheus.Error.Client.Client            (renderGQLErrors)+import           Data.Morpheus.Execution.Document.Convert     (renderTHTypes)+import           Data.Morpheus.Execution.Document.Declare     (declareTypes)+import           Data.Morpheus.Parsing.Document.Parser        (parseTypes)+import           Data.Morpheus.Validation.Document.Validation  compileExp :: String -> Q Exp compileExp documentTXT =-  case parseTypes (T.pack documentTXT) >>= renderTHTypes of+  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes of     Left errors -> fail (renderGQLErrors errors)     Right root  -> [|root|]  compileDec :: String -> Q [Dec] compileDec documentTXT =-  case parseTypes (T.pack documentTXT) >>= renderTHTypes of+  case parseTypes (T.pack documentTXT) >>= validatePartialDocument >>= renderTHTypes of     Left errors -> fail (renderGQLErrors errors)     Right root  -> declareTypes root
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -42,8 +42,8 @@ import           Data.Morpheus.Types.Internal.Value                  (Value (..)) import           Data.Morpheus.Types.IO                              (GQLRequest (..), GQLResponse (..)) import           Data.Morpheus.Types.Resolver                        (GQLRootResolver (..))-import           Data.Morpheus.Validation.Utils.Utils                (VALIDATION_MODE (..))-import           Data.Morpheus.Validation.Validation                 (validateRequest)+import           Data.Morpheus.Validation.Internal.Utils             (VALIDATION_MODE (..))+import           Data.Morpheus.Validation.Query.Validation           (validateRequest)  type EventCon event = Eq event
src/Data/Morpheus/Parsing/Document/DataType.hs view
@@ -11,9 +11,10 @@ import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, parseMaybeTuple, parseNonNull,                                                           parseWrappedType, pipeLiteral, qualifier, setOf,                                                           spaceAndComments, token)-import           Data.Morpheus.Types.Internal.Data       (DataArgument, DataFullType (..), DataOutputField, Key)+import           Data.Morpheus.Types.Internal.Data       (DataArgument, DataFullType (..), DataOutputField, Key,+                                                          RawDataType (..)) import           Data.Text                               (Text)-import           Text.Megaparsec                         (label, sepBy1, (<|>))+import           Text.Megaparsec                         (label, sepBy1, some, (<|>)) import           Text.Megaparsec.Char                    (char, space1, string)  dataArgument :: Parser (Text, DataArgument)@@ -33,39 +34,57 @@ dataInputObject =   label "inputObject" $ do     typeName <- typeDef "input"-    typeData <- inputEntries+    typeData <- inputObjectEntries     pure (typeName, InputObject $ createType typeName typeData)++inputObjectEntries :: Parser [(Key, DataArgument)]+inputObjectEntries = label "inputEntries" $ setOf entry   where-    inputEntries :: Parser [(Key, DataArgument)]-    inputEntries = label "inputEntries" $ setOf entry-      where-        entry =-          label "entry" $ do-            ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType-            nonNull <- parseNonNull-            return (fieldName, createField () fieldName (nonNull ++ wrappers, fieldType))+    entry =+      label "entry" $ do+        ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType+        nonNull <- parseNonNull+        return (fieldName, createField () fieldName (nonNull ++ wrappers, fieldType)) -dataObject :: Parser (Text, DataFullType)+outputObjectEntries :: Parser [(Key, DataOutputField)]+outputObjectEntries = label "entries" $ setOf entry+  where+    fieldWithArgs =+      label "fieldWithArgs" $ do+        (name, _) <- qualifier+        args <- parseMaybeTuple dataArgument+        return (name, args)+    entry =+      label "entry" $ do+        ((fieldName, fieldArgs), (wrappers, fieldType)) <- parseAssignment fieldWithArgs parseWrappedType+        nonNull <- parseNonNull+        return (fieldName, createField fieldArgs fieldName (nonNull ++ wrappers, fieldType))++dataObject :: Parser (Text, RawDataType) dataObject =   label "object" $ do     typeName <- typeDef "type"-    typeData <- entries-    pure (typeName, OutputObject $ createType typeName typeData)+    interfaces <- maybeImplements+    typeData <- outputObjectEntries+    pure (typeName, Implements interfaces $ createType typeName typeData)++maybeImplements :: Parser [Text]+maybeImplements = implements <|> pure []   where-    entries :: Parser [(Key, DataOutputField)]-    entries = label "entries" $ setOf entry-      where-        fieldWithArgs =-          label "fieldWithArgs" $ do-            (name, _) <- qualifier-            args <- parseMaybeTuple dataArgument-            return (name, args)-        entry =-          label "entry" $ do-            ((fieldName, fieldArgs), (wrappers, fieldType)) <- parseAssignment fieldWithArgs parseWrappedType-            nonNull <- parseNonNull-            return (fieldName, createField fieldArgs fieldName (nonNull ++ wrappers, fieldType))+    implements =+      label "implements" $ do+        _ <- string "implements"+        space1+        spaceAndComments+        some token +dataInterface :: Parser (Text, RawDataType)+dataInterface =+  label "interface" $ do+    typeName <- typeDef "interface"+    typeData <- outputObjectEntries+    pure (typeName, Interface $ createType typeName typeData)+ dataScalar :: Parser (Text, DataFullType) dataScalar =   label "scalar" $ do@@ -91,5 +110,12 @@   where     unionsParser = token `sepBy1` pipeLiteral -parseDataType :: Parser (Text, DataFullType)-parseDataType = label "dataType" $ dataObject <|> dataInputObject <|> dataUnion <|> dataEnum <|> dataScalar+parseFinalDataType :: Parser (Text, DataFullType)+parseFinalDataType = label "dataType" $ dataInputObject <|> dataUnion <|> dataEnum <|> dataScalar++parseDataType :: Parser (Text, RawDataType)+parseDataType = label "dataType" $ dataInterface <|> dataObject <|> finalDataT+  where+    finalDataT = do+      (name, datatype) <- parseFinalDataType+      pure (name, FinalDataType datatype)
− src/Data/Morpheus/Parsing/Document/Parse.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns   #-}--module Data.Morpheus.Parsing.Document.Parse-  ( parseGraphQLDocument-  , parseFullGQLDocument-  ) where--import           Control.Monad                           ((>=>))-import           Data.ByteString.Lazy.Char8              (ByteString)-import qualified Data.Text.Lazy                          as LT (toStrict)-import           Data.Text.Lazy.Encoding                 (decodeUtf8)---- MORPHEUS-import           Data.Morpheus.Parsing.Document.Parser   (parseDocument)-import           Data.Morpheus.Schema.SchemaAPI          (defaultTypes)-import           Data.Morpheus.Types.Internal.Data       (DataTypeLib)-import           Data.Morpheus.Types.Internal.Validation (Validation)--parseGraphQLDocument :: ByteString -> Validation DataTypeLib-parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x)--parseFullGQLDocument :: ByteString -> Validation DataTypeLib-parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes
src/Data/Morpheus/Parsing/Document/Parser.hs view
@@ -2,8 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Parsing.Document.Parser-  ( parseDocument-  , parseTypes+  ( parseTypes   ) where  import           Data.Text                               (Text)@@ -11,13 +10,12 @@  -- MORPHEUS import           Data.Morpheus.Parsing.Document.DataType (parseDataType)-import           Data.Morpheus.Parsing.Internal.Create   (createDataTypeLib) import           Data.Morpheus.Parsing.Internal.Internal (processErrorBundle) import           Data.Morpheus.Parsing.Internal.Terms    (spaceAndComments)-import           Data.Morpheus.Types.Internal.Data       (DataFullType, DataTypeLib)+import           Data.Morpheus.Types.Internal.Data       (RawDataType) import           Data.Morpheus.Types.Internal.Validation (Validation) -parseTypes :: Text -> Validation [(Text, DataFullType)]+parseTypes :: Text -> Validation [(Text, RawDataType)] parseTypes doc =   case parseDoc of     Right root      -> Right root@@ -28,16 +26,3 @@       label "DocumentTypes" $ do         spaceAndComments         manyTill parseDataType eof--parseDocument :: Text -> Validation DataTypeLib-parseDocument doc =-  case parseDoc of-    Right root      -> Right root-    Left parseError -> Left $ processErrorBundle parseError-  where-    parseDoc = runParser request "<input>" doc-    request =-      label "Document" $ do-        spaceAndComments-        dataTypes <- manyTill parseDataType eof-        createDataTypeLib dataTypes
src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -6,6 +6,7 @@   , qualifier   , variable   , spaceAndComments+  , spaceAndComments1   , pipeLiteral   -------------   , setOf@@ -59,10 +60,17 @@     varName' <- token     return (varName', position') +spaceAndComments1 :: Parser ()+spaceAndComments1 = space1 *> spaceAndComments+ spaceAndComments :: Parser ()-spaceAndComments = space *> skipMany inlineComment *> space+spaceAndComments = space *> skipMany (inlineComment <|> multilineComment) *> space   where     inlineComment = char '#' *> skipManyTill printChar newline *> space+    ------------------------------------------------------------------------+    multilineComment = multilineIndicator *> skipManyTill (printChar *> space <|> space) multilineIndicator *> space+    --------------------+    multilineIndicator = string "\"\"\""  -- COMPLEX -----------------------------
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -9,13 +9,13 @@ import           Data.Functor                               (($>)) import           Data.Text                                  (Text) import           Text.Megaparsec                            (label, (<?>), (<|>))-import           Text.Megaparsec.Char                       (space1, string)+import           Text.Megaparsec.Char                       (string)  -- -- MORPHEUS import           Data.Morpheus.Parsing.Internal.Internal    (Parser, getLocation) import           Data.Morpheus.Parsing.Internal.Terms       (parseAssignment, parseMaybeTuple, parseNonNull,-                                                             parseWrappedType, token, variable)+                                                             parseWrappedType, spaceAndComments1, token, variable) import           Data.Morpheus.Parsing.Request.Body         (entries) import           Data.Morpheus.Types.Internal.AST.Operation (Operation (..), OperationKind (..), RawOperation,                                                              Variable (..))@@ -64,5 +64,5 @@ parseOperationKind =   label "operatorKind" $ do     kind <- (string "query" $> QUERY) <|> (string "mutation" $> MUTATION) <|> (string "subscription" $> SUBSCRIPTION)-    space1+    spaceAndComments1     return kind
src/Data/Morpheus/Parsing/Request/Value.hs view
@@ -9,23 +9,20 @@ import           Data.Functor                            (($>)) import           Data.Text                               (pack) import           Text.Megaparsec                         (anySingleBut, between, choice, label, many, sepBy, (<|>))-import           Text.Megaparsec.Char                    (char, space, string)+import           Text.Megaparsec.Char                    (char, string) import           Text.Megaparsec.Char.Lexer              (scientific)  -- -- MORPHEUS import           Data.Morpheus.Parsing.Internal.Internal (Parser)-import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, setOf, token)+import           Data.Morpheus.Parsing.Internal.Terms    (parseAssignment, setOf, spaceAndComments, token) import           Data.Morpheus.Types.Internal.Value      (ScalarValue (..), Value (..), decodeScientific)  parseValue :: Parser Value parseValue =   label "value" $ do-    value <--      valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|>-      objectValue <|>-      listValue-    space+    value <- valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|> objectValue <|> listValue+    spaceAndComments     return value  valueNull :: Parser Value@@ -43,7 +40,7 @@ enumValue :: Parser Value enumValue = do   enum <- Enum <$> token-  space+  spaceAndComments   return enum  escaped :: Parser Char@@ -59,18 +56,16 @@     escapeChar code replacement = char code >> return replacement  stringValue :: Parser Value-stringValue =-  label "stringValue" $-  Scalar . String . pack <$> between (char '"') (char '"') (many escaped)+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))+    (char '[' *> spaceAndComments)+    (char ']' *> spaceAndComments)+    (parseValue `sepBy` (char ',' *> spaceAndComments))  objectValue :: Parser Value objectValue = label "objectValue" $ Object <$> setOf entry
src/Data/Morpheus/Types/IO.hs view
@@ -10,6 +10,7 @@  import           Data.Aeson                              (FromJSON (..), ToJSON (..), pairs, withObject, (.:?), (.=)) import qualified Data.Aeson                              as Aeson (Value (..))+import qualified Data.HashMap.Lazy                       as LH (toList) import           GHC.Generics                            (Generic)  -- MORPHEUS@@ -39,6 +40,14 @@   = Data Value   | Errors [JSONError]   deriving (Show, Generic)++instance FromJSON GQLResponse where+  parseJSON (Aeson.Object hm) =+    case LH.toList hm of+      [("data", value)]   -> Data <$> parseJSON value+      [("errors", value)] -> Errors <$> parseJSON value+      _                   -> fail "Invalid GraphQL Response"+  parseJSON _ = fail "Invalid GraphQL Response"  instance ToJSON GQLResponse where   toEncoding (Data _data)     = pairs $ "data" .= _data
src/Data/Morpheus/Types/Internal/Data.hs view
@@ -25,6 +25,7 @@   , DataValidator(..)   , DataTypeKind(..)   , DataFingerprint(..)+  , RawDataType(..)   , isTypeDefined   , initTypeLib   , defineType@@ -127,6 +128,13 @@   | EnumKind DataEnum   | ObjectKind (DataObject a)   | UnionKind DataUnion+  deriving (Show)++data RawDataType+  = FinalDataType DataFullType+  | Interface DataOutputObject+  | Implements { implementsInterfaces :: [Key]+               , unImplements         :: DataOutputObject }   deriving (Show)  data DataFullType
− src/Data/Morpheus/Validation/Arguments.hs 
@@ -1,146 +0,0 @@-{-# 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.Operation    (ValidVariables, Variable (..))-import           Data.Morpheus.Types.Internal.AST.RawSelection (RawArgument (..), RawArguments, Reference (..))-import           Data.Morpheus.Types.Internal.AST.Selection    (Argument (..), ArgumentOrigin (..), 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, ) . toArgument <$> lookupVar-      where-        toArgument argumentValue =-          Argument-            { argumentValue-            , argumentOrigin = VARIABLE-            , argumentPosition = referencePosition-            }-        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, fieldTypeWrappers} arg@(key, Argument { argumentValue-                                                                                      , argumentPosition-                                                                                      }) =-  getInputType fieldType lib (internalUnknownTypeMessage fieldType) >>=-  checkType >>-  pure arg-  where-    checkType type' =-      handleInputError-        key-        argumentPosition-        (validateInputValue lib [] fieldTypeWrappers type' (key, argumentValue))--validateArgument ::-     DataTypeLib-  -> Position-  -> Arguments-  -> (Text, DataArgument)-  -> Validation (Text, Argument)-validateArgument types argumentPosition requestArgs (key, arg) =-  case lookup key requestArgs of-    Nothing                                            -> handleNullable-    Just argument@Argument {argumentOrigin = VARIABLE} -> pure (key, argument) -- Variables are already checked in Variable Validation-    Just Argument {argumentValue = Null}               -> handleNullable-    Just argument                                      -> validateArgumentValue types arg (key, argument)-  where-    handleNullable-      | isFieldNullable arg =-        pure-          ( key-          , Argument-              {argumentValue = Null, argumentOrigin = INLINE, argumentPosition})-      | otherwise = Left $ undefinedArgument (EnhancedKey key argumentPosition)--checkForUnknownArguments ::-     (Text, DataOutputField) -> Arguments -> Validation [(Text, DataInputField)]-checkForUnknownArguments (key, DataField {fieldArgs}) args =-  checkForUnknownKeys enhancedKeys fieldKeys argError >>-  checkNameCollision enhancedKeys argumentNameCollision >>-  pure fieldArgs-  where-    argError = unknownArguments key-    enhancedKeys = map argToKey args-    argToKey (key', Argument {argumentPosition}) =-      EnhancedKey key' argumentPosition-    fieldKeys = map fst fieldArgs--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
+ src/Data/Morpheus/Validation/Document/Validation.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Document.Validation+  ( validatePartialDocument+  ) where++import           Data.Maybe++--+-- Morpheus+import           Data.Morpheus.Error.Document.Interface  (ImplementsError (..), partialImplements, unknownInterface)+import           Data.Morpheus.Types.Internal.Base       (Location (..))+import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataFullType (..), DataOutputField,+                                                          DataOutputObject, DataType (..), Key, RawDataType (..),+                                                          showWrappedType)+import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Validation.Internal.Utils (isEqOrStricter)++validatePartialDocument :: [(Key, RawDataType)] -> Validation [(Key, DataFullType)]+validatePartialDocument lib = catMaybes <$> traverse validateType lib+  where+    validateType :: (Key, RawDataType) -> Validation (Maybe (Key, DataFullType))+    validateType (name, FinalDataType x)              = pure $ Just (name, x)+    validateType (name, Implements interfaces object) = asTuple name <$> object `mustImplement` interfaces+    validateType _                                    = pure Nothing+    -----------------------------------+    asTuple name x = Just (name, x)+    -----------------------------------+    mustImplement :: DataOutputObject -> [Key] -> Validation DataFullType+    mustImplement object interfaceKey = do+      interface <- traverse getInterfaceByKey interfaceKey+      case concatMap (mustBeSubset object) interface of+        []     -> pure $ OutputObject object+        errors -> Left $ partialImplements (typeName object)  errors+    -------------------------------+    mustBeSubset :: DataOutputObject -> DataOutputObject -> [(Key, Key, ImplementsError)]+    mustBeSubset DataType {typeData = objFields} DataType {typeName, typeData = interfaceFields} =+      concatMap checkField interfaceFields+      where+        checkField :: (Key, DataOutputField) -> [(Key, Key, ImplementsError)]+        checkField (key, DataField {fieldType = interfaceTypeName, fieldTypeWrappers = interfaceWrappers}) =+          case lookup key objFields of+            Just DataField {fieldType, fieldTypeWrappers}+              | fieldType == interfaceTypeName && isEqOrStricter fieldTypeWrappers interfaceWrappers -> []+              | otherwise -> [(typeName, key, UnexpectedType {expectedType, foundType})]+              where expectedType = showWrappedType interfaceWrappers interfaceTypeName+                    foundType = showWrappedType fieldTypeWrappers fieldType+            Nothing -> [(typeName, key, UndefinedField)]+    -------------------------------+    getInterfaceByKey :: Key -> Validation DataOutputObject+    getInterfaceByKey key =+      case lookup key lib of+        Just (Interface x) -> pure x+        _                  -> Left $ unknownInterface key
− src/Data/Morpheus/Validation/Fragment.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Validation.Fragment-  ( validateFragments-  , castFragmentType-  , resolveSpread-  , getFragment-  ) where--import           Data.List                                     ((\\))-import           Data.Semigroup                                ((<>))-import           Data.Text                                     (Text)-import qualified Data.Text                                     as T (concat)---- MORPHEUS-import           Data.Morpheus.Error.Fragment                  (cannotBeSpreadOnType, cannotSpreadWithinItself,-                                                                fragmentNameCollision, unknownFragment, unusedFragment)-import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),-                                                                RawSelection' (..), Reference (..))-import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position)-import           Data.Morpheus.Types.Internal.Data             (DataTypeLib)-import           Data.Morpheus.Types.Internal.Validation       (Validation)-import           Data.Morpheus.Validation.Utils.Utils          (checkNameCollision, existsObjectType)--validateFragments ::-     DataTypeLib -> FragmentLib -> [(Text, RawSelection)] -> Validation ()-validateFragments lib fragments operatorSel =-  validateNameCollision >> checkLoop >> checkUnusedFragments-  where-    validateNameCollision =-      checkNameCollision fragmentsKeys fragmentNameCollision-    checkUnusedFragments =-      case fragmentsKeys \\ usedFragments fragments operatorSel of-        []     -> return ()-        unused -> Left $ unusedFragment unused-    checkLoop = mapM (validateFragment lib) fragments >>= detectLoopOnFragments-    fragmentsKeys = map toEnhancedKey fragments-      where-        toEnhancedKey (key, Fragment {fragmentPosition}) =-          EnhancedKey key fragmentPosition--type Node = EnhancedKey--type NodeEdges = (Node, [Node])--type Graph = [NodeEdges]--getFragment :: Reference -> FragmentLib -> Validation Fragment-getFragment Reference {referenceName, referencePosition} lib =-  case 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} =-  if fragmentType `elem` targets'-    then pure fragment-    else Left $-         cannotBeSpreadOnType key' fragmentType position' (T.concat targets')--resolveSpread :: FragmentLib -> [Text] -> Reference -> Validation Fragment-resolveSpread fragments allowedTargets reference@Reference { referenceName-                                                           , referencePosition-                                                           } =-  getFragment reference fragments >>=-  castFragmentType (Just referenceName) referencePosition allowedTargets--usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node]-usedFragments fragments = concatMap findAllUses-  where-    findAllUses :: (Text, RawSelection) -> [Node]-    findAllUses (_, RawSelectionSet RawSelection' {rawSelectionRec}) =-      concatMap findAllUses rawSelectionRec-    findAllUses (_, RawAlias {rawAliasSelection}) =-      concatMap findAllUses [rawAliasSelection]-    findAllUses (_, InlineFragment Fragment {fragmentSelection}) =-      concatMap findAllUses fragmentSelection-    findAllUses (_, RawSelectionField {}) = []-    findAllUses (_, Spread Reference {referenceName, referencePosition}) =-      [EnhancedKey referenceName referencePosition] <> searchInFragment-      where-        searchInFragment =-          maybe-            []-            (concatMap findAllUses . fragmentSelection)-            (lookup referenceName fragments)--scanForSpread :: (Text, RawSelection) -> [Node]-scanForSpread (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) =-  concatMap scanForSpread selection'-scanForSpread (_, RawAlias {rawAliasSelection = selection'}) =-  concatMap scanForSpread [selection']-scanForSpread (_, InlineFragment Fragment {fragmentSelection = selection'}) =-  concatMap scanForSpread selection'-scanForSpread (_, RawSelectionField {}) = []-scanForSpread (_, Spread Reference { referenceName = name'-                                   , referencePosition = position'-                                   }) = [EnhancedKey name' position']--validateFragment :: DataTypeLib -> (Text, Fragment) -> Validation NodeEdges-validateFragment lib (fName, Fragment { fragmentSelection-                                      , fragmentType-                                      , fragmentPosition-                                      }) =-  existsObjectType fragmentPosition fragmentType lib >>-  pure-    ( EnhancedKey fName fragmentPosition-    , concatMap scanForSpread fragmentSelection)--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]
− src/Data/Morpheus/Validation/Input/Enum.hs 
@@ -1,16 +0,0 @@-{-# 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'
− src/Data/Morpheus/Validation/Input/Object.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# 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 INPUT UNION-    -- TODO: Validate Union-    validate [] (UnionKind DataType {typeData}) (_, Object fields) =-      return (Object fields)-    {-- 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'
+ src/Data/Morpheus/Validation/Internal/Utils.hs view
@@ -0,0 +1,86 @@+module Data.Morpheus.Validation.Internal.Utils+  ( differKeys+  , existsObjectType+  , lookupType+  , getInputType+  , lookupField+  , checkNameCollision+  , checkForUnknownKeys+  , isEqOrStricter+  , VALIDATION_MODE(..)+  ) 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 (..), DataTypeWrapper (..))+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++data VALIDATION_MODE+  = WITHOUT_VARIABLES+  | FULL_VALIDATION+  deriving (Eq, Show)++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' (inputUnion lib) of+        Just x -> pure (UnionKind x)+        Nothing ->+          case lookup typeName' (leaf lib) of+            Nothing               -> Left error'+            Just (BaseScalar x)   -> pure (ScalarKind x)+            Just (CustomScalar 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] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]+checkNameCollision enhancedKeys errorGenerator =+  case enhancedKeys \\ removeDuplicates enhancedKeys 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'++isEqOrStricter :: [DataTypeWrapper] -> [DataTypeWrapper] -> Bool+isEqOrStricter [] []                               = True+isEqOrStricter (NonNullType:xs1) (NonNullType:xs2) = isEqOrStricter xs1 xs2+isEqOrStricter (NonNullType:xs1) xs2               = isEqOrStricter xs1 xs2+isEqOrStricter (ListType:xs1) (ListType:xs2)       = isEqOrStricter xs1 xs2+isEqOrStricter _ _                                 = False
+ src/Data/Morpheus/Validation/Query/Arguments.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections  #-}++module Data.Morpheus.Validation.Query.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.Operation    (ValidVariables, Variable (..))+import           Data.Morpheus.Types.Internal.AST.RawSelection (RawArgument (..), RawArguments, Reference (..))+import           Data.Morpheus.Types.Internal.AST.Selection    (Argument (..), ArgumentOrigin (..), Arguments)+import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position)+import           Data.Morpheus.Types.Internal.Data             (DataArgument, DataField (..), DataInputField,+                                                                DataOutputField, DataTypeLib, isFieldNullable,+                                                                showWrappedType)+import           Data.Morpheus.Types.Internal.Validation       (Validation)+import           Data.Morpheus.Types.Internal.Value            (Value (Null))+import           Data.Morpheus.Validation.Internal.Utils       (checkForUnknownKeys, checkNameCollision, getInputType,+                                                                isEqOrStricter)+import           Data.Morpheus.Validation.Query.Input.Object   (validateInputValue)+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, ) . toArgument <$> lookupVar+      where+        toArgument argumentValue =+          Argument {argumentValue, argumentOrigin = VARIABLE, argumentPosition = referencePosition}+        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 && isEqOrStricter 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, fieldTypeWrappers} arg@(key, Argument {argumentValue, argumentPosition}) =+  getInputType fieldType lib (internalUnknownTypeMessage fieldType) >>= checkType >> pure arg+  where+    checkType type' =+      handleInputError key argumentPosition (validateInputValue lib [] fieldTypeWrappers type' (key, argumentValue))++validateArgument :: DataTypeLib -> Position -> Arguments -> (Text, DataArgument) -> Validation (Text, Argument)+validateArgument types argumentPosition requestArgs (key, arg) =+  case lookup key requestArgs of+    Nothing                                            -> handleNullable+    Just argument@Argument {argumentOrigin = VARIABLE} -> pure (key, argument) -- Variables are already checked in Variable Validation+    Just Argument {argumentValue = Null}               -> handleNullable+    Just argument                                      -> validateArgumentValue types arg (key, argument)+  where+    handleNullable+      | isFieldNullable arg = pure (key, Argument {argumentValue = Null, argumentOrigin = INLINE, argumentPosition})+      | otherwise = Left $ undefinedArgument (EnhancedKey key argumentPosition)++checkForUnknownArguments :: (Text, DataOutputField) -> Arguments -> Validation [(Text, DataInputField)]+checkForUnknownArguments (key, DataField {fieldArgs}) args =+  checkForUnknownKeys enhancedKeys fieldKeys argError >> checkNameCollision enhancedKeys argumentNameCollision >>+  pure fieldArgs+  where+    argError = unknownArguments key+    enhancedKeys = map argToKey args+    argToKey (key', Argument {argumentPosition}) = EnhancedKey key' argumentPosition+    fieldKeys = map fst fieldArgs++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
+ src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Query.Fragment+  ( validateFragments+  , castFragmentType+  , resolveSpread+  , getFragment+  ) where++import           Data.List                                     ((\\))+import           Data.Semigroup                                ((<>))+import           Data.Text                                     (Text)+import qualified Data.Text                                     as T (concat)++-- MORPHEUS+import           Data.Morpheus.Error.Fragment                  (cannotBeSpreadOnType, cannotSpreadWithinItself,+                                                                fragmentNameCollision, unknownFragment, unusedFragment)+import           Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..),+                                                                RawSelection' (..), Reference (..))+import           Data.Morpheus.Types.Internal.Base             (EnhancedKey (..), Position)+import           Data.Morpheus.Types.Internal.Data             (DataTypeLib)+import           Data.Morpheus.Types.Internal.Validation       (Validation)+import           Data.Morpheus.Validation.Internal.Utils       (checkNameCollision, existsObjectType)++validateFragments :: DataTypeLib -> FragmentLib -> [(Text, RawSelection)] -> Validation ()+validateFragments lib fragments operatorSel = validateNameCollision >> checkLoop >> checkUnusedFragments+  where+    validateNameCollision = checkNameCollision fragmentsKeys fragmentNameCollision+    checkUnusedFragments =+      case fragmentsKeys \\ usedFragments fragments operatorSel of+        []     -> return ()+        unused -> Left $ unusedFragment unused+    checkLoop = mapM (validateFragment lib) fragments >>= detectLoopOnFragments+    fragmentsKeys = map toEnhancedKey fragments+      where+        toEnhancedKey (key, Fragment {fragmentPosition}) = EnhancedKey key fragmentPosition++type Node = EnhancedKey++type NodeEdges = (Node, [Node])++type Graph = [NodeEdges]++getFragment :: Reference -> FragmentLib -> Validation Fragment+getFragment Reference {referenceName, referencePosition} lib =+  case 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} =+  if fragmentType `elem` targets'+    then pure fragment+    else Left $ cannotBeSpreadOnType key' fragmentType position' (T.concat targets')++resolveSpread :: FragmentLib -> [Text] -> Reference -> Validation Fragment+resolveSpread fragments allowedTargets reference@Reference {referenceName, referencePosition} =+  getFragment reference fragments >>= castFragmentType (Just referenceName) referencePosition allowedTargets++usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node]+usedFragments fragments = concatMap findAllUses+  where+    findAllUses :: (Text, RawSelection) -> [Node]+    findAllUses (_, RawSelectionSet RawSelection' {rawSelectionRec}) = concatMap findAllUses rawSelectionRec+    findAllUses (_, RawAlias {rawAliasSelection}) = concatMap findAllUses [rawAliasSelection]+    findAllUses (_, InlineFragment Fragment {fragmentSelection}) = concatMap findAllUses fragmentSelection+    findAllUses (_, RawSelectionField {}) = []+    findAllUses (_, Spread Reference {referenceName, referencePosition}) =+      [EnhancedKey referenceName referencePosition] <> searchInFragment+      where+        searchInFragment = maybe [] (concatMap findAllUses . fragmentSelection) (lookup referenceName fragments)++scanForSpread :: (Text, RawSelection) -> [Node]+scanForSpread (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) = concatMap scanForSpread selection'+scanForSpread (_, RawAlias {rawAliasSelection = selection'}) = concatMap scanForSpread [selection']+scanForSpread (_, InlineFragment Fragment {fragmentSelection = selection'}) = concatMap scanForSpread selection'+scanForSpread (_, RawSelectionField {}) = []+scanForSpread (_, Spread Reference {referenceName = name', referencePosition = position'}) =+  [EnhancedKey name' position']++validateFragment :: DataTypeLib -> (Text, Fragment) -> Validation NodeEdges+validateFragment lib (fName, Fragment {fragmentSelection, fragmentType, fragmentPosition}) =+  existsObjectType fragmentPosition fragmentType lib >>+  pure (EnhancedKey fName fragmentPosition, concatMap scanForSpread fragmentSelection)++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]
+ src/Data/Morpheus/Validation/Query/Input/Enum.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Validation.Query.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'
+ src/Data/Morpheus/Validation/Query/Input/Object.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Validation.Query.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.Query.Input.Enum  (validateEnum)+import           Data.Morpheus.Validation.Internal.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 INPUT UNION+    -- TODO: Validate Union+    validate [] (UnionKind DataType {typeData}) (_, Object fields) = return (Object fields)+    {-- 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'
+ src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++module Data.Morpheus.Validation.Query.Selection+  ( validateSelectionSet+  ) where++import           Data.Morpheus.Error.Selection                  (cannotQueryField, duplicateQuerySelections,+                                                                 hasNoSubfields, subfieldsNotSelected)+import           Data.Morpheus.Error.Variable                   (unknownType)+import           Data.Morpheus.Types.Internal.AST.Operation     (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 (..), DataFullType (..), DataOutputObject,+                                                                 DataType (..), DataTypeLib (..), allDataTypes)+import           Data.Morpheus.Types.Internal.Validation        (Validation)+import           Data.Morpheus.Validation.Internal.Utils        (checkNameCollision, lookupType)+import           Data.Morpheus.Validation.Query.Arguments       (validateArguments)+import           Data.Morpheus.Validation.Query.Fragment        (castFragmentType, resolveSpread)+import           Data.Morpheus.Validation.Query.Utils.Selection (lookupFieldAsSelectionSet, lookupSelectionField,+                                                                 lookupUnionTypes)+import           Data.Text                                      (Text)++checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet+checkDuplicatesOn DataType {typeName = name'} keys = checkNameCollision enhancedKeys selError >> pure keys+  where+    selError = 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 ref) = resolveSpread fragments typeNames ref >>= packFragment+    splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) =+      return+        ( []+        , [ ( "__typename"+            , Selection {selectionRec = SelectionField, selectionArguments = [], selectionPosition = position'})+          ])+    splitFrag (key, RawSelectionSet RawSelection' {rawSelectionPosition}) =+      Left $ cannotQueryField key type' rawSelectionPosition+    splitFrag (key, RawSelectionField RawSelection' {rawSelectionPosition}) =+      Left $ cannotQueryField key type' rawSelectionPosition+    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 = filter notEmpty $ map categorizeType types+  where+    notEmpty = (0 /=) . length . snd+    categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])+    categorizeType datatype = (datatype, filter matches fragments)+      where+        matches fragment = fragmentType fragment == typeName datatype++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 {<SelectionA>}+      ...B on T2 {<SelectionB>}+      ...C on T2 {<SelectionC>}+      will be become : [+          ("T1",[<SelectionA>]),+          ("T2",[<SelectionB>,<SelectionC>])+      ]+ -}++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'+          -- validate field Argument -----+          arguments <-+            validateArguments+              lib+              operatorName+              variables+              (key, selectionField)+              rawSelectionPosition+              rawSelectionArguments+          -- check field Type existence  -----+          fieldDataType <-+            lookupType+              (unknownType (fieldType selectionField) rawSelectionPosition)+              (allDataTypes lib)+              (fieldType selectionField)+          return (selectionField, fieldDataType, 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', dataType, arguments) <- getValidationData key' fullRawSelection'+          case dataType of+            Union _ -> 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')+            OutputObject _ -> do+              fieldType' <- lookupFieldAsSelectionSet position' key' lib dataField'+              __validate fieldType' rawSelectors >>= returnSelection arguments . SelectionSet+                 -- DataFullType+                       --   = Leaf DataLeaf+                       --   | InputObject DataInputObject+                       --   | InputUnion DataUnion+            _ -> 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}) = do+          (dataField, datatype, arguments') <- getValidationData key' fullRawSelection'+          isLeaf datatype dataField+          pure+            [ ( key'+              , Selection+                  { selectionArguments = arguments'+                  , selectionRec = SelectionField+                  , selectionPosition = rawSelectionPosition+                  })+            ]+          where+            isLeaf (Leaf _) _              = Right ()+            isLeaf _ DataField {fieldType} = Left $ subfieldsNotSelected key' fieldType rawSelectionPosition+        validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment+        validateSelection (_, InlineFragment fragment') =+          castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment
+ src/Data/Morpheus/Validation/Query/Utils/Selection.hs view
@@ -0,0 +1,29 @@+module Data.Morpheus.Validation.Query.Utils.Selection+  ( lookupFieldAsSelectionSet+  , lookupSelectionField+  , lookupUnionTypes+  ) where++import           Data.Morpheus.Error.Selection           (cannotQueryField, hasNoSubfields)+import           Data.Morpheus.Types.Internal.Base       (Position)+import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataOutputField, DataOutputObject,+                                                          DataType (..), DataTypeLib (..))+import           Data.Morpheus.Types.Internal.Validation (Validation)+import           Data.Morpheus.Validation.Internal.Utils (lookupField, lookupType)+import           Data.Text                               (Text)++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'
+ src/Data/Morpheus/Validation/Query/Validation.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}++module Data.Morpheus.Validation.Query.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.Operation (Operation (..), OperationKind (..), RawOperation,+                                                             ValidOperation)+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.Internal.Utils    (VALIDATION_MODE)+import           Data.Morpheus.Validation.Query.Fragment    (validateFragments)+import           Data.Morpheus.Validation.Query.Selection   (validateSelectionSet)+import           Data.Morpheus.Validation.Query.Variable    (resolveOperationVariables)++getOperationDataType :: RawOperation -> DataTypeLib -> Validation DataOutputObject+getOperationDataType Operation {operationKind = QUERY} lib = pure $ snd $ query lib+getOperationDataType Operation {operationKind = MUTATION, operationPosition} lib =+  case mutation lib of+    Just (_, mutation') -> pure mutation'+    Nothing             -> Left $ mutationIsNotDefined operationPosition+getOperationDataType Operation {operationKind = SUBSCRIPTION, operationPosition} lib =+  case subscription lib of+    Just (_, subscription') -> pure subscription'+    Nothing                 -> Left $ subscriptionIsNotDefined operationPosition++validateRequest :: DataTypeLib -> VALIDATION_MODE -> GQLQueryRoot -> Validation ValidOperation+validateRequest lib validationMode GQLQueryRoot { fragments+                                                , inputVariables+                                                , operation = rawOperation@Operation { operationName+                                                                                     , operationKind+                                                                                     , operationSelection+                                                                                     , operationPosition+                                                                                     }+                                                } = do+  operationDataType <- getOperationDataType rawOperation lib+  variables <- resolveOperationVariables lib fragments (fromList inputVariables) validationMode rawOperation+  validateFragments lib fragments operationSelection+  selection <- validateSelectionSet lib fragments operationName variables operationDataType operationSelection+  pure $ Operation {operationName, operationKind, operationArgs = [], operationSelection = selection, operationPosition}
+ src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Validation.Query.Variable+  ( resolveOperationVariables+  ) 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.Operation    (Operation (..), RawOperation, 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.Internal.Utils       (VALIDATION_MODE (..), getInputType)+import           Data.Morpheus.Validation.Query.Fragment       (getFragment)+import           Data.Morpheus.Validation.Query.Input.Object   (validateInputValue)+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++resolveOperationVariables ::+     DataTypeLib -> FragmentLib -> Variables -> VALIDATION_MODE -> RawOperation -> Validation ValidVariables+resolveOperationVariables typeLib lib root validationMode Operation {operationName, operationSelection, operationArgs} = do+  allVariableReferences lib [operationSelection] >>= checkUnusedVariables+  mapM (lookupAndValidateValueOnBody typeLib root validationMode) operationArgs+  where+    varToKey :: (Text, Variable ()) -> EnhancedKey+    varToKey (key', Variable {variablePosition}) = EnhancedKey key' variablePosition+    --+    checkUnusedVariables :: [EnhancedKey] -> Validation ()+    checkUnusedVariables refs =+      case map varToKey operationArgs \\ refs of+        []      -> pure ()+        unused' -> Left $ unusedVariables operationName unused'++lookupAndValidateValueOnBody ::+     DataTypeLib -> Variables -> VALIDATION_MODE -> (Text, Variable ()) -> Validation (Text, Variable Value)+lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType+                                                                                     , variablePosition+                                                                                     , isVariableRequired+                                                                                     , variableTypeWrappers+                                                                                     }) =+  toVariable <$>+  (getVariableType variableType variablePosition typeLib >>=+   checkType (validationMode /= WITHOUT_VARIABLES && isVariableRequired))+  where+    toVariable (varKey, variableValue) = (varKey, var {variableValue})+    ------------------------------------------------------------------+    checkType True varType =+      lookupVariable bodyVariables key (uninitializedVariable variablePosition variableType) >>= validator varType+    checkType False varType = maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)+    -----------------------------------------------------------------------------------------------+    validator varType varValue =+      handleInputError key variablePosition $ validateInputValue typeLib [] variableTypeWrappers varType (key, varValue)
− src/Data/Morpheus/Validation/Selection.hs 
@@ -1,226 +0,0 @@-{-# 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, subfieldsNotSelected)-import           Data.Morpheus.Error.Variable                  (unknownType)-import           Data.Morpheus.Types.Internal.AST.Operation    (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 (..), DataFullType (..), DataOutputObject,-                                                                DataType (..), DataTypeLib (..), allDataTypes)-import           Data.Morpheus.Types.Internal.Validation       (Validation)-import           Data.Morpheus.Validation.Arguments            (validateArguments)-import           Data.Morpheus.Validation.Fragment             (castFragmentType, resolveSpread)-import           Data.Morpheus.Validation.Utils.Selection      (lookupFieldAsSelectionSet, lookupSelectionField,-                                                                lookupUnionTypes)-import           Data.Morpheus.Validation.Utils.Utils          (checkNameCollision, lookupType)-import           Data.Text                                     (Text)--checkDuplicatesOn :: DataOutputObject -> SelectionSet -> Validation SelectionSet-checkDuplicatesOn DataType {typeName = name'} keys =-  checkNameCollision enhancedKeys selError >> pure keys-  where-    selError = 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 ref) =-      resolveSpread fragments typeNames ref >>= packFragment-    splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) =-      return-        ( []-        , [ ( "__typename"-            , Selection-                { selectionRec = SelectionField-                , selectionArguments = []-                , selectionPosition = position'-                })-          ])-    splitFrag (key, RawSelectionSet RawSelection' {rawSelectionPosition}) =-      Left $ cannotQueryField key type' rawSelectionPosition-    splitFrag (key, RawSelectionField RawSelection' {rawSelectionPosition}) =-      Left $ cannotQueryField key type' rawSelectionPosition-    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 = filter notEmpty $ map categorizeType types-  where-    notEmpty = (0 /=) . length . snd-    categorizeType :: DataOutputObject -> (DataOutputObject, [Fragment])-    categorizeType datatype = (datatype, filter matches fragments)-      where-        matches fragment = fragmentType fragment == typeName datatype--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 {<SelectionA>}-      ...B on T2 {<SelectionB>}-      ...C on T2 {<SelectionC>}-      will be become : [-          ("T1",[<SelectionA>]),-          ("T2",[<SelectionB>,<SelectionC>])-      ]- -}--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'-          -- validate field Argument ------          arguments <--            validateArguments-              lib-              operatorName-              variables-              (key, selectionField)-              rawSelectionPosition-              rawSelectionArguments-          -- check field Type existence  ------          fieldDataType <--            lookupType-              (unknownType (fieldType selectionField) rawSelectionPosition)-              (allDataTypes lib)-              (fieldType selectionField)-          return (selectionField, fieldDataType, 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', dataType, arguments) <--            getValidationData key' fullRawSelection'-          case dataType of-            Union _ -> 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')-            OutputObject _ -> do-              fieldType' <--                lookupFieldAsSelectionSet position' key' lib dataField'-              __validate fieldType' rawSelectors >>=-                returnSelection arguments . SelectionSet-                 -- DataFullType-                       --   = Leaf DataLeaf-                       --   | InputObject DataInputObject-                       --   | InputUnion DataUnion-            _ -> 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}) = do-          (dataField, datatype, arguments') <--            getValidationData key' fullRawSelection'-          isLeaf datatype dataField-          pure-            [ ( key'-              , Selection-                  { selectionArguments = arguments'-                  , selectionRec = SelectionField-                  , selectionPosition = rawSelectionPosition-                  })-            ]-          where-            isLeaf (Leaf _) _ = Right ()-            isLeaf _ DataField {fieldType} =-              Left $ subfieldsNotSelected key' fieldType rawSelectionPosition-        validateSelection (_, Spread reference') =-          resolveSpread fragments' [typeName'] reference' >>= validateFragment-        validateSelection (_, InlineFragment fragment') =-          castFragmentType-            Nothing-            (fragmentPosition fragment')-            [typeName']-            fragment' >>=-          validateFragment
− src/Data/Morpheus/Validation/Utils/Selection.hs 
@@ -1,44 +0,0 @@-module Data.Morpheus.Validation.Utils.Selection-  ( lookupFieldAsSelectionSet-  , lookupSelectionField-  , lookupUnionTypes-  ) where--import           Data.Morpheus.Error.Selection           (cannotQueryField, hasNoSubfields)-import           Data.Morpheus.Types.Internal.Base       (Position)-import           Data.Morpheus.Types.Internal.Data       (DataField (..), DataOutputField, DataOutputObject,-                                                          DataType (..), DataTypeLib (..))-import           Data.Morpheus.Types.Internal.Validation (Validation)-import           Data.Morpheus.Validation.Utils.Utils    (lookupField, lookupType)-import           Data.Text                               (Text)--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'
− src/Data/Morpheus/Validation/Utils/Utils.hs 
@@ -1,85 +0,0 @@-module Data.Morpheus.Validation.Utils.Utils-  ( differKeys-  , existsObjectType-  , lookupType-  , getInputType-  , lookupField-  , checkNameCollision-  , checkForUnknownKeys-  , VALIDATION_MODE(..)-  ) 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--data VALIDATION_MODE-  = WITHOUT_VARIABLES-  | FULL_VALIDATION-  deriving (Eq, Show)--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' (inputUnion lib) of-        Just x -> pure (UnionKind x)-        Nothing ->-          case lookup typeName' (leaf lib) of-            Nothing               -> Left error'-            Just (BaseScalar x)   -> pure (ScalarKind x)-            Just (CustomScalar 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] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey]-checkNameCollision enhancedKeys errorGenerator =-  case enhancedKeys \\ removeDuplicates enhancedKeys 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'
− src/Data/Morpheus/Validation/Validation.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# 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.Operation (Operation (..), OperationKind (..), RawOperation,-                                                             ValidOperation)-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.Utils.Utils       (VALIDATION_MODE)-import           Data.Morpheus.Validation.Variable          (resolveOperationVariables)--getOperationDataType ::-     RawOperation -> DataTypeLib -> Validation DataOutputObject-getOperationDataType Operation {operationKind = QUERY} lib =-  pure $ snd $ query lib-getOperationDataType Operation {operationKind = MUTATION, operationPosition} lib =-  case mutation lib of-    Just (_, mutation') -> pure mutation'-    Nothing             -> Left $ mutationIsNotDefined operationPosition-getOperationDataType Operation {operationKind = SUBSCRIPTION, operationPosition} lib =-  case subscription lib of-    Just (_, subscription') -> pure subscription'-    Nothing                 -> Left $ subscriptionIsNotDefined operationPosition--validateRequest ::-     DataTypeLib -> VALIDATION_MODE -> GQLQueryRoot -> Validation ValidOperation-validateRequest lib validationMode GQLQueryRoot { fragments-                                                , inputVariables-                                                , operation = rawOperation@Operation { operationName-                                                                                     , operationKind-                                                                                     , operationSelection-                                                                                     , operationPosition-                                                                                     }-                                                } = do-  operationDataType <- getOperationDataType rawOperation lib-  variables <--    resolveOperationVariables-      lib-      fragments-      (fromList inputVariables)-      validationMode-      rawOperation-  validateFragments lib fragments operationSelection-  selection <--    validateSelectionSet-      lib-      fragments-      operationName-      variables-      operationDataType-      operationSelection-  pure $-    Operation-      { operationName-      , operationKind-      , operationArgs = []-      , operationSelection = selection-      , operationPosition-      }
− src/Data/Morpheus/Validation/Variable.hs 
@@ -1,130 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Validation.Variable-  ( resolveOperationVariables-  ) 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.Operation    (Operation (..), RawOperation, 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.Fragment             (getFragment)-import           Data.Morpheus.Validation.Input.Object         (validateInputValue)-import           Data.Morpheus.Validation.Utils.Utils          (VALIDATION_MODE (..), 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--resolveOperationVariables ::-     DataTypeLib-  -> FragmentLib-  -> Variables-  -> VALIDATION_MODE-  -> RawOperation-  -> Validation ValidVariables-resolveOperationVariables typeLib lib root validationMode Operation { operationName-                                                                    , operationSelection-                                                                    , operationArgs-                                                                    } = do-  allVariableReferences lib [operationSelection] >>= checkUnusedVariables-  mapM (lookupAndValidateValueOnBody typeLib root validationMode) operationArgs-  where-    varToKey :: (Text, Variable ()) -> EnhancedKey-    varToKey (key', Variable {variablePosition}) =-      EnhancedKey key' variablePosition-    ---    checkUnusedVariables :: [EnhancedKey] -> Validation ()-    checkUnusedVariables refs =-      case map varToKey operationArgs \\ refs of-        []      -> pure ()-        unused' -> Left $ unusedVariables operationName unused'--lookupAndValidateValueOnBody ::-     DataTypeLib-  -> Variables-  -> VALIDATION_MODE-  -> (Text, Variable ())-  -> Validation (Text, Variable Value)-lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType-                                                                                     , variablePosition-                                                                                     , isVariableRequired-                                                                                     , variableTypeWrappers-                                                                                     }) =-  toVariable <$>-  (getVariableType variableType variablePosition typeLib >>=-   checkType (validationMode /= WITHOUT_VARIABLES && isVariableRequired))-  where-    toVariable (varKey, variableValue) = (varKey, var {variableValue})-    -------------------------------------------------------------------    checkType True varType =-      lookupVariable-        bodyVariables-        key-        (uninitializedVariable variablePosition variableType) >>=-      validator varType-    checkType False varType =-      maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)-    ------------------------------------------------------------------------------------------------    validator varType varValue =-      handleInputError key variablePosition $-      validateInputValue typeLib [] variableTypeWrappers varType (key, varValue)
test/Feature/Holistic/API.hs view
@@ -7,13 +7,12 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (ENUM, INPUT_OBJECT, OBJECT, SCALAR, UNION)-import           Data.Morpheus.Types        (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..),-                                             IORes, IOSubRes, ScalarValue (..))-import           Data.Text                  (Text)-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (ENUM, INPUT_OBJECT, OBJECT, SCALAR, UNION)+import           Data.Morpheus.Types (Event (..), GQLRequest, GQLResponse, GQLRootResolver (..), GQLScalar (..),+                                      GQLType (..), ID (..), IORes, IOSubRes, ScalarValue (..))+import           Data.Text           (Text)+import           GHC.Generics        (Generic)  data TestEnum   = EnumA@@ -121,7 +120,7 @@   } deriving (Generic)  resolveAddress :: a -> IORes Address-resolveAddress _ = return Address {city = "", houseNumber = 1, street = const $ return Nothing}+resolveAddress _ = return Address {city = "", houseNumber = 0, street = const $ return Nothing}  resolveUser :: a -> IORes User resolveUser _ =@@ -137,5 +136,5 @@     , subscriptionResolver = return Subscription {newUser = const $ Event [EVENT] resolveUser}     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Holistic/cases.json view
@@ -166,5 +166,13 @@   {     "path": "introspection/kinds/UNION",     "description": "test introspection of UNION kind"+  },+  {+    "path": "parsing/singleLineComments",+    "description": "parses single line comments"+  },+  {+    "path": "parsing/multilineComments",+    "description": "parses multiline comments"   } ]
test/Feature/Holistic/parsing/invalidFields/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', body, digit, entry, letter, maybeArguments, or white space\n",+      "message": "offset=26:\nunexpected '<'\nexpecting \"\"\"\"\", '#', ',', '_', '}', body, digit, entry, letter, maybeArguments, or white space\n",       "locations": [         {           "line": 1,
test/Feature/Holistic/parsing/invalidNotNullOperator/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=20:\nunexpected '@'\nexpecting '!', '#', ']', '_', digit, letter, or white space\n",+      "message": "offset=20:\nunexpected '@'\nexpecting \"\"\"\"\", '!', '#', ']', '_', digit, letter, or white space\n",       "locations": [         {           "line": 1,
test/Feature/Holistic/parsing/missingCloseBrace/response.json view
@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=66:\nunexpected end of input\nexpecting '#', ',', '}', entry, or white space\n",+      "message": "offset=66:\nunexpected end of input\nexpecting \"\"\"\"\", '#', ',', '}', entry, or white space\n",       "locations": [         {           "line": 5,
+ test/Feature/Holistic/parsing/multilineComments/query.gql view
@@ -0,0 +1,131 @@+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""++"""+"""++"""+++"""+++"""+   comment with tabs++"""+++query+""" +%&+%wer""g ''Comme+"""+GetUsers """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" ( """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" $v: """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+ [ """ somejhgja """ Int """ 343 """ ! """ 343 """  ] # starting Comment'' # starting Comment''+) {+  user {+    """ %&+%(//+     %& ''Comme"""++    email2: """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" email """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+    name """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""++    address( """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+      coordinates: {+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""        longitude:  0 # starting Comment''+        latitude: "" # starting Comment'' # starting Comment'' # starting Comment''+      }+    ) """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" {+      """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+      # starting Comment''+      ...City+    }+    office """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" (+      zipCode: $v # starting Comment''+      cityID: EnumA +    ) """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" {+      houseNumber """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""++      ... on Address {+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+        city """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+      }+    }+    """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+  }+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""}+# starting Comment''+# starting Comment''++fragment City  on  Address """ %&+%(//+     %& %(//+%&%&  # startin""g ''Comme""" {+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+  city""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""+}+""" %&+%(//+     %& %(//+%&%&  # startin""g ''Comme"""
+ test/Feature/Holistic/parsing/multilineComments/response.json view
@@ -0,0 +1,15 @@+{+  "data": {+    "user": {+      "email2": "",+      "name": "testName",+      "address": {+        "city": ""+      },+      "office": {+        "houseNumber": 0,+        "city": ""+      }+    }+  }+}
+ test/Feature/Holistic/parsing/singleLineComments/query.gql view
@@ -0,0 +1,57 @@+# starting Comment''+# starting Comment''+query # starting Comment''+# starting Comment''+GetUsers( # starting Comment'' # starting Comment''+  $v: [# starting Comment'' # starting Comment''+  Int!] # starting Comment'' # starting Comment''+) {+  user {+    # starting Comment''+    # %&%(//+    # %&%(//+    email2: email # starting Comment'' # %&%(// # starting Comment''+    name # starting Comment''+    # starting Comment''+    # starting Comment''+    # starting Comment''++    address( # starting Comment'' # %&%(//+      coordinates: {+        # %&%(//+        longitude: 0 # starting Comment''+        latitude: "" # starting Comment'' # starting Comment'' # starting Comment''+      }+    ) {+      # starting Comment''+      ...City+    }+    office(+      zipCode: $v # starting Comment''+      cityID: EnumA # starting Comment'' # starting Comment''+    ) {+      houseNumber # starting Comment''+      # starting Comment''++      ... on Address {+        # starting Comment''++        city # starting Comment''+        # starting Comment''+        # starting Comment''+      }+    }+    # starting Comment''+  }+  # starting Comment''+}+# starting Comment''+# starting Comment''++fragment City on Address {+  # starting Comment''+  # starting Comment''+  city # starting Comment''+}+# starting Comment''+# starting Comment''
+ test/Feature/Holistic/parsing/singleLineComments/response.json view
@@ -0,0 +1,15 @@+{+  "data": {+    "user": {+      "email2": "",+      "name": "testName",+      "address": {+        "city": ""+      },+      "office": {+        "houseNumber": 0,+        "city": ""+      }+    }+  }+}
test/Feature/Input/Enum/API.hs view
@@ -7,11 +7,10 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (ENUM)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes)-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (ENUM)+import           Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes)+import           GHC.Generics        (Generic)  data TwoCon   = LA@@ -67,5 +66,5 @@     , subscriptionResolver = return ()     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/InputType/API.hs view
@@ -7,12 +7,11 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (OBJECT)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes)-import           Data.Text                  (Text)-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (OBJECT)+import           Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes)+import           Data.Text           (Text)+import           GHC.Generics        (Generic)  data F1Args = F1Args   { arg1 :: Text@@ -44,5 +43,5 @@     , subscriptionResolver = return ()     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Schema/API.hs view
@@ -7,13 +7,12 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (OBJECT)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..))-import           Data.Text                  (Text)-import qualified Feature.Schema.A2          as A2 (A (..))-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (OBJECT)+import           Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..))+import           Data.Text           (Text)+import qualified Feature.Schema.A2   as A2 (A (..))+import           GHC.Generics        (Generic)  data A = A   { aText :: Text@@ -36,5 +35,5 @@     , subscriptionResolver = return ()     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/UnionType/API.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies      #-}@@ -8,12 +7,11 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (OBJECT, UNION)-import           Data.Morpheus.Types        (GQLRootResolver (..), GQLType (..), IORes)-import           Data.Text                  (Text)-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (OBJECT, UNION)+import           Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes)+import           Data.Text           (Text)+import           GHC.Generics        (Generic)  instance GQLType A where   type KIND A = OBJECT@@ -63,5 +61,5 @@     , subscriptionResolver = return ()     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/WrappedTypeName/API.hs view
@@ -7,13 +7,13 @@   ( api   ) where -import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus              (interpreter)-import           Data.Morpheus.Kind         (OBJECT)-import           Data.Morpheus.Types        (Event (..), GQLRootResolver (..), GQLType (..), IOMutRes, IORes, IOSubRes)-import           Data.Text                  (Text)-import           Data.Typeable              (Typeable)-import           GHC.Generics               (Generic)+import           Data.Morpheus       (interpreter)+import           Data.Morpheus.Kind  (OBJECT)+import           Data.Morpheus.Types (Event (..), GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IOMutRes,+                                      IORes, IOSubRes)+import           Data.Text           (Text)+import           Data.Typeable       (Typeable)+import           GHC.Generics        (Generic)  instance Typeable a => GQLType (WA a) where   type KIND (WA a) = OBJECT@@ -67,5 +67,5 @@             }     } -api :: ByteString -> IO ByteString+api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Lib.hs view
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy       as L (readFile) import           Data.ByteString.Lazy.Char8 (ByteString) import           Data.Maybe                 (fromMaybe)+import           Data.Morpheus.Types        (GQLResponse (..)) import           Data.Text                  (Text, unpack)  path :: Text -> String@@ -23,8 +24,8 @@ resLib :: Text -> String resLib x = path x ++ "/response.json" -maybeVariables :: Text -> IO ByteString-maybeVariables x = L.readFile (path x ++ "/variables.json") <|> return "{}"+maybeVariables :: Text -> IO (Maybe Value)+maybeVariables x = decode <$> (L.readFile (path x ++ "/variables.json") <|> return "{}")  getGQLBody :: Text -> IO ByteString getGQLBody p = L.readFile (gqlLib p)
test/TestFeature.hs view
@@ -1,14 +1,19 @@ {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module TestFeature   ( testFeature   ) where -import           Data.Aeson                 (FromJSON, decode, encode)+import qualified Data.Text.Lazy             as LT (toStrict)+import           Data.Text.Lazy.Encoding    (decodeUtf8)++import           Data.Aeson                 (FromJSON, Value, decode, encode) import           Data.ByteString.Lazy.Char8 (ByteString)-import qualified Data.ByteString.Lazy.Char8 as LB (concat, pack, unpack)+import qualified Data.ByteString.Lazy.Char8 as LB (unpack)+import           Data.Morpheus.Types        (GQLRequest (..), GQLResponse (..)) import           Data.Semigroup             ((<>)) import           Data.Text                  (Text, unpack) import qualified Data.Text                  as T (concat)@@ -17,33 +22,31 @@ 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', "}"]+packGQLRequest :: ByteString -> Maybe Value -> GQLRequest+packGQLRequest queryBS variables =+  GQLRequest {operationName = Nothing, query = LT.toStrict $ decodeUtf8 queryBS, 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'+testFeature :: (GQLRequest -> IO GQLResponse) -> 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+testByFiles :: (GQLRequest -> IO GQLResponse) -> Case -> IO TestTree+testByFiles testApi Case {path, description} = do+  testCaseQuery <- getGQLBody path+  testCaseVariables <- maybeVariables path+  expectedResponse <- getResponseBody path+  actualResponse <- encode <$> testApi (packGQLRequest testCaseQuery testCaseVariables)+  case decode actualResponse 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+    Just response -> return $ testCase (unpack path ++ " | " ++ description) $ customTest expectedResponse response+      where customTest expected value+              | expected == value = return ()+              | otherwise =+                assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse