diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Daviti Nalchevanidze + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# Morpheus GraphQL Core + +core Functionalities of Morpheus GraphQL, can be used to build GraphQL server, client .. + +- parser +- validar +- api + +## Build GraphQL api with Core + +```hs +getSchema :: Monad m => ResponseStream e m Schema +getSchema = + fromList + [dsl| + type Query { + deity(name: String): Deity! + } + + type Deity { + name: String! + power: [String!]! + } +|] + +resolver :: Monad m => RootResModel e m +resolver = + RootResModel + { query = + pure $ + mkObject + "Query" + [("deity", resolveDeity)], + mutation = pure mkNull, + subscription = pure mkNull + } + +resolveDeity :: (WithOperation o, Monad m) => Resolver o e m (ResModel o e m) +resolveDeity = + pure $ + mkObject + "Deity" + [ ("name", pure $ mkString "Morpheus"), + ("power", pure $ mkList [mkString "Shapeshifting"]) + ] + +api :: GQLRequest -> ResponseStream e Identity (Value VALID) +api request = do + schema <- getSchema + runApi schema resolver request +``` diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,13 @@ +# Changelog + +## 0.12.0 - 21.05.2020 + +## New features + +- parser supports implemnets interfaces seperated with empty spaces + + ```gql + type T implements A , B C & D { + ``` + +- introspection can render interfaces diff --git a/morpheus-graphql-core.cabal b/morpheus-graphql-core.cabal new file mode 100644 --- /dev/null +++ b/morpheus-graphql-core.cabal @@ -0,0 +1,146 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4a337fa1d88f2e1ca1eb76ec72c4bd0e5e91ef67626a02682384994f6731d446 + +name: morpheus-graphql-core +version: 0.12.0 +synopsis: Morpheus GraphQL Core +description: Build GraphQL APIs with your favourite functional language! +category: web, graphql +homepage: https://morpheusgraphql.com +bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues +author: Daviti Nalchevanidze +maintainer: d.nalchevanidze@gmail.com +copyright: (c) 2019 Daviti Nalchevanidze +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + changelog.md + README.md +data-files: + test/interface/query.gql + test/schema/validation/interface/fail/schema.gql + test/schema/validation/interface/ok/schema.gql + test/simple/query.gql + test/interface/response.json + test/schema/validation/interface/fail/response.json + test/schema/validation/interface/ok/response.json + test/simple/response.json + +source-repository head + type: git + location: https://github.com/nalchevanidze/morpheus-graphql + +library + exposed-modules: + Data.Morpheus.Core + Data.Morpheus.QuasiQuoter + Data.Morpheus.Error + Data.Morpheus.Internal.TH + Data.Morpheus.Internal.Utils + Data.Morpheus.Types.Internal.AST + Data.Morpheus.Types.IO + Data.Morpheus.Types.Internal.Resolving + other-modules: + Data.Morpheus.Error.Document.Interface + Data.Morpheus.Error.Fragment + Data.Morpheus.Error.Input + Data.Morpheus.Error.Internal + Data.Morpheus.Error.NameCollision + Data.Morpheus.Error.Operation + Data.Morpheus.Error.Schema + Data.Morpheus.Error.Selection + Data.Morpheus.Error.Utils + Data.Morpheus.Error.Variable + Data.Morpheus.Error.Warning + Data.Morpheus.Parser + Data.Morpheus.Parsing.Document.TypeSystem + Data.Morpheus.Parsing.Internal.Arguments + Data.Morpheus.Parsing.Internal.Internal + Data.Morpheus.Parsing.Internal.Pattern + Data.Morpheus.Parsing.Internal.Terms + Data.Morpheus.Parsing.Internal.Value + Data.Morpheus.Parsing.JSONSchema.Parse + Data.Morpheus.Parsing.JSONSchema.Types + Data.Morpheus.Parsing.Request.Operation + Data.Morpheus.Parsing.Request.Parser + Data.Morpheus.Parsing.Request.Selection + Data.Morpheus.Rendering.RenderGQL + Data.Morpheus.Rendering.RenderIntrospection + Data.Morpheus.Schema.Directives + Data.Morpheus.Schema.Schema + Data.Morpheus.Schema.SchemaAPI + Data.Morpheus.Schema.TypeKind + Data.Morpheus.Types.Internal.AST.Base + Data.Morpheus.Types.Internal.AST.Data + Data.Morpheus.Types.Internal.AST.MergeSet + Data.Morpheus.Types.Internal.AST.OrderedMap + Data.Morpheus.Types.Internal.AST.Selection + Data.Morpheus.Types.Internal.AST.TH + Data.Morpheus.Types.Internal.AST.Value + Data.Morpheus.Types.Internal.Resolving.Core + Data.Morpheus.Types.Internal.Resolving.Resolver + Data.Morpheus.Types.Internal.Validation + Data.Morpheus.Types.Internal.Validation.Error + Data.Morpheus.Types.Internal.Validation.Validator + Data.Morpheus.Types.SelectionTree + Data.Morpheus.Validation.Document.Validation + Data.Morpheus.Validation.Internal.Directive + Data.Morpheus.Validation.Internal.Value + Data.Morpheus.Validation.Query.Arguments + Data.Morpheus.Validation.Query.Fragment + Data.Morpheus.Validation.Query.Selection + Data.Morpheus.Validation.Query.UnionSelection + Data.Morpheus.Validation.Query.Validation + Data.Morpheus.Validation.Query.Variable + Paths_morpheus_graphql_core + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson >=1.4.4.0 && <=1.6 + , base >=4.7 && <5 + , bytestring >=0.10.4 && <0.11 + , hashable >=1.0.0 + , megaparsec >=7.0.0 && <9.0.0 + , scientific >=0.3.6.2 && <0.4 + , template-haskell >=2.0 && <=3.0 + , text >=1.2.3.0 && <1.3 + , th-lift-instances >=0.1.1 && <=0.3 + , transformers >=0.3.0.0 && <0.6 + , unordered-containers >=0.2.8.0 && <0.3 + , vector >=0.12.0.1 && <0.13 + default-language: Haskell2010 + +test-suite morpheus-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Lib + Schema + Paths_morpheus_graphql_core + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + aeson + , base >=4.7 && <5 + , bytestring >=0.10.4 && <0.11 + , hashable >=1.0.0 + , megaparsec >=7.0.0 && <9.0.0 + , morpheus-graphql-core + , scientific >=0.3.6.2 && <0.4 + , tasty + , tasty-hunit + , template-haskell >=2.0 && <=3.0 + , text >=1.2.3.0 && <1.3 + , th-lift-instances >=0.1.1 && <=0.3 + , transformers >=0.3.0.0 && <0.6 + , unordered-containers >=0.2.8.0 && <0.3 + , vector >=0.12.0.1 && <0.13 + default-language: Haskell2010 diff --git a/src/Data/Morpheus/Core.hs b/src/Data/Morpheus/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Core.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Core + ( runApi, + EventCon, + parseDSL, + parseFullGQLDocument, + parseGQLDocument, + decodeIntrospection, + parseTypeSystemDefinition, + parseTypeDefinitions, + validateRequest, + parseRequestWith, + validateSchema, + parseRequest, + RenderGQL (..), + SelectionTree (..), + ) +where + +-- MORPHEUS +import Control.Monad ((>=>)) +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.Morpheus.Internal.Utils + ( empty, + ) +import Data.Morpheus.Parser + ( parseRequest, + parseRequestWith, + parseTypeDefinitions, + parseTypeSystemDefinition, + ) +import Data.Morpheus.Parsing.JSONSchema.Parse + ( decodeIntrospection, + ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL (..), + ) +import Data.Morpheus.Schema.Schema (withSystemTypes) +import Data.Morpheus.Schema.SchemaAPI (withSystemFields) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + ) +import Data.Morpheus.Types.Internal.AST + ( Operation (..), + Schema (..), + Selection (..), + SelectionContent (..), + VALID, + Value, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Context (..), + Eventless, + GQLChannel (..), + ResponseStream, + ResultT (..), + RootResModel, + cleanEvents, + resultOr, + runRootResModel, + ) +import Data.Morpheus.Types.SelectionTree (SelectionTree (..)) +import Data.Morpheus.Validation.Document.Validation (validateSchema) +import Data.Morpheus.Validation.Query.Validation + ( validateRequest, + ) +import qualified Data.Text.Lazy as LT + ( toStrict, + ) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Typeable (Typeable) + +type EventCon event = + (Eq (StreamChannel event), Typeable event, GQLChannel event) + +runApi :: + forall event m. + (Monad m) => + Schema -> + RootResModel event m -> + GQLRequest -> + ResponseStream event m (Value VALID) +runApi inputSchema resModel request = do + ctx <- validRequest + model <- withSystemFields (schema ctx) resModel + runRootResModel model ctx + where + validRequest :: + Monad m => ResponseStream event m Context + validRequest = cleanEvents $ ResultT $ pure $ do + validSchema <- validateSchema inputSchema + schema <- withSystemTypes validSchema + operation <- parseRequestWith schema request + pure $ + Context + { schema, + operation, + currentTypeName = "Root", + currentSelection = + Selection + { selectionName = "Root", + selectionArguments = empty, + selectionPosition = operationPosition operation, + selectionAlias = Nothing, + selectionContent = SelectionSet (operationSelection operation), + selectionDirectives = [] + } + } + +parseDSL :: ByteString -> Either String Schema +parseDSL = resultOr (Left . show) pure . parseGQLDocument + +parseGQLDocument :: ByteString -> Eventless Schema +parseGQLDocument = parseTypeSystemDefinition . LT.toStrict . decodeUtf8 + +parseFullGQLDocument :: ByteString -> Eventless Schema +parseFullGQLDocument = parseGQLDocument >=> withSystemTypes diff --git a/src/Data/Morpheus/Error.hs b/src/Data/Morpheus/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error.hs @@ -0,0 +1,18 @@ +module Data.Morpheus.Error + ( errorMessage, + globalErrorMessage, + internalError, + internalTypeMismatch, + gqlWarnings, + renderGQLErrors, + deprecatedField, + ) +where + +import Data.Morpheus.Error.Internal +import Data.Morpheus.Error.Utils +import Data.Morpheus.Error.Warning + ( deprecatedField, + gqlWarnings, + renderGQLErrors, + ) diff --git a/src/Data/Morpheus/Error/Document/Interface.hs b/src/Data/Morpheus/Error/Document/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Document/Interface.hs @@ -0,0 +1,58 @@ +{-# 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.AST.Base + ( FieldName, + GQLError (..), + GQLErrors, + TypeName, + TypeRef, + msg, + ) +import Data.Semigroup ((<>)) + +unknownInterface :: TypeName -> GQLErrors +unknownInterface name = globalErrorMessage message + where + message = "Unknown Interface " <> msg name <> "." + +data ImplementsError + = UnexpectedType + { expectedType :: TypeRef, + foundType :: TypeRef + } + | UndefinedField + +partialImplements :: TypeName -> [(TypeName, FieldName, ImplementsError)] -> GQLErrors +partialImplements name = map impError + where + impError (interfaceName, key, errorType) = + GQLError + { message = message, + locations = [] + } + where + message = + "type " + <> msg name + <> " implements Interface " + <> msg interfaceName + <> " Partially," + <> detailedMessage errorType + detailedMessage UnexpectedType {expectedType, foundType} = + " on key " + <> msg key + <> " expected type " + <> msg expectedType + <> " found " + <> msg foundType + <> "." + detailedMessage UndefinedField = " key " <> msg key <> " not found ." diff --git a/src/Data/Morpheus/Error/Fragment.hs b/src/Data/Morpheus/Error/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Fragment.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Fragment + ( cannotSpreadWithinItself, + cannotBeSpreadOnType, + ) +where + +-- MORPHEUS +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + GQLError (..), + GQLErrors, + Position, + Ref (..), + TypeName, + msg, + msgSepBy, + ) +import Data.Semigroup ((<>)) + +{- + FRAGMENT: + type Experience { + experience ( lang: LANGUAGE ) : String , + date: String + } + fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." + fragment H on T1 { ...A} , fragment A on T { ...H } -> "Cannot spread fragment \"H\" within itself via A." + fragment H on D {...} -> "Unknown type \"D\"." + {...H} -> "Unknown fragment \"H\"." +-} + +cannotSpreadWithinItself :: [Ref] -> GQLErrors +cannotSpreadWithinItself fragments = [GQLError {message = text, locations = map refPosition fragments}] + where + text = + "Cannot spread fragment " + <> msg (refName $ head fragments) + <> " within itself via " + <> msgSepBy ", " (map refName fragments) + <> "." + +-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." +cannotBeSpreadOnType :: Maybe FieldName -> TypeName -> Position -> [TypeName] -> GQLErrors +cannotBeSpreadOnType key fragmentType position typeMembers = + errorMessage + position + text + where + text = + "Fragment " + <> getName key + <> "cannot be spread here as objects of type " + <> msgSepBy ", " typeMembers + <> " can never be of type " + <> msg fragmentType + <> "." + getName (Just x) = msg x <> " " + getName Nothing = "" diff --git a/src/Data/Morpheus/Error/Input.hs b/src/Data/Morpheus/Error/Input.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Input.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Input + ( typeViolation, + ) +where + +import Data.Morpheus.Types.Internal.AST + ( Message, + ResolvedValue, + TypeRef (..), + msg, + ) +import Data.Semigroup ((<>)) + +typeViolation :: TypeRef -> ResolvedValue -> Message +typeViolation expected found = + "Expected type " + <> msg expected + <> " found " + <> msg found + <> "." + +{- + ARGUMENTS: + type Experience { + experience ( lang: LANGUAGE ) : String , + date: String + } + + - required field !? + - experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"." + - experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla." + - experience( lang: 1 ) -> "Expected type LANGUAGE, found 1." + - experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".", + - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"." +-} diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Internal.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Internal + ( internalTypeMismatch, + internalError, + internalResolvingError, + ) +where + +-- MORPHEUS +import Data.Morpheus.Error.Utils (globalErrorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLErrors, + Message, + msg, + ) +import Data.Morpheus.Types.Internal.AST.Value + ( ValidValue, + ) +import Data.Morpheus.Types.Internal.Resolving.Core + ( Eventless, + Failure (..), + ) +import Data.Semigroup ((<>)) + +-- GQL:: if no mutation defined -> "Schema is not configured for mutations." +-- all kind internal error in development +internalError :: Message -> Eventless a +internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x + +internalResolvingError :: Message -> GQLErrors +internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>) + +-- if value is already validated but value has different type +internalTypeMismatch :: Message -> ValidValue -> Eventless a +internalTypeMismatch text jsType = + internalError $ "Type mismatch " <> text <> msg jsType diff --git a/src/Data/Morpheus/Error/NameCollision.hs b/src/Data/Morpheus/Error/NameCollision.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/NameCollision.hs @@ -0,0 +1,12 @@ +module Data.Morpheus.Error.NameCollision + ( NameCollision (..), + ) +where + +import Data.Morpheus.Internal.Utils (KeyOf (..)) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLError (..), + ) + +class NameCollision a where + nameCollision :: KEY a -> a -> GQLError diff --git a/src/Data/Morpheus/Error/Operation.hs b/src/Data/Morpheus/Error/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Operation.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Operation + ( mutationIsNotDefined, + subscriptionIsNotDefined, + ) +where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLErrors, + Position, + ) + +mutationIsNotDefined :: Position -> GQLErrors +mutationIsNotDefined position = + errorMessage position "Schema is not configured for mutations." + +subscriptionIsNotDefined :: Position -> GQLErrors +subscriptionIsNotDefined position = + errorMessage position "Schema is not configured for subscriptions." diff --git a/src/Data/Morpheus/Error/Schema.hs b/src/Data/Morpheus/Error/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Schema.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Schema + ( nameCollisionError, + schemaValidationError, + ) +where + +import Data.Morpheus.Error.Utils (globalErrorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLErrors, + Message, + TypeName, + msg, + ) +import Data.Semigroup ((<>)) + +schemaValidationError :: Message -> GQLErrors +schemaValidationError error' = + globalErrorMessage $ "Schema Validation Error, " <> error' + +nameCollisionError :: TypeName -> GQLErrors +nameCollisionError typeName = + schemaValidationError $ + "Name collision: " + <> msg typeName + <> " is used for different dataTypes in two separate modules" diff --git a/src/Data/Morpheus/Error/Selection.hs b/src/Data/Morpheus/Error/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Selection.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Selection + ( unknownSelectionField, + subfieldsNotSelected, + hasNoSubfields, + ) +where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + GQLErrors, + Position, + Ref (..), + TypeName, + msg, + ) +import Data.Semigroup ((<>)) + +-- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields." +hasNoSubfields :: Ref -> TypeName -> GQLErrors +hasNoSubfields (Ref selectionName position) typeName = errorMessage position text + where + text = + "Field " + <> msg selectionName + <> " must not have a selection since type " + <> msg typeName + <> " has no subfields." + +unknownSelectionField :: TypeName -> Ref -> GQLErrors +unknownSelectionField typeName Ref {refName, refPosition} = errorMessage refPosition text + where + text = + "Cannot query field " <> msg refName + <> " on type " + <> msg typeName + <> "." + +-- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"? +subfieldsNotSelected :: FieldName -> TypeName -> Position -> GQLErrors +subfieldsNotSelected fieldName typeName position = errorMessage position text + where + text = + "Field " <> msg fieldName <> " of type " + <> msg typeName + <> " must have a selection of subfields" diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Utils.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Utils + ( errorMessage, + globalErrorMessage, + badRequestError, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + pack, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLError (..), + GQLErrors, + Message, + Position (..), + ) +import Data.Semigroup ((<>)) + +errorMessage :: Position -> Message -> GQLErrors +errorMessage position message = [GQLError {message, locations = [position]}] + +globalErrorMessage :: Message -> GQLErrors +globalErrorMessage message = [GQLError {message, locations = []}] + +badRequestError :: String -> ByteString +badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack diff --git a/src/Data/Morpheus/Error/Variable.hs b/src/Data/Morpheus/Error/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Variable.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Variable + ( uninitializedVariable, + incompatibleVariableType, + ) +where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST + ( GQLErrors, + Ref (..), + TypeRef, + Variable (..), + msg, + ) +import Data.Semigroup ((<>)) + +-- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." +incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors +incompatibleVariableType + (Ref variableName argPosition) + Variable {variableType} + argumentType = + errorMessage argPosition text + where + text = + "Variable " + <> msg ("$" <> variableName) + <> " of type " + <> msg variableType + <> " used in position expecting type " + <> msg argumentType + <> "." + +uninitializedVariable :: Variable s -> GQLErrors +uninitializedVariable Variable {variableName, variableType, variablePosition} = + errorMessage + variablePosition + $ "Variable " + <> msg ("$" <> variableName) + <> " of required type " + <> msg variableType + <> " was not provided." diff --git a/src/Data/Morpheus/Error/Warning.hs b/src/Data/Morpheus/Error/Warning.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Warning.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Warning + ( renderGQLErrors, + deprecatedEnum, + deprecatedField, + gqlWarnings, + ) +where + +import Data.Aeson (encode) +import Data.ByteString.Lazy.Char8 (unpack) +import Data.Foldable (traverse_) +-- MORPHEUS +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST.Base + ( Description, + FieldName, + GQLErrors, + Ref (..), + msg, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH + ( Q, + reportWarning, + ) + +renderGQLErrors :: GQLErrors -> String +renderGQLErrors = unpack . encode + +deprecatedEnum :: FieldName -> Ref -> Maybe Description -> GQLErrors +deprecatedEnum typeName Ref {refPosition, refName} reason = + errorMessage refPosition $ + "the enum value " + <> msg typeName + <> "." + <> msg refName + <> " is deprecated." + <> msg (maybe "" (" " <>) reason) + +deprecatedField :: FieldName -> Ref -> Maybe Description -> GQLErrors +deprecatedField typeName Ref {refPosition, refName} reason = + errorMessage refPosition $ + "the field " + <> msg typeName + <> "." + <> msg refName + <> " is deprecated." + <> msg (maybe "" (" " <>) reason) + +gqlWarnings :: GQLErrors -> Q () +gqlWarnings [] = pure () +gqlWarnings warnings = traverse_ handleWarning warnings + where + handleWarning warning = + reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning) diff --git a/src/Data/Morpheus/Internal/TH.hs b/src/Data/Morpheus/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Internal/TH.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Morpheus.Internal.TH + ( declareType, + tyConArgs, + Scope (..), + apply, + applyT, + typeT, + instanceHeadT, + instanceProxyFunD, + instanceFunD, + instanceHeadMultiT, + destructRecord, + typeInstanceDec, + infoTyVars, + decArgs, + nameLitP, + nameStringE, + nameStringL, + nameConT, + nameVarE, + nameVarT, + nameConType, + nameConE, + nameVarP, + mkTypeName, + ) +where + +import Data.Maybe (maybe) +-- MORPHEUS +import Data.Morpheus.Internal.Utils + ( nameSpaceField, + nameSpaceType, + ) +import Data.Morpheus.Types.Internal.AST + ( ArgumentsDefinition (..), + ConsD (..), + DataTypeKind (..), + DataTypeKind (..), + FieldDefinition (..), + FieldName, + TypeD (..), + TypeName (..), + TypeRef (..), + TypeWrapper (..), + convertToHaskellName, + isEnum, + isOutputObject, + isSubscription, + readName, + ) +import Data.Morpheus.Types.Internal.Resolving + ( UnSubResolver, + ) +import Data.Semigroup ((<>)) +import Data.Text (unpack) +import GHC.Generics (Generic) +import Language.Haskell.TH + +type Arrow = (->) + +m' :: Type +m' = VarT $ mkTypeName m_ + +m_ :: TypeName +m_ = "m" + +declareTypeRef :: Bool -> TypeRef -> Type +declareTypeRef isSub TypeRef {typeConName, typeWrappers, typeArgs} = + wrappedT + typeWrappers + where + wrappedT :: [TypeWrapper] -> Type + wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs + wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs + wrappedT [] = decType typeArgs + ------------------------------------------------------ + typeName = nameConType typeConName + -------------------------------------------- + decType _ + | isSub = + AppT typeName (AppT (ConT ''UnSubResolver) m') + decType (Just par) = AppT typeName (VarT $ mkTypeName par) + decType _ = typeName + +tyConArgs :: DataTypeKind -> [TypeName] +tyConArgs kindD + | isOutputObject kindD || kindD == KindUnion = [m_] + | otherwise = [] + +data Scope = CLIENT | SERVER + deriving (Eq) + +declareType :: Scope -> Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec +declareType scope namespace kindD derivingList TypeD {tName, tCons, tNamespace} = + DataD [] (genName tName) tVars Nothing cons $ + map derive (''Generic : derivingList) + where + genName = mkTypeName . nameSpaceType tNamespace + tVars = maybe [] (declareTyVar . tyConArgs) kindD + where + declareTyVar = map (PlainTV . mkTypeName) + defBang = Bang NoSourceUnpackedness NoSourceStrictness + derive className = DerivClause Nothing [ConT className] + cons + | scope == CLIENT && isEnum tCons = map consE tCons + | otherwise = map consR tCons + consE ConsD {cName} = NormalC (genName $ tName <> cName) [] + consR ConsD {cName, cFields} = + RecC + (genName cName) + (map declareField cFields) + where + declareField FieldDefinition {fieldName, fieldArgs, fieldType} = + (mkFieldName fName, defBang, fiType) + where + fName + | namespace = nameSpaceField tName fieldName + | otherwise = fieldName + fiType = genFieldT fieldArgs + where + --------------------------- + genFieldT ArgumentsDefinition {argumentsTypename = Just argsTypename} = + AppT + (AppT arrowType argType) + (AppT m' result) + where + argType = ConT $ mkTypeName argsTypename + arrowType = ConT ''Arrow + genFieldT _ + | (isOutputObject <$> kindD) == Just True = AppT m' result + | otherwise = result + ------------------------------------------------ + result = declareTypeRef (maybe False isSubscription kindD) fieldType + +apply :: Name -> [Q Exp] -> Q Exp +apply n = foldl appE (conE n) + +applyT :: Name -> [Q Type] -> Q Type +applyT name = foldl appT (conT name) + +typeT :: Name -> [TypeName] -> Q Type +typeT name li = applyT name (map (varT . mkTypeName) li) + +instanceHeadT :: Name -> TypeName -> [TypeName] -> Q Type +instanceHeadT cName iType tArgs = applyT cName [applyT (mkTypeName iType) (map (varT . mkTypeName) tArgs)] + +instanceProxyFunD :: (Name, ExpQ) -> DecQ +instanceProxyFunD (name, body) = instanceFunD name ["_"] body + +instanceFunD :: Name -> [TypeName] -> ExpQ -> Q Dec +instanceFunD name args body = funD name [clause (map (varP . mkTypeName) args) (normalB body) []] + +instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type +instanceHeadMultiT className iType li = applyT className (iType : li) + +-- "User" -> ["name","id"] -> (User name id) +destructRecord :: TypeName -> [FieldName] -> PatQ +destructRecord conName fields = conP (mkTypeName conName) (map (varP . mkFieldName) fields) + +typeInstanceDec :: Name -> Type -> Type -> Dec + +nameLitP :: TypeName -> PatQ +nameLitP = litP . nameStringL + +nameStringL :: TypeName -> Lit +nameStringL = stringL . unpack . readTypeName + +nameStringE :: TypeName -> ExpQ +nameStringE = stringE . (unpack . readTypeName) + +#if MIN_VERSION_template_haskell(2,15,0) +-- fix breaking changes +typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res) +#else +-- +typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res) +#endif + +infoTyVars :: Info -> [TyVarBndr] +infoTyVars (TyConI x) = decArgs x +infoTyVars _ = [] + +decArgs :: Dec -> [TyVarBndr] +decArgs (DataD _ _ args _ _ _) = args +decArgs (NewtypeD _ _ args _ _ _) = args +decArgs (TySynD _ args _) = args +decArgs _ = [] + +mkTypeName :: TypeName -> Name +mkTypeName = mkName . unpack . readTypeName + +mkFieldName :: FieldName -> Name +mkFieldName = mkName . unpack . readName . convertToHaskellName + +nameConT :: TypeName -> Q Type +nameConT = conT . mkTypeName + +nameConType :: TypeName -> Type +nameConType = ConT . mkTypeName + +nameVarT :: TypeName -> Q Type +nameVarT = varT . mkTypeName + +nameVarE :: FieldName -> ExpQ +nameVarE = varE . mkFieldName + +nameConE :: TypeName -> ExpQ +nameConE = conE . mkTypeName + +nameVarP :: FieldName -> PatQ +nameVarP = varP . mkFieldName diff --git a/src/Data/Morpheus/Internal/Utils.hs b/src/Data/Morpheus/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Internal/Utils.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Internal.Utils + ( capital, + nonCapital, + nameSpaceField, + nameSpaceType, + capitalTypeName, + Collection (..), + Selectable (..), + Listable (..), + Merge (..), + Failure (..), + KeyOf (..), + toPair, + selectBy, + member, + keys, + size, + (<:>), + mapFst, + mapSnd, + mapTuple, + ) +where + +import Data.Char + ( toLower, + toUpper, + ) +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HM +import Data.Hashable (Hashable) +import Data.List (find) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + FieldName (..), + GQLErrors, + Ref (..), + Token, + TypeName (..), + TypeNameRef (..), + ) +import Data.Semigroup ((<>)) +import qualified Data.Text as T + ( concat, + pack, + unpack, + ) +import Instances.TH.Lift () +import Text.Megaparsec.Internal (ParsecT (..)) +import Text.Megaparsec.Stream (Stream) + +mapText :: (String -> String) -> Token -> Token +mapText f = T.pack . f . T.unpack + +nameSpaceType :: [FieldName] -> TypeName -> TypeName +nameSpaceType list (TypeName name) = TypeName . T.concat $ map capital (map readName list <> [name]) + +nameSpaceField :: TypeName -> FieldName -> FieldName +nameSpaceField nSpace (FieldName name) = FieldName (nonCapital nSpace <> capital name) + +nonCapital :: TypeName -> Token +nonCapital = mapText __nonCapital . readTypeName + where + __nonCapital [] = [] + __nonCapital (x : xs) = toLower x : xs + +capital :: Token -> Token +capital = mapText __capital + where + __capital [] = [] + __capital (x : xs) = toUpper x : xs + +capitalTypeName :: FieldName -> TypeName +capitalTypeName = TypeName . capital . readName + +--(KEY v ~ k) => +class Collection a coll | coll -> a where + empty :: coll + singleton :: a -> coll + +instance Collection a [a] where + empty = [] + singleton x = [x] + +instance (Hashable k, KeyOf v, k ~ KEY v) => Collection v (HashMap k v) where + empty = HM.empty + singleton x = HM.singleton (keyOf x) x + +class Selectable c a | c -> a where + selectOr :: d -> (a -> d) -> KEY a -> c -> d + +instance KeyOf a => Selectable [a] a where + selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib) + +instance (KEY a ~ k, Eq k, Hashable k) => Selectable (HashMap k a) a where + selectOr fb f key lib = maybe fb f (HM.lookup key lib) + +selectBy :: (Failure e m, Selectable c a, Monad m) => e -> KEY a -> c -> m a +selectBy err = selectOr (failure err) pure + +member :: forall a c. Selectable c a => KEY a -> c -> Bool +member = selectOr False toTrue + where + toTrue :: a -> Bool + toTrue _ = True + +class Eq (KEY a) => KeyOf a where + type KEY a :: * + type KEY a = FieldName + keyOf :: a -> KEY a + +instance KeyOf Ref where + keyOf = refName + +instance KeyOf TypeNameRef where + type KEY TypeNameRef = TypeName + keyOf = typeNameRef + +toPair :: KeyOf a => a -> (KEY a, a) +toPair x = (keyOf x, x) + +-- list Like Collections +class Listable a coll | coll -> a where + elems :: coll -> [a] + fromElems :: (KeyOf a, Monad m, Failure GQLErrors m) => [a] -> m coll + +keys :: (KeyOf a, Listable a coll) => coll -> [KEY a] +keys = map keyOf . elems + +size :: Listable a coll => coll -> Int +size = length . elems + +-- Merge Object with of Failure as an Option +class Merge a where + merge :: (Monad m, Failure GQLErrors m) => [Ref] -> a -> a -> m a + +(<:>) :: (Monad m, Merge a, Failure GQLErrors m) => a -> a -> m a +(<:>) = merge [] + +-- Failure: for custome Morpheus GrapHQL errors +class Applicative f => Failure error (f :: * -> *) where + failure :: error -> f v + +instance Failure error (Either error) where + failure = Left + +instance (Stream s, Ord e, Failure [a] m) => Failure [a] (ParsecT e s m) where + failure x = ParsecT $ \_ _ _ _ _ -> failure x + +mapFst :: (a -> a') -> (a, b) -> (a', b) +mapFst f (a, b) = (f a, b) + +mapSnd :: (b -> b') -> (a, b) -> (a, b') +mapSnd f (a, b) = (a, f b) + +mapTuple :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') +mapTuple f1 f2 (a, b) = (f1 a, f2 b) diff --git a/src/Data/Morpheus/Parser.hs b/src/Data/Morpheus/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser.hs @@ -0,0 +1,52 @@ +module Data.Morpheus.Parser + ( parseTypeDefinitions, + parseTypeSystemDefinition, + parseRequest, + parseRequestWith, + ) +where + +import Control.Monad ((>=>)) +import Data.Morpheus.Internal.Utils + ( fromElems, + ) +import Data.Morpheus.Parsing.Document.TypeSystem (parseSchema) +import Data.Morpheus.Parsing.Request.Parser (parseGQL) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + GQLQuery (..), + Operation, + Schema (..), + TypeDefinition (..), + VALID, + VALIDATION_MODE (..), + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Morpheus.Validation.Document.Validation + ( validatePartialDocument, + ) +import Data.Morpheus.Validation.Query.Validation + ( validateRequest, + ) +import Data.Text (Text) + +parseTypeSystemDefinition :: + Text -> Eventless Schema +parseTypeSystemDefinition = + parseSchema >=> fromElems + +parseTypeDefinitions :: + Text -> Eventless [TypeDefinition ANY] +parseTypeDefinitions = + parseSchema >=> validatePartialDocument + +parseRequest :: GQLRequest -> Eventless GQLQuery +parseRequest = parseGQL + +parseRequestWith :: Schema -> GQLRequest -> Eventless (Operation VALID) +parseRequestWith schema = parseRequest >=> validateRequest schema FULL_VALIDATION diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parsing.Document.TypeSystem + ( parseSchema, + ) +where + +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + processParser, + ) +import Data.Morpheus.Parsing.Internal.Pattern + ( enumValueDefinition, + fieldsDefinition, + inputFieldsDefinition, + optionalDirectives, + typeDeclaration, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( collection, + keyword, + operator, + optDescription, + parseTypeName, + pipeLiteral, + sepByAnd, + spaceAndComments, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + DataFingerprint (..), + Description, + IN, + Meta (..), + OUT, + ScalarDefinition (..), + TypeContent (..), + TypeDefinition (..), + TypeName, + toAny, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Text (Text) +import Text.Megaparsec + ( (<|>), + eof, + label, + manyTill, + sepBy1, + ) + +-- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars +-- +-- ScalarTypeDefinition: +-- Description(opt) scalar Name Directives(Const)(opt) +-- +scalarTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY) +scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do + typeName <- typeDeclaration "scalar" + metaDirectives <- optionalDirectives + pure + TypeDefinition + { typeName, + typeMeta = Just Meta {metaDescription, metaDirectives}, + typeFingerprint = DataFingerprint typeName [], + typeContent = DataScalar $ ScalarDefinition pure + } + +-- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects +-- +-- ObjectTypeDefinition: +-- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) +-- +-- ImplementsInterfaces +-- implements &(opt) NamedType +-- ImplementsInterfaces & NamedType +-- +-- FieldsDefinition +-- { FieldDefinition(list) } +-- +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +objectTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) +objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do + typeName <- typeDeclaration "type" + objectImplements <- optionalImplementsInterfaces + metaDirectives <- optionalDirectives + objectFields <- fieldsDefinition + -- build object + pure + TypeDefinition + { typeName, + typeMeta = Just Meta {metaDescription, metaDirectives}, + typeFingerprint = DataFingerprint typeName [], + typeContent = DataObject {objectImplements, objectFields} + } + +optionalImplementsInterfaces :: Parser [TypeName] +optionalImplementsInterfaces = implements <|> pure [] + where + implements = + label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseTypeName + +-- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces +-- +-- InterfaceTypeDefinition +-- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) +-- +interfaceTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) +interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do + typeName <- typeDeclaration "interface" + metaDirectives <- optionalDirectives + fields <- fieldsDefinition + -- build interface + pure + TypeDefinition + { typeName, + typeMeta = Just Meta {metaDescription, metaDirectives}, + typeFingerprint = DataFingerprint typeName [], + typeContent = DataInterface fields + } + +-- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions +-- +-- UnionTypeDefinition: +-- Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt) +-- +-- UnionMemberTypes: +-- = |(opt) NamedType +-- UnionMemberTypes | NamedType +-- +unionTypeDefinition :: Maybe Description -> Parser (TypeDefinition OUT) +unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do + typeName <- typeDeclaration "union" + metaDirectives <- optionalDirectives + memberTypes <- unionMemberTypes + -- build union + pure + TypeDefinition + { typeName, + typeMeta = Just Meta {metaDescription, metaDirectives}, + typeFingerprint = DataFingerprint typeName [], + typeContent = DataUnion memberTypes + } + where + unionMemberTypes = operator '=' *> parseTypeName `sepBy1` pipeLiteral + +-- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums +-- +-- EnumTypeDefinition +-- Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt) +-- +-- EnumValuesDefinition +-- { EnumValueDefinition(list) } +-- +-- EnumValueDefinition +-- Description(opt) EnumValue Directives(Const)(opt) +-- +enumTypeDefinition :: Maybe Description -> Parser (TypeDefinition ANY) +enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do + typeName <- typeDeclaration "enum" + metaDirectives <- optionalDirectives + enumValuesDefinitions <- collection enumValueDefinition + -- build enum + pure + TypeDefinition + { typeName, + typeContent = DataEnum enumValuesDefinitions, + typeFingerprint = DataFingerprint typeName [], + typeMeta = Just Meta {metaDescription, metaDirectives} + } + +-- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects +-- +-- InputObjectTypeDefinition +-- Description(opt) input Name Directives(Const)(opt) InputFieldsDefinition(opt) +-- +-- InputFieldsDefinition: +-- { InputValueDefinition(list) } +-- +inputObjectTypeDefinition :: Maybe Description -> Parser (TypeDefinition IN) +inputObjectTypeDefinition metaDescription = + label "InputObjectTypeDefinition" $ do + typeName <- typeDeclaration "input" + metaDirectives <- optionalDirectives + fields <- inputFieldsDefinition + -- build input + pure + TypeDefinition + { typeName, + typeContent = DataInputObject fields, + typeFingerprint = DataFingerprint typeName [], + typeMeta = Just Meta {metaDescription, metaDirectives} + } + +parseDataType :: Parser (TypeDefinition ANY) +parseDataType = label "TypeDefinition" $ do + description <- optDescription + -- scalar | enum | input | object | union | interface + (toAny <$> inputObjectTypeDefinition description) + <|> (toAny <$> unionTypeDefinition description) + <|> enumTypeDefinition description + <|> scalarTypeDefinition description + <|> (toAny <$> objectTypeDefinition description) + <|> (toAny <$> interfaceTypeDefinition description) + +parseSchema :: Text -> Eventless [TypeDefinition ANY] +parseSchema = processParser request + where + request = label "DocumentTypes" $ do + spaceAndComments + manyTill parseDataType eof diff --git a/src/Data/Morpheus/Parsing/Internal/Arguments.hs b/src/Data/Morpheus/Parsing/Internal/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Arguments.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Parsing.Internal.Arguments (maybeArguments) where + +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + getLocation, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( parseAssignment, + parseName, + uniqTupleOpt, + ) +import Data.Morpheus.Parsing.Internal.Value + ( Parse (..), + ) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + Arguments, + Value, + ) +import Text.Megaparsec (label) + +-- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments +-- +-- Arguments[Const] +-- ( Argument[Const](list) ) +-- +-- Argument[Const] +-- Name : Value[Const] +valueArgument :: Parse (Value s) => Parser (Argument s) +valueArgument = + label "Argument" $ do + argumentPosition <- getLocation + (argumentName, argumentValue) <- parseAssignment parseName parse + pure $ Argument {argumentName, argumentValue, argumentPosition} + +maybeArguments :: Parse (Value s) => Parser (Arguments s) +maybeArguments = + label "Arguments" $ + uniqTupleOpt valueArgument diff --git a/src/Data/Morpheus/Parsing/Internal/Internal.hs b/src/Data/Morpheus/Parsing/Internal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Internal.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Parsing.Internal.Internal + ( Parser, + Position, + getLocation, + processParser, + ) +where + +import qualified Data.List.NonEmpty as NonEmpty +import Data.Morpheus.Types.Internal.AST + ( GQLError (..), + GQLErrors, + Position (..), + msg, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Result (..), + failure, + ) +import Data.Text + ( Text, + ) +import Data.Void (Void) +import Text.Megaparsec + ( ParseError, + ParseErrorBundle + ( ParseErrorBundle + ), + ParsecT, + SourcePos, + SourcePos (..), + attachSourcePos, + bundleErrors, + bundlePosState, + errorOffset, + getSourcePos, + parseErrorPretty, + runParserT, + unPos, + ) + +getLocation :: Parser Position +getLocation = fmap toLocation getSourcePos + +toLocation :: SourcePos -> Position +toLocation SourcePos {sourceLine, sourceColumn} = + Position {line = unPos sourceLine, column = unPos sourceColumn} + +type MyError = Void + +type Parser = ParsecT MyError Text Eventless + +type ErrorBundle = ParseErrorBundle Text MyError + +processParser :: Parser a -> Text -> Eventless a +processParser parser txt = case runParserT parser [] txt of + Success {result} -> case result of + Right root -> pure root + Left parseError -> failure (processErrorBundle parseError) + Failure {errors} -> failure errors + +processErrorBundle :: ErrorBundle -> GQLErrors +processErrorBundle = map parseErrorToGQLError . bundleToErrors + where + parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError + parseErrorToGQLError (err, position) = + GQLError + { message = msg (parseErrorPretty err), + locations = [toLocation position] + } + bundleToErrors :: + ErrorBundle -> [(ParseError Text MyError, SourcePos)] + bundleToErrors ParseErrorBundle {bundleErrors, bundlePosState} = + NonEmpty.toList $ fst $ + attachSourcePos + errorOffset + bundleErrors + bundlePosState diff --git a/src/Data/Morpheus/Parsing/Internal/Pattern.hs b/src/Data/Morpheus/Parsing/Internal/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Pattern.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Morpheus.Parsing.Internal.Pattern + ( inputValueDefinition, + fieldsDefinition, + typeDeclaration, + optionalDirectives, + enumValueDefinition, + inputFieldsDefinition, + ) +where + +-- MORPHEUS + +import Data.Morpheus.Parsing.Internal.Arguments + ( maybeArguments, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( getLocation, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( keyword, + litAssignment, + operator, + optDescription, + parseName, + parseType, + parseTypeName, + setOf, + uniqTuple, + ) +import Data.Morpheus.Parsing.Internal.Value + ( Parse (..), + parseDefaultValue, + ) +import Data.Morpheus.Types.Internal.AST + ( ArgumentsDefinition (..), + DataEnumValue (..), + Directive (..), + FieldDefinition (..), + FieldName, + FieldsDefinition, + IN, + InputFieldsDefinition, + Meta (..), + OUT, + TypeName, + Value, + ) +import Text.Megaparsec + ( (<|>), + label, + many, + ) + +-- EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition +-- +-- EnumValueDefinition +-- Description(opt) EnumValue Directives(Const)(opt) +-- +enumValueDefinition :: Parser DataEnumValue +enumValueDefinition = label "EnumValueDefinition" $ do + metaDescription <- optDescription + enumName <- parseTypeName + metaDirectives <- optionalDirectives + return $ + DataEnumValue + { enumName, + enumMeta = Just Meta {metaDescription, metaDirectives} + } + +-- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition +-- +-- InputValueDefinition +-- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) +-- +inputValueDefinition :: Parser (FieldDefinition IN) +inputValueDefinition = label "InputValueDefinition" $ do + metaDescription <- optDescription + fieldName <- parseName + litAssignment -- ':' + fieldType <- parseType + _ <- parseDefaultValue + metaDirectives <- optionalDirectives + pure + FieldDefinition + { fieldArgs = NoArguments, + fieldName, + fieldType, + fieldMeta = Just Meta {metaDescription, metaDirectives} + } + +-- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments +-- +-- ArgumentsDefinition: +-- ( InputValueDefinition(list) ) +-- +argumentsDefinition :: Parser ArgumentsDefinition +argumentsDefinition = + label "ArgumentsDefinition" $ + uniqTuple inputValueDefinition + <|> pure NoArguments + +-- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition +-- +-- FieldsDefinition : +-- { FieldDefinition(list) } +-- +fieldsDefinition :: Parser (FieldsDefinition OUT) +fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition + +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +fieldDefinition :: Parser (FieldDefinition OUT) +fieldDefinition = label "FieldDefinition" $ do + metaDescription <- optDescription + fieldName <- parseName + fieldArgs <- argumentsDefinition + litAssignment -- ':' + fieldType <- parseType + metaDirectives <- optionalDirectives + pure + FieldDefinition + { fieldName, + fieldArgs, + fieldType, + fieldMeta = Just Meta {metaDescription, metaDirectives} + } + +-- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives +-- InputFieldsDefinition: +-- { InputValueDefinition(list) } +-- +inputFieldsDefinition :: Parser InputFieldsDefinition +inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition + +-- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives +-- +-- example: @directive ( arg1: "value" , .... ) +-- +-- Directives[Const] +-- Directive[Const](list) +-- +optionalDirectives :: Parse (Value s) => Parser [Directive s] +optionalDirectives = label "Directives" $ many directive + +-- Directive[Const] +-- +-- @ Name Arguments[Const](opt) +directive :: Parse (Value s) => Parser (Directive s) +directive = label "Directive" $ do + directivePosition <- getLocation + operator '@' + directiveName <- parseName + directiveArgs <- maybeArguments + pure Directive {..} + +-- typDeclaration : Not in spec ,start part of type definitions +-- +-- typDeclaration +-- Description(opt) scalar Name +-- +typeDeclaration :: FieldName -> Parser TypeName +typeDeclaration kind = do + keyword kind + parseTypeName diff --git a/src/Data/Morpheus/Parsing/Internal/Terms.hs b/src/Data/Morpheus/Parsing/Internal/Terms.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Terms.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Data.Morpheus.Parsing.Internal.Terms + ( token, + qualifier, + variable, + spaceAndComments, + spaceAndComments1, + pipeLiteral, + ------------- + collection, + setOf, + uniqTuple, + uniqTupleOpt, + parseTypeCondition, + spreadLiteral, + parseNonNull, + parseAssignment, + parseWrappedType, + litEquals, + litAssignment, + parseTuple, + parseAlias, + sepByAnd, + parseName, + parseType, + keyword, + operator, + optDescription, + optionalList, + parseNegativeSign, + parseTypeName, + ) +where + +import Control.Monad ((>=>)) +import Data.Functor (($>)) +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( KeyOf, + Listable (..), + fromElems, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + Position, + getLocation, + ) +import Data.Morpheus.Types.Internal.AST + ( DataTypeWrapper (..), + Description, + FieldName (..), + Ref (..), + Token, + TypeName (..), + TypeRef (..), + toHSWrappers, + ) +import Data.Text + ( pack, + strip, + ) +import Text.Megaparsec + ( (), + (<|>), + between, + label, + many, + manyTill, + optional, + sepBy, + sepEndBy, + skipMany, + skipManyTill, + try, + try, + ) +import Text.Megaparsec.Char + ( char, + digitChar, + letterChar, + newline, + printChar, + space, + space1, + string, + ) + +-- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names +-- +-- Name :: /[_A-Za-z][_0-9A-Za-z]*/ +-- + +parseNegativeSign :: Parser Bool +parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False + +parseName :: Parser FieldName +parseName = FieldName <$> token + +parseTypeName :: Parser TypeName +parseTypeName = TypeName <$> token + +keyword :: FieldName -> Parser () +keyword (FieldName word) = string word *> space1 *> spaceAndComments + +operator :: Char -> Parser () +operator x = char x *> spaceAndComments + +-- LITERALS +braces :: Parser [a] -> Parser [a] +braces = + between + (char '{' *> spaceAndComments) + (char '}' *> spaceAndComments) + +pipeLiteral :: Parser () +pipeLiteral = char '|' *> spaceAndComments + +litEquals :: Parser () +litEquals = char '=' *> spaceAndComments + +litAssignment :: Parser () +litAssignment = char ':' *> spaceAndComments + +-- PRIMITIVE +------------------------------------ +token :: Parser Token +token = label "token" $ do + firstChar <- letterChar <|> char '_' + restToken <- many $ letterChar <|> char '_' <|> digitChar + spaceAndComments + return $ pack $ firstChar : restToken + +qualifier :: Parser (FieldName, Position) +qualifier = label "qualifier" $ do + position <- getLocation + value <- parseName + return (value, position) + +-- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable +-- +-- Variable : $Name +-- +variable :: Parser Ref +variable = label "variable" $ do + refPosition <- getLocation + _ <- char '$' + refName <- parseName + spaceAndComments + pure $ Ref {refName, refPosition} + +spaceAndComments1 :: Parser () +spaceAndComments1 = space1 *> spaceAndComments + +-- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description +-- +-- Description: +-- StringValue +-- TODO: should support """ and " +-- +optDescription :: Parser (Maybe Description) +optDescription = optional parseDescription + +parseDescription :: Parser Description +parseDescription = + strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments + where + blockDescription = + blockQuotes + *> manyTill (printChar <|> newline) blockQuotes + <* spaceAndComments + where + blockQuotes = string "\"\"\"" + ---------------------------- + singleLine = + stringQuote *> manyTill printChar stringQuote <* spaceAndComments + where + stringQuote = char '"' + +-- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens +-- Ignored: +-- UnicodeBOM +-- WhiteSpace +-- LineTerminator +-- Comment +-- Comma +-- TODO: implement as in specification +spaceAndComments :: Parser () +spaceAndComments = ignoredTokens + +ignoredTokens :: Parser () +ignoredTokens = + label "IgnoredTokens" $ space *> skipMany inlineComment *> space + where + inlineComment = char '#' *> skipManyTill printChar newline *> space + +------------------------------------------------------------------------ + +-- COMPLEX +sepByAnd :: Parser a -> Parser [a] +sepByAnd entry = entry `sepBy` (optional (char '&') *> spaceAndComments) + +----------------------------- +collection :: Parser a -> Parser [a] +collection entry = braces (entry `sepEndBy` many (char ',' *> spaceAndComments)) + +setOf :: (Listable a coll, KeyOf a) => Parser a -> Parser coll +setOf = collection >=> fromElems + +parseNonNull :: Parser [DataTypeWrapper] +parseNonNull = do + wrapper <- (char '!' $> [NonNullType]) <|> pure [] + spaceAndComments + return wrapper + +optionalList :: Parser [a] -> Parser [a] +optionalList x = x <|> pure [] + +parseTuple :: Parser a -> Parser [a] +parseTuple parser = + label "Tuple" $ + between + (char '(' *> spaceAndComments) + (char ')' *> spaceAndComments) + ( parser `sepBy` (many (char ',') *> spaceAndComments) "empty Tuple value!" + ) + +uniqTuple :: (Listable a coll, KeyOf a) => Parser a -> Parser coll +uniqTuple = parseTuple >=> fromElems + +uniqTupleOpt :: (Listable a coll, KeyOf a) => Parser a -> Parser coll +uniqTupleOpt = optionalList . parseTuple >=> fromElems + +parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b) +parseAssignment nameParser valueParser = label "assignment" $ do + name' <- nameParser + litAssignment + value' <- valueParser + pure (name', value') + +-- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions +-- +-- TypeCondition: +-- on NamedType +-- +parseTypeCondition :: Parser TypeName +parseTypeCondition = do + _ <- string "on" + space1 + parseTypeName + +spreadLiteral :: Parser Position +spreadLiteral = do + index <- getLocation + _ <- string "..." + space + return index + +parseWrappedType :: Parser ([DataTypeWrapper], TypeName) +parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments + where + unwrapped :: Parser ([DataTypeWrapper], TypeName) + unwrapped = ([],) <$> parseTypeName <* spaceAndComments + ---------------------------------------------- + wrapped :: Parser ([DataTypeWrapper], TypeName) + wrapped = + between + (char '[' *> spaceAndComments) + (char ']' *> spaceAndComments) + ( do + (wrappers, name) <- unwrapped <|> wrapped + nonNull' <- parseNonNull + return ((ListType : nonNull') ++ wrappers, name) + ) + +-- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias +-- Alias +-- Name: +parseAlias :: Parser (Maybe FieldName) +parseAlias = try (optional alias) <|> pure Nothing + where + alias = label "alias" $ parseName <* char ':' <* spaceAndComments + +parseType :: Parser TypeRef +parseType = do + (wrappers, typeConName) <- parseWrappedType + nonNull <- parseNonNull + pure + TypeRef + { typeConName, + typeArgs = Nothing, + typeWrappers = toHSWrappers $ nonNull ++ wrappers + } diff --git a/src/Data/Morpheus/Parsing/Internal/Value.hs b/src/Data/Morpheus/Parsing/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Value.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Parsing.Internal.Value + ( enumValue, + parseDefaultValue, + Parse (..), + ) +where + +import Data.Functor (($>)) +-- +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( litEquals, + parseAssignment, + parseName, + parseNegativeSign, + parseTypeName, + setOf, + spaceAndComments, + variable, + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + ObjectEntry (..), + OrderedMap, + RAW, + ResolvedValue, + ScalarValue (..), + VALID, + Value (..), + decodeScientific, + ) +import Data.Text (pack) +import Text.Megaparsec + ( (<|>), + anySingleBut, + between, + choice, + label, + many, + optional, + sepBy, + ) +import Text.Megaparsec.Char + ( char, + string, + ) +import Text.Megaparsec.Char.Lexer (scientific) + +valueNull :: Parser (Value a) +valueNull = string "null" $> Null + +booleanValue :: Parser (Value a) +booleanValue = boolTrue <|> boolFalse + where + boolTrue = string "true" $> Scalar (Boolean True) + boolFalse = string "false" $> Scalar (Boolean False) + +valueNumber :: Parser (Value a) +valueNumber = do + isNegative <- parseNegativeSign + Scalar . decodeScientific . signedNumber isNegative <$> scientific + where + signedNumber isNegative number + | isNegative = - number + | otherwise = number + +enumValue :: Parser (Value a) +enumValue = do + enum <- Enum <$> parseTypeName + spaceAndComments + return enum + +escaped :: Parser Char +escaped = label "escaped" $ do + x <- anySingleBut '\"' + if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x + where + replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/'] + codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/'] + escapeChar code replacement = char code >> return replacement + +stringValue :: Parser (Value a) +stringValue = + label "stringValue" $ + Scalar . String . pack + <$> between + (char '"') + (char '"') + (many escaped) + +listValue :: Parser a -> Parser [a] +listValue parser = + label "ListValue" $ + between + (char '[' *> spaceAndComments) + (char ']' *> spaceAndComments) + (parser `sepBy` (many (char ',') *> spaceAndComments)) + +objectEntry :: Parser (Value a) -> Parser (ObjectEntry a) +objectEntry parser = label "ObjectEntry" $ do + (entryName, entryValue) <- parseAssignment parseName parser + pure ObjectEntry {entryName, entryValue} + +objectValue :: Parser (Value a) -> Parser (OrderedMap FieldName (ObjectEntry a)) +objectValue = label "ObjectValue" . setOf . objectEntry + +parsePrimitives :: Parser (Value a) +parsePrimitives = + valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue + +parseDefaultValue :: Parser (Maybe ResolvedValue) +parseDefaultValue = optional $ do + litEquals + parseV + where + parseV :: Parser ResolvedValue + parseV = structValue parseV + +class Parse a where + parse :: Parser a + +instance Parse (Value RAW) where + parse = (VariableValue <$> variable) <|> structValue parse + +instance Parse (Value VALID) where + parse = structValue parse + +structValue :: Parser (Value a) -> Parser (Value a) +structValue parser = + label "Value" $ + ( parsePrimitives + <|> (Object <$> objectValue parser) + <|> (List <$> listValue parser) + ) + <* spaceAndComments diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/JSONSchema/Parse.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Parsing.JSONSchema.Parse + ( decodeIntrospection, + ) +where + +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Morpheus.Error.Internal (internalError) +import Data.Morpheus.Internal.Utils + ( fromElems, + ) +import Data.Morpheus.Parsing.JSONSchema.Types + ( EnumValue (..), + Field (..), + InputValue (..), + Introspection (..), + Schema (..), + Type (..), + ) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.IO (JSONResponse (..)) +import qualified Data.Morpheus.Types.Internal.AST as AST + ( Schema, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + DataTypeWrapper (..), + FieldDefinition, + IN, + OUT, + TypeContent (..), + TypeDefinition (..), + TypeName, + TypeWrapper, + createArgument, + createEnumType, + createField, + createScalarType, + createType, + createUnionType, + msg, + toAny, + toHSWrappers, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Semigroup ((<>)) + +decodeIntrospection :: ByteString -> Eventless AST.Schema +decodeIntrospection jsonDoc = case jsonSchema of + Left errors -> internalError $ msg errors + Right JSONResponse {responseData = Just Introspection {__schema = Schema {types}}} -> + traverse parse types >>= fromElems . concat + Right res -> internalError (msg $ show res) + where + jsonSchema :: Either String (JSONResponse Introspection) + jsonSchema = eitherDecode jsonDoc + +class ParseJSONSchema a b where + parse :: a -> Eventless b + +instance ParseJSONSchema Type [TypeDefinition ANY] where + parse Type {name = Just typeName, kind = SCALAR} = + pure [createScalarType typeName] + parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} = + pure [createEnumType typeName (map enumName enums)] + parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} = + case traverse name unions of + Nothing -> internalError "ERROR: GQL ERROR" + Just uni -> pure [toAny $ createUnionType typeName uni] + parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = + do + (fields :: [FieldDefinition IN]) <- traverse parse iFields + fs <- fromElems fields + pure [createType typeName $ DataInputObject fs] + parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = + do + (fields :: [FieldDefinition OUT]) <- traverse parse oFields + fs <- fromElems fields + pure [createType typeName $ DataObject [] fs] + parse _ = pure [] + +instance ParseJSONSchema Field (FieldDefinition OUT) where + parse Field {fieldName, fieldArgs, fieldType} = do + fType <- fieldTypeFromJSON fieldType + args <- traverse genArg fieldArgs >>= fromElems + pure $ createField (ArgumentsDefinition Nothing args) fieldName fType + where + genArg InputValue {inputName = argName, inputType = argType} = + createArgument argName <$> fieldTypeFromJSON argType + +instance ParseJSONSchema InputValue (FieldDefinition IN) where + parse InputValue {inputName, inputType} = createField NoArguments inputName <$> fieldTypeFromJSON inputType + +fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName) +fieldTypeFromJSON = fmap toHs . fieldTypeRec [] + where + toHs (w, t) = (toHSWrappers w, t) + fieldTypeRec :: + [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], TypeName) + fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} = + fieldTypeRec (ListType : acc) ofType + fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} = + fieldTypeRec (NonNullType : acc) ofType + fieldTypeRec acc Type {name = Just name} = pure (acc, name) + fieldTypeRec _ x = internalError $ "Unsuported Field" <> msg (show x) diff --git a/src/Data/Morpheus/Parsing/JSONSchema/Types.hs b/src/Data/Morpheus/Parsing/JSONSchema/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/JSONSchema/Types.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Parsing.JSONSchema.Types + ( Introspection (..), + Schema (..), + Type (..), + Field (..), + InputValue (..), + EnumValue (..), + ) +where + +import Data.Aeson +-- +-- MORPHEUS +import Data.Morpheus.Schema.TypeKind (TypeKind) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + TypeName, + ) +import GHC.Generics (Generic) + +-- TYPES FOR DECODING JSON INTROSPECTION +-- +newtype Introspection = Introspection + { __schema :: Schema + } + deriving (Generic, Show, FromJSON) + +newtype Schema = Schema + { types :: [Type] + } + deriving (Generic, Show, FromJSON) + +-- TYPE +data Type = Type + { kind :: TypeKind, + name :: Maybe TypeName, + fields :: Maybe [Field], + interfaces :: Maybe [Type], + possibleTypes :: Maybe [Type], + enumValues :: Maybe [EnumValue], + inputFields :: Maybe [InputValue], + ofType :: Maybe Type + } + deriving (Generic, Show, FromJSON) + +-- FIELD +data Field = Field + { fieldName :: FieldName, + fieldArgs :: [InputValue], + fieldType :: Type + } + deriving (Show, Generic) + +instance FromJSON Field where + parseJSON = withObject "Field" objectParser + where + objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type" + +-- INPUT +data InputValue = InputValue + { inputName :: FieldName, + inputType :: Type + } + deriving (Show, Generic) + +instance FromJSON InputValue where + parseJSON = withObject "InputValue" objectParser + where + objectParser o = InputValue <$> o .: "name" <*> o .: "type" + +-- ENUM +newtype EnumValue = EnumValue + { enumName :: TypeName + } + deriving (Generic, Show) + +instance FromJSON EnumValue where + parseJSON = withObject "EnumValue" objectParser + where + objectParser o = EnumValue <$> o .: "name" diff --git a/src/Data/Morpheus/Parsing/Request/Operation.hs b/src/Data/Morpheus/Parsing/Request/Operation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Request/Operation.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Morpheus.Parsing.Request.Operation + ( parseOperation, + ) +where + +import Data.Functor (($>)) +-- +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( empty, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + getLocation, + ) +import Data.Morpheus.Parsing.Internal.Pattern + ( optionalDirectives, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( operator, + parseName, + parseType, + spaceAndComments1, + uniqTupleOpt, + variable, + ) +import Data.Morpheus.Parsing.Internal.Value + ( parseDefaultValue, + ) +import Data.Morpheus.Parsing.Request.Selection + ( parseSelectionSet, + ) +import Data.Morpheus.Types.Internal.AST + ( Operation (..), + OperationType (..), + RAW, + Ref (..), + Variable (..), + VariableContent (..), + ) +import Text.Megaparsec + ( (), + (<|>), + label, + optional, + ) +import Text.Megaparsec.Char (string) + +-- Variables : https://graphql.github.io/graphql-spec/June2018/#VariableDefinition +-- +-- VariableDefinition +-- Variable : Type DefaultValue(opt) +-- +variableDefinition :: Parser (Variable RAW) +variableDefinition = label "VariableDefinition" $ do + (Ref variableName variablePosition) <- variable + operator ':' + variableType <- parseType + variableValue <- DefaultValue <$> parseDefaultValue + pure Variable {..} + +-- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations +-- +-- OperationDefinition +-- OperationType Name(opt) VariableDefinitions(opt) Directives(opt) SelectionSet +-- +-- OperationType: one of +-- query, mutation, subscription +parseOperationDefinition :: Parser (Operation RAW) +parseOperationDefinition = label "OperationDefinition" $ do + operationPosition <- getLocation + operationType <- parseOperationType + operationName <- optional parseName + operationArguments <- uniqTupleOpt variableDefinition + operationDirectives <- optionalDirectives + operationSelection <- parseSelectionSet + pure Operation {..} + +parseOperationType :: Parser OperationType +parseOperationType = label "OperationType" $ do + kind <- + (string "query" $> Query) + <|> (string "mutation" $> Mutation) + <|> (string "subscription" $> Subscription) + spaceAndComments1 + return kind + +parseAnonymousQuery :: Parser (Operation RAW) +parseAnonymousQuery = label "AnonymousQuery" $ do + operationPosition <- getLocation + operationSelection <- parseSelectionSet + pure + ( Operation + { operationName = Nothing, + operationType = Query, + operationArguments = empty, + operationDirectives = empty, + .. + } + ) + "can't parse AnonymousQuery" + +parseOperation :: Parser (Operation RAW) +parseOperation = parseAnonymousQuery <|> parseOperationDefinition diff --git a/src/Data/Morpheus/Parsing/Request/Parser.hs b/src/Data/Morpheus/Parsing/Request/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Request/Parser.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parsing.Request.Parser (parseGQL) where + +import qualified Data.Aeson as Aeson + ( Value (..), + ) +import Data.HashMap.Lazy (toList) +-- +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( fromElems, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + processParser, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( spaceAndComments, + ) +import Data.Morpheus.Parsing.Request.Operation + ( parseOperation, + ) +import Data.Morpheus.Parsing.Request.Selection + ( parseFragmentDefinition, + ) +import Data.Morpheus.Types.IO (GQLRequest (..)) +import Data.Morpheus.Types.Internal.AST + ( FieldName (..), + GQLQuery (..), + ResolvedValue, + replaceValue, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Text.Megaparsec + ( eof, + label, + manyTill, + ) + +request :: Parser GQLQuery +request = label "GQLQuery" $ do + spaceAndComments + operation <- parseOperation + fragments <- manyTill parseFragmentDefinition eof >>= fromElems + pure GQLQuery {operation, fragments, inputVariables = []} + +parseGQL :: GQLRequest -> Eventless GQLQuery +parseGQL GQLRequest {query, variables} = setVariables <$> processParser request query + where + setVariables root = root {inputVariables = toVariableMap variables} + toVariableMap :: Maybe Aeson.Value -> [(FieldName, ResolvedValue)] + toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x) + where + toMorpheusValue (key, value) = (FieldName key, replaceValue value) + toVariableMap _ = [] diff --git a/src/Data/Morpheus/Parsing/Request/Selection.hs b/src/Data/Morpheus/Parsing/Request/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Request/Selection.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Parsing.Request.Selection + ( parseSelectionSet, + parseFragmentDefinition, + ) +where + +-- +-- MORPHEUS + +import Data.Morpheus.Parsing.Internal.Arguments + ( maybeArguments, + ) +import Data.Morpheus.Parsing.Internal.Internal + ( Parser, + getLocation, + ) +import Data.Morpheus.Parsing.Internal.Pattern + ( optionalDirectives, + ) +import Data.Morpheus.Parsing.Internal.Terms + ( keyword, + parseAlias, + parseName, + parseTypeCondition, + setOf, + spreadLiteral, + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + Fragment (..), + Position, + RAW, + Ref (..), + Selection (..), + SelectionContent (..), + SelectionSet, + ) +import Text.Megaparsec + ( (<|>), + label, + try, + ) + +-- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets +-- +-- SelectionSet: +-- { Selection(list) } +-- +-- Selection: +-- Field +-- FragmentSpread +-- InlineFragment +-- +parseSelectionSet :: Parser (SelectionSet RAW) +parseSelectionSet = label "SelectionSet" $ setOf parseSelection + where + parseSelection = + label "Selection" $ + try inlineFragment + <|> try spread + <|> parseSelectionField + +-- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields +-- +-- Field +-- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) +-- +parseSelectionField :: Parser (Selection RAW) +parseSelectionField = + label "SelectionField" $ + do + selectionPosition <- getLocation + selectionAlias <- parseAlias + selectionName <- parseName + selectionArguments <- maybeArguments + selectionDirectives <- optionalDirectives + selectionContent <- parseSelectionContent + pure Selection {..} + +parseSelectionContent :: Parser (SelectionContent RAW) +parseSelectionContent = + label "SelectionContent" $ + SelectionSet <$> parseSelectionSet + <|> pure SelectionField + +-- +-- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments +-- +-- FragmentName : Name +-- + +-- FragmentSpread +-- ...FragmentName Directives(opt) +-- +spread :: Parser (Selection RAW) +spread = label "FragmentSpread" $ do + refPosition <- spreadLiteral + refName <- parseName + directives <- optionalDirectives + pure $ Spread directives Ref {..} + +-- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition +-- +-- FragmentDefinition: +-- fragment FragmentName TypeCondition Directives(opt) SelectionSet +-- +parseFragmentDefinition :: Parser Fragment +parseFragmentDefinition = label "FragmentDefinition" $ do + keyword "fragment" + fragmentPosition <- getLocation + fragmentName <- parseName + fragmentBody fragmentName fragmentPosition + +-- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments +-- +-- InlineFragment: +-- ... TypeCondition(opt) Directives(opt) SelectionSet +-- +inlineFragment :: Parser (Selection RAW) +inlineFragment = label "InlineFragment" $ do + fragmentPosition <- spreadLiteral + InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition + +fragmentBody :: FieldName -> Position -> Parser Fragment +fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do + fragmentType <- parseTypeCondition + fragmentDirectives <- optionalDirectives + fragmentSelection <- parseSelectionSet + pure $ Fragment {..} diff --git a/src/Data/Morpheus/QuasiQuoter.hs b/src/Data/Morpheus/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/QuasiQuoter.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.QuasiQuoter + ( gql, + gqlExpression, + dsl, + dslExpression, + ) +where + +import Data.Morpheus.Error + ( gqlWarnings, + renderGQLErrors, + ) +import Data.Morpheus.Parser + ( parseRequest, + parseTypeDefinitions, + ) +import Data.Morpheus.Types.IO (GQLRequest (..)) +import Data.Morpheus.Types.Internal.Resolving + ( Result (..), + ) +import Data.Text + ( Text, + pack, + unpack, + ) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +gql :: QuasiQuoter +gql = + QuasiQuoter + { quoteExp = gqlExpression . pack, + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = notHandled "Declarations" + } + where + notHandled things = + error $ things ++ " are not supported by the GraphQL QuasiQuoter" + +gqlExpression :: Text -> Q Exp +gqlExpression queryText = case parseRequest request of + Failure errors -> fail (renderGQLErrors errors) + Success {result, warnings} -> + gqlWarnings warnings >> [|(result, query)|] + where + query = unpack queryText + request = + GQLRequest + { query = queryText, + operationName = Nothing, + variables = Nothing + } + +dsl :: QuasiQuoter +dsl = + QuasiQuoter + { quoteExp = dslExpression . pack, + quotePat = notHandled "Patterns", + quoteType = notHandled "Types", + quoteDec = notHandled "Declarations" + } + where + notHandled things = + error $ things ++ " are not supported by the GraphQL QuasiQuoter" + +dslExpression :: Text -> Q Exp +dslExpression doc = case parseTypeDefinitions doc of + Failure errors -> fail (renderGQLErrors errors) + Success {result, warnings} -> + gqlWarnings warnings >> [|result|] diff --git a/src/Data/Morpheus/Rendering/RenderGQL.hs b/src/Data/Morpheus/Rendering/RenderGQL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Rendering/RenderGQL.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Rendering.RenderGQL + ( RenderGQL (..), + renderObject, + renderIndent, + ) +where + +-- MORPHEUS +import Data.Semigroup ((<>)) +import Data.Text + ( Text, + intercalate, + ) + +type Rendering = Text + +class RenderGQL a where + render :: a -> Rendering + +renderIndent :: Rendering +renderIndent = " " + +renderObject :: (a -> Rendering) -> [a] -> Rendering +renderObject f list = + " { \n " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}" diff --git a/src/Data/Morpheus/Rendering/RenderIntrospection.hs b/src/Data/Morpheus/Rendering/RenderIntrospection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Rendering/RenderIntrospection.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Rendering.RenderIntrospection + ( render, + createObjectType, + ) +where + +import Data.Maybe (isJust) +-- Morpheus + +import Data.Morpheus.Internal.Utils + ( elems, + failure, + selectBy, + ) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Internal.AST + ( ArgumentsDefinition (..), + DataEnumValue (..), + DataInputUnion, + DataInputUnion, + DataTypeKind (..), + DataTypeWrapper (..), + DataUnion, + Description, + DirectiveDefinition (..), + DirectiveLocation, + FieldDefinition (..), + FieldName (..), + FieldsDefinition, + IN, + Message, + Meta (..), + OUT, + QUERY, + Schema, + TypeContent (..), + TypeDefinition (..), + TypeName (..), + TypeRef (..), + createInputUnionFields, + fieldVisibility, + kindOf, + lookupDeprecated, + lookupDeprecatedReason, + msg, + toGQLWrapper, + ) +import Data.Morpheus.Types.Internal.Resolving + ( ResModel, + Resolver, + mkBoolean, + mkList, + mkNull, + mkObject, + mkString, + ) +import Data.Semigroup ((<>)) +import Data.Text (pack) + +constRes :: Applicative m => a -> b -> m a +constRes = const . pure + +type Result e m a = Schema -> Resolver QUERY e m a + +class RenderSchema a where + render :: (Monad m) => a -> Schema -> Resolver QUERY e m (ResModel QUERY e m) + +instance RenderSchema DirectiveDefinition where + render + DirectiveDefinition + { directiveDefinitionName, + directiveDefinitionDescription, + directiveDefinitionLocations, + directiveDefinitionArgs + } + schema = + pure $ + mkObject + "__Directive" + [ renderFieldName directiveDefinitionName, + renderDescription directiveDefinitionDescription, + ("locations", render directiveDefinitionLocations schema), + ("args", mkList <$> renderArguments directiveDefinitionArgs schema) + ] + +instance RenderSchema a => RenderSchema [a] where + render ls schema = mkList <$> traverse (`render` schema) ls + +instance RenderSchema DirectiveLocation where + render locations _ = pure $ mkString (pack $ show locations) + +instance RenderSchema (TypeDefinition a) where + render TypeDefinition {typeName, typeMeta, typeContent} = __render typeContent + where + __render :: + (Monad m) => TypeContent bool a -> Schema -> Resolver QUERY e m (ResModel QUERY e m) + __render DataScalar {} = + constRes $ createLeafType SCALAR typeName typeMeta Nothing + __render (DataEnum enums) = + constRes $ + createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums) + __render (DataInputObject fields) = \lib -> + createInputObject typeName typeMeta + <$> traverse (`renderinputValue` lib) (elems fields) + __render DataObject {objectImplements, objectFields} = + pure . createObjectType typeName typeMeta objectImplements objectFields + __render (DataUnion union) = \schema -> + pure $ typeFromUnion schema (typeName, typeMeta, union) + __render (DataInputUnion members) = + renderInputUnion (typeName, typeMeta, members) + __render (DataInterface fields) = + renderInterface typeName Nothing fields + +renderFields :: Monad m => Schema -> FieldsDefinition cat -> Resolver QUERY e m [ResModel QUERY e m] +renderFields schema = traverse (`render` schema) . filter fieldVisibility . elems + +renderInterface :: + Monad m => TypeName -> Maybe Meta -> FieldsDefinition OUT -> Schema -> Resolver QUERY e m (ResModel QUERY e m) +renderInterface name meta fields schema = + pure $ + mkObject + "__Type" + [ renderKind INTERFACE, + renderName name, + description meta, + ("fields", mkList <$> renderFields schema fields), + ("possibleTypes", mkList <$> interfacePossibleTypes schema name) + ] + +interfacePossibleTypes :: + (Monad m) => + Schema -> + TypeName -> + Resolver QUERY e m [ResModel QUERY e m] +interfacePossibleTypes schema interfaceName = sequence $ concatMap implements (elems schema) + where + implements typeDef@TypeDefinition {typeContent = DataObject {objectImplements}, ..} + | interfaceName `elem` objectImplements = [render typeDef schema] + implements _ = [] + +createEnumValue :: Monad m => DataEnumValue -> ResModel QUERY e m +createEnumValue DataEnumValue {enumName, enumMeta} = + mkObject "__Field" $ + [ renderName enumName, + description enumMeta + ] + <> renderDeprecated enumMeta + +renderDeprecated :: + (Monad m) => + Maybe Meta -> + [(FieldName, Resolver QUERY e m (ResModel QUERY e m))] +renderDeprecated meta = + [ ("isDeprecated", pure $ mkBoolean (isJust $ meta >>= lookupDeprecated)), + ("deprecationReason", opt (pure . mkString) (meta >>= lookupDeprecated >>= lookupDeprecatedReason)) + ] + +description :: Monad m => Maybe Meta -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +description enumMeta = renderDescription (enumMeta >>= metaDescription) + +renderDescription :: Monad m => Maybe Description -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +renderDescription desc = ("description", opt (pure . mkString) desc) + +renderArguments :: (Monad m) => ArgumentsDefinition -> Schema -> Resolver QUERY e m [ResModel QUERY e m] +renderArguments ArgumentsDefinition {arguments} lib = traverse (`renderinputValue` lib) $ elems arguments +renderArguments NoArguments _ = pure [] + +instance RenderSchema (FieldDefinition cat) where + render field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}, fieldArgs, fieldMeta} lib = + do + kind <- renderTypeKind <$> lookupKind typeConName lib + pure + $ mkObject "__Field" + $ [ renderFieldName fieldName, + description fieldMeta, + ("args", mkList <$> renderArguments fieldArgs lib), + ("type", pure (withTypeWrapper field $ createType kind typeConName Nothing $ Just [])) + ] + <> renderDeprecated fieldMeta + +renderTypeKind :: DataTypeKind -> TypeKind +renderTypeKind KindScalar = SCALAR +renderTypeKind (KindObject _) = OBJECT +renderTypeKind KindUnion = UNION +renderTypeKind KindInputUnion = INPUT_OBJECT +renderTypeKind KindEnum = ENUM +renderTypeKind KindInputObject = INPUT_OBJECT +renderTypeKind KindList = LIST +renderTypeKind KindNonNull = NON_NULL +renderTypeKind KindInterface = INTERFACE + +lookupKind :: (Monad m) => TypeName -> Result e m DataTypeKind +lookupKind name schema = kindOf <$> selectBy ("Kind Not Found: " <> msg name) name schema + +renderinputValue :: + (Monad m) => + FieldDefinition IN -> + Result e m (ResModel QUERY e m) +renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input + +createInputObjectType :: + (Monad m) => FieldDefinition IN -> Result e m (ResModel QUERY e m) +createInputObjectType field@FieldDefinition {fieldType = TypeRef {typeConName}} lib = + do + kind <- renderTypeKind <$> lookupKind typeConName lib + pure $ withTypeWrapper field $ createType kind typeConName Nothing $ Just [] + +renderInputUnion :: + (Monad m) => + (TypeName, Maybe Meta, DataInputUnion) -> + Result e m (ResModel QUERY e m) +renderInputUnion (key, meta, fields) lib = + createInputObject key meta + <$> traverse + createField + (createInputUnionFields key $ map fst $ filter snd fields) + where + createField field = + createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib + +createLeafType :: + Monad m => + TypeKind -> + TypeName -> + Maybe Meta -> + Maybe [ResModel QUERY e m] -> + ResModel QUERY e m +createLeafType kind name meta enums = + mkObject + "__Type" + [ renderKind kind, + renderName name, + description meta, + ("enumValues", optList enums) + ] + +typeFromUnion :: Monad m => Schema -> (TypeName, Maybe Meta, DataUnion) -> ResModel QUERY e m +typeFromUnion schema (name, typeMeta, typeContent) = + mkObject + "__Type" + [ renderKind UNION, + renderName name, + description typeMeta, + ("possibleTypes", mkList <$> traverse (unionPossibleType schema) typeContent) + ] + +unionPossibleType :: Monad m => Schema -> TypeName -> Resolver QUERY e m (ResModel QUERY e m) +unionPossibleType schema name = + selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name schema + >>= (`render` schema) + +createObjectType :: + Monad m => TypeName -> Maybe Meta -> [TypeName] -> FieldsDefinition OUT -> Schema -> ResModel QUERY e m +createObjectType name meta interfaces fields schema = + mkObject + "__Type" + [ renderKind OBJECT, + renderName name, + description meta, + ("fields", mkList <$> renderFields schema fields), + ("interfaces", mkList <$> traverse (implementedInterface schema) interfaces) + ] + +implementedInterface :: + (Monad m) => + Schema -> + TypeName -> + Resolver QUERY e m (ResModel QUERY e m) +implementedInterface schema name = + selectBy ("INTERNAL: cant found Interface " <> msg name) name schema + >>= __render + where + __render typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef schema + __render _ = failure ("Type " <> msg name <> " must be an Interface" :: Message) + +optList :: Monad m => Maybe [ResModel QUERY e m] -> Resolver QUERY e m (ResModel QUERY e m) +optList = pure . maybe mkNull mkList + +createInputObject :: + Monad m => TypeName -> Maybe Meta -> [ResModel QUERY e m] -> ResModel QUERY e m +createInputObject name meta fields = + mkObject + "__Type" + [ renderKind INPUT_OBJECT, + renderName name, + description meta, + ("inputFields", pure $ mkList fields) + ] + +createType :: + Monad m => + TypeKind -> + TypeName -> + Maybe Meta -> + Maybe [ResModel QUERY e m] -> + ResModel QUERY e m +createType kind name desc fields = + mkObject + "__Type" + [ renderKind kind, + renderName name, + description desc, + ("fields", pure $ maybe mkNull mkList fields), + ("enumValues", pure $ mkList []) + ] + +opt :: Monad m => (a -> Resolver QUERY e m (ResModel QUERY e m)) -> Maybe a -> Resolver QUERY e m (ResModel QUERY e m) +opt f (Just x) = f x +opt _ Nothing = pure mkNull + +renderName :: Monad m => TypeName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +renderName = ("name",) . pure . mkString . readTypeName + +renderFieldName :: Monad m => FieldName -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +renderFieldName (FieldName name) = ("name", pure $ mkString name) + +renderKind :: Monad m => TypeKind -> (FieldName, Resolver QUERY e m (ResModel QUERY e m)) +renderKind = ("kind",) . pure . mkString . pack . show + +withTypeWrapper :: Monad m => FieldDefinition cat -> ResModel QUERY e m -> ResModel QUERY e m +withTypeWrapper FieldDefinition {fieldType = TypeRef {typeWrappers}} typ = + foldr wrapAs typ (toGQLWrapper typeWrappers) + +wrapAs :: Monad m => DataTypeWrapper -> ResModel QUERY e m -> ResModel QUERY e m +wrapAs wrapper contentType = + mkObject + "__Type" + [ renderKind (kind wrapper), + ("ofType", pure contentType) + ] + where + kind ListType = LIST + kind NonNullType = NON_NULL + +createInputValueWith :: + Monad m => FieldName -> Maybe Meta -> ResModel QUERY e m -> ResModel QUERY e m +createInputValueWith name meta ivType = + mkObject + "__InputValue" + [ renderFieldName name, + description meta, + ("type", pure ivType) + ] diff --git a/src/Data/Morpheus/Schema/Directives.hs b/src/Data/Morpheus/Schema/Directives.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Directives.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Schema.Directives (defaultDirectives) where + +import Data.Morpheus.Internal.Utils + ( singleton, + ) +import Data.Morpheus.Types.Internal.AST + ( ArgumentsDefinition (..), + DirectiveDefinition (..), + DirectiveLocation (..), + TypeWrapper (..), + createField, + ) + +defaultDirectives :: [DirectiveDefinition] +defaultDirectives = + [ DirectiveDefinition + { directiveDefinitionName = "skip", + directiveDefinitionDescription = Just "Directs the executor to skip this field or fragment when the `if` argument is true.", + directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT], + directiveDefinitionArgs = argumentsIf + }, + DirectiveDefinition + { directiveDefinitionName = "include", + directiveDefinitionDescription = Just "Directs the executor to include this field or fragment only when the `if` argument is true.", + directiveDefinitionLocations = [FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT], + directiveDefinitionArgs = argumentsIf + }, + DirectiveDefinition + { directiveDefinitionName = "deprecated", + directiveDefinitionDescription = Just "Marks an element of a GraphQL schema as no longer supported.", + directiveDefinitionLocations = [FIELD_DEFINITION, ENUM_VALUE], + directiveDefinitionArgs = + singleton $ + createField + NoArguments + "reason" + ([TypeMaybe], "String") + } + ] + +argumentsIf :: ArgumentsDefinition +argumentsIf = singleton $ createField NoArguments "if" ([], "Boolean") diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Schema.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Schema.Schema + ( withSystemTypes, + ) +where + +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( (<:>), + singleton, + ) +import Data.Morpheus.QuasiQuoter (dsl) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + DataFingerprint (..), + FieldsDefinition, + Message, + OUT, + Schema (..), + TypeContent (..), + TypeDefinition (..), + TypeUpdater, + TypeWrapper (..), + createArgument, + createField, + insertType, + internalFingerprint, + unsafeFromFields, + ) +import Data.Morpheus.Types.Internal.Resolving + ( failure, + resolveUpdates, + ) + +withSystemTypes :: TypeUpdater +withSystemTypes s@Schema {query = q@TypeDefinition {typeContent = DataObject inter fields}} = + ( do + fs <- fields <:> hiddenFields + pure $ s {query = q {typeContent = DataObject inter fs}} + ) + >>= (`resolveUpdates` map (insertType . internalType) schemaTypes) +withSystemTypes _ = failure ("Query must be an Object Type" :: Message) + +hiddenFields :: FieldsDefinition OUT +hiddenFields = + unsafeFromFields + [ createField + (singleton (createArgument "name" ([], "String"))) + "__type" + ([TypeMaybe], "__Type"), + createField + NoArguments + "__schema" + ([], "__Schema") + ] + +internalType :: TypeDefinition a -> TypeDefinition a +internalType + tyDef@TypeDefinition + { typeFingerprint = DataFingerprint name xs + } = + tyDef {typeFingerprint = internalFingerprint name xs} + +schemaTypes :: [TypeDefinition ANY] +schemaTypes = + [dsl| + +# default scalars +scalar Boolean +scalar Int +scalar Float +scalar String +scalar ID + +type __Schema { + types: [__Type!]! + queryType: __Type! + mutationType: __Type + subscriptionType: __Type + directives: [__Directive!]! +} + +type __Type { + kind: __TypeKind! + name: String + description: String + + # OBJECT and INTERFACE only + fields(includeDeprecated: Boolean = false): [__Field!] + + # OBJECT only + interfaces: [__Type!] + + # INTERFACE and UNION only + possibleTypes: [__Type!] + + # ENUM only + enumValues(includeDeprecated: Boolean = false): [__EnumValue!] + + # INPUT_OBJECT only + inputFields: [__InputValue!] + + # NON_NULL and LIST only + ofType: __Type +} + +type __Field { + name: String! + description: String + args: [__InputValue!]! + type: __Type! + isDeprecated: Boolean! + deprecationReason: String +} + +type __InputValue { + name: String! + description: String + type: __Type! + defaultValue: String +} + +type __EnumValue { + name: String! + description: String + isDeprecated: Boolean! + deprecationReason: String +} + +type __Directive { + name: String! + description: String + locations: [__DirectiveLocation!]! + args: [__InputValue!]! +} + +enum __DirectiveLocation { + QUERY + MUTATION + SUBSCRIPTION + FIELD + FRAGMENT_DEFINITION + FRAGMENT_SPREAD + INLINE_FRAGMENT + SCHEMA + SCALAR + OBJECT + FIELD_DEFINITION + ARGUMENT_DEFINITION + INTERFACE + UNION + ENUM + ENUM_VALUE + INPUT_OBJECT + INPUT_FIELD_DEFINITION +} + +enum __TypeKind { + SCALAR + OBJECT + INTERFACE + UNION + ENUM + INPUT_OBJECT + LIST + NON_NULL +} + +|] diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/SchemaAPI.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Schema.SchemaAPI + ( withSystemFields, + ) +where + +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( (<:>), + elems, + empty, + selectOr, + ) +import Data.Morpheus.Rendering.RenderIntrospection + ( createObjectType, + render, + ) +import Data.Morpheus.Schema.Directives + ( defaultDirectives, + ) +import Data.Morpheus.Schema.Schema + ( + ) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + OUT, + QUERY, + ScalarValue (..), + Schema (..), + TypeDefinition (..), + TypeName (..), + Value (..), + ) +import Data.Morpheus.Types.Internal.Resolving + ( ResModel, + Resolver, + ResultT, + RootResModel (..), + mkList, + mkNull, + mkObject, + withArguments, + ) + +resolveTypes :: + Monad m => Schema -> Resolver QUERY e m (ResModel QUERY e m) +resolveTypes schema = mkList <$> traverse (`render` schema) (elems schema) + +buildSchemaLinkType :: + Monad m => Maybe (TypeDefinition OUT) -> Schema -> ResModel QUERY e m +buildSchemaLinkType (Just TypeDefinition {typeName}) = createObjectType typeName Nothing [] empty +buildSchemaLinkType Nothing = const mkNull + +findType :: + Monad m => + TypeName -> + Schema -> + Resolver QUERY e m (ResModel QUERY e m) +findType name schema = selectOr (pure mkNull) (`render` schema) name schema + +renderDirectives :: + Monad m => + Schema -> + Resolver QUERY e m (ResModel QUERY e m) +renderDirectives schema = + mkList + <$> traverse + (`render` schema) + defaultDirectives + +schemaResolver :: + Monad m => + Schema -> + Resolver QUERY e m (ResModel QUERY e m) +schemaResolver schema@Schema {query, mutation, subscription} = + pure $ + mkObject + "__Schema" + [ ("types", resolveTypes schema), + ("queryType", pure $ buildSchemaLinkType (Just query) schema), + ("mutationType", pure $ buildSchemaLinkType mutation schema), + ("subscriptionType", pure $ buildSchemaLinkType subscription schema), + ("directives", renderDirectives schema) + ] + +schemaAPI :: Monad m => Schema -> ResModel QUERY e m +schemaAPI schema = + mkObject + "Root" + [ ("__type", withArguments typeResolver), + ("__schema", schemaResolver schema) + ] + where + typeResolver = selectOr (pure mkNull) handleArg "name" + where + handleArg + Argument + { argumentValue = (Scalar (String typename)) + } = findType (TypeName typename) schema + handleArg _ = pure mkNull + +withSystemFields :: Monad m => Schema -> RootResModel e m -> ResultT e' m (RootResModel e m) +withSystemFields schema RootResModel {query, ..} = + pure $ + RootResModel + { query = query >>= (<:> schemaAPI schema), + .. + } diff --git a/src/Data/Morpheus/Schema/TypeKind.hs b/src/Data/Morpheus/Schema/TypeKind.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/TypeKind.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Schema.TypeKind + ( TypeKind (..), + ) +where + +import Data.Aeson (FromJSON (..)) +import GHC.Generics + +data TypeKind + = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving (Eq, Generic, FromJSON, Show) diff --git a/src/Data/Morpheus/Types/IO.hs b/src/Data/Morpheus/Types/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/IO.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.IO + ( GQLRequest (..), + GQLResponse (..), + JSONResponse (..), + renderResponse, + MapAPI (..), + ) +where + +import Data.Aeson + ( (.:?), + (.=), + FromJSON (..), + ToJSON (..), + encode, + object, + pairs, + withObject, + ) +import qualified Data.Aeson as Aeson + ( Value (..), + ) +import Data.Aeson.Internal + ( formatError, + ifromJSON, + ) +import Data.Aeson.Parser + ( eitherDecodeWith, + jsonNoDup, + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB + ( ByteString, + fromStrict, + toStrict, + ) +import qualified Data.HashMap.Lazy as LH + ( toList, + ) +-- MORPHEUS +import Data.Morpheus.Error.Utils (badRequestError) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + GQLError (..), + Token, + ValidValue, + ) +import Data.Morpheus.Types.Internal.Resolving.Core + ( Failure (..), + Result (..), + ) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT + ( Text, + fromStrict, + toStrict, + ) +import Data.Text.Lazy.Encoding + ( decodeUtf8, + encodeUtf8, + ) +import GHC.Generics (Generic) + +decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest +decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of + Left (path, x) -> failure $ formatError path x + Right value -> pure value + +class MapAPI a where + mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m a + +instance MapAPI LB.ByteString where + mapAPI api request = case decodeNoDup request of + Left aesonError -> pure $ badRequestError aesonError + Right req -> encode <$> api req + +instance MapAPI LT.Text where + mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8 + +instance MapAPI ByteString where + mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict + +instance MapAPI Text where + mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict + +renderResponse :: Result e ValidValue -> GQLResponse +renderResponse (Failure errors) = Errors errors +renderResponse Success {result} = Data result + +instance FromJSON a => FromJSON (JSONResponse a) where + parseJSON = withObject "JSONResponse" objectParser + where + objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors" + +data JSONResponse a = JSONResponse + { responseData :: Maybe a, + responseErrors :: Maybe [GQLError] + } + deriving (Generic, Show, ToJSON) + +-- | GraphQL HTTP Request Body +data GQLRequest = GQLRequest + { query :: Token, + operationName :: Maybe FieldName, + variables :: Maybe Aeson.Value + } + deriving (Show, Generic, FromJSON, ToJSON) + +-- | GraphQL Response +data GQLResponse + = Data ValidValue + | Errors [GQLError] + 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 + toJSON (Data gqlData) = object ["data" .= toJSON gqlData] + toJSON (Errors errors) = object ["errors" .= toJSON errors] + + ---------------------------------------------------------- + toEncoding (Data _data) = pairs $ "data" .= _data + toEncoding (Errors _errors) = pairs $ "errors" .= _errors diff --git a/src/Data/Morpheus/Types/Internal/AST.hs b/src/Data/Morpheus/Types/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Morpheus.Types.Internal.AST + ( -- BASE + Ref (..), + Position (..), + Message, + anonymousRef, + FieldName (..), + Description, + Stage, + RESOLVED, + VALID, + RAW, + VALIDATION_MODE (..), + -- VALUE + Value (..), + ScalarValue (..), + Object, + GQLValue (..), + replaceValue, + decodeScientific, + convertToJSONName, + convertToHaskellName, + RawValue, + ValidValue, + RawObject, + ValidObject, + ResolvedObject, + ResolvedValue, + splitDuplicates, + removeDuplicates, + -- Selection + Argument (..), + Arguments, + SelectionSet, + SelectionContent (..), + Selection (..), + Fragments, + Fragment (..), + -- OPERATION + Operation (..), + Variable (..), + VariableDefinitions, + DefaultValue, + getOperationName, + getOperationDataType, + -- DSL + ScalarDefinition (..), + DataEnum, + FieldsDefinition, + ArgumentDefinition, + DataUnion, + ArgumentsDefinition (..), + FieldDefinition (..), + InputFieldsDefinition, + TypeContent (..), + TypeDefinition (..), + Schema (..), + DataTypeWrapper (..), + DataTypeKind (..), + DataFingerprint (..), + TypeWrapper (..), + TypeRef (..), + DataEnumValue (..), + OperationType (..), + QUERY, + MUTATION, + SUBSCRIPTION, + Meta (..), + Directive (..), + TypeUpdater, + TypeD (..), + ConsD (..), + GQLTypeD (..), + TypeCategory, + DataInputUnion, + VariableContent (..), + TypeLib, + initTypeLib, + defineType, + isFieldNullable, + kindOf, + toNullableField, + toListField, + isObject, + isInput, + toHSWrappers, + isNullable, + toGQLWrapper, + isWeaker, + isSubscription, + isOutputObject, + sysTypes, + isSystemTypeName, + isEntNode, + createField, + createArgument, + createEnumType, + createScalarType, + createType, + createUnionType, + createAlias, + createInputUnionFields, + fieldVisibility, + createEnumValue, + insertType, + lookupDeprecated, + lookupDeprecatedReason, + hasArguments, + lookupWith, + typeFromScalar, + -- Temaplate Haskell + hsTypeName, + -- LOCAL + GQLQuery (..), + Variables, + isNullableWrapper, + unsafeFromFields, + OrderedMap, + GQLError (..), + GQLErrors, + ObjectEntry (..), + UnionTag (..), + __inputname, + updateSchema, + internalFingerprint, + ANY, + IN, + OUT, + FromAny (..), + ToAny (..), + TRUE, + FALSE, + TypeName (..), + Token, + Msg (..), + intercalateName, + toFieldName, + TypeNameRef (..), + isEnum, + Fields, + argumentsToFields, + fieldsToArguments, + mkCons, + mkConsEnum, + Directives, + DirectiveDefinitions, + DirectiveDefinition (..), + DirectiveLocation (..), + ) +where + +import Data.HashMap.Lazy (HashMap) +-- Morpheus +import Data.Morpheus.Types.Internal.AST.Base +import Data.Morpheus.Types.Internal.AST.Data +import Data.Morpheus.Types.Internal.AST.OrderedMap +import Data.Morpheus.Types.Internal.AST.Selection +import Data.Morpheus.Types.Internal.AST.TH +import Data.Morpheus.Types.Internal.AST.Value +import Language.Haskell.TH.Syntax (Lift) + +type Variables = HashMap FieldName ResolvedValue + +data GQLQuery = GQLQuery + { fragments :: Fragments, + operation :: Operation RAW, + inputVariables :: [(FieldName, ResolvedValue)] + } + deriving (Show, Lift) diff --git a/src/Data/Morpheus/Types/Internal/AST/Base.hs b/src/Data/Morpheus/Types/Internal/AST/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/Base.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.Internal.AST.Base + ( Ref (..), + Position (..), + Message (..), + FieldName (..), + Description, + VALID, + RAW, + TypeWrapper (..), + Stage (..), + RESOLVED, + TypeRef (..), + VALIDATION_MODE (..), + OperationType (..), + QUERY, + MUTATION, + SUBSCRIPTION, + DataTypeKind (..), + DataFingerprint (..), + DataTypeWrapper (..), + Token, + anonymousRef, + toHSWrappers, + toGQLWrapper, + sysTypes, + isNullable, + isWeaker, + isSubscription, + isOutputObject, + isSystemTypeName, + isObject, + isInput, + isNullableWrapper, + sysFields, + typeFromScalar, + hsTypeName, + toOperationType, + splitDuplicates, + removeDuplicates, + GQLError (..), + GQLErrors, + internalFingerprint, + TRUE, + FALSE, + TypeName (..), + Msg (..), + intercalateName, + toFieldName, + TypeNameRef (..), + convertToJSONName, + convertToHaskellName, + ) +where + +import Data.Aeson + ( FromJSON, + ToJSON, + Value, + encode, + ) +import Data.ByteString.Lazy.Char8 (ByteString, unpack) +import Data.Hashable (Hashable) +import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..)) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString) +import Data.Text (Text, intercalate, pack) +import qualified Data.Text as T +import GHC.Generics (Generic) +-- import Instances.TH.Lift () +import Language.Haskell.TH (stringE) +import Language.Haskell.TH.Syntax (Lift (..)) + +type TRUE = 'True + +type FALSE = 'False + +-- Strings +type Token = Text + +-- Error / Warning Messages +newtype Message = Message {readMessage :: Text} + deriving + (Generic) + deriving newtype + (Show, Eq, Ord, IsString, Semigroup, Hashable, FromJSON, ToJSON) + +instance Lift Message where + lift = stringE . T.unpack . readMessage + +class Msg a where + msg :: a -> Message + msgSepBy :: Text -> [a] -> Message + msgSepBy t = Message . intercalate t . map (readMessage . msg) + +instance Msg String where + msg = Message . pack + +instance Msg ByteString where + msg = msg . unpack + +instance Msg Text where + msg = Message + +instance Msg Value where + msg = msg . encode + +-- FieldName : lower case names +newtype FieldName = FieldName {readName :: Text} + deriving + (Generic) + deriving newtype + (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON) + +instance Lift FieldName where + lift = stringE . T.unpack . readName + +instance Msg FieldName where + msg FieldName {readName} = Message $ "\"" <> readName <> "\"" + +instance RenderGQL FieldName where + render = readName + +intercalateName :: FieldName -> [FieldName] -> FieldName +intercalateName (FieldName x) = FieldName . intercalate x . map readName + +toFieldName :: TypeName -> FieldName +toFieldName = FieldName . readTypeName + +-- TypeName +newtype TypeName = TypeName {readTypeName :: Text} + deriving + (Generic) + deriving newtype + (Show, Ord, Eq, IsString, Hashable, Semigroup, FromJSON, ToJSON) + +instance Lift TypeName where + lift = stringE . T.unpack . readTypeName + +instance Msg TypeName where + msg TypeName {readTypeName} = Message $ "\"" <> readTypeName <> "\"" + +instance RenderGQL TypeName where + render = readTypeName + +-- Description +type Description = Text + +data Stage = RAW | RESOLVED | VALID + +data Position = Position + { line :: Int, + column :: Int + } + deriving (Show, Generic, FromJSON, ToJSON, Lift) + +-- Positions 2 Value withs same structire +-- but different Positions should be Equal +instance Eq Position where + _ == _ = True + +data GQLError = GQLError + { message :: Message, + locations :: [Position] + } + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +type GQLErrors = [GQLError] + +type RAW = 'RAW + +type RESOLVED = 'RESOLVED + +type VALID = 'VALID + +data VALIDATION_MODE + = WITHOUT_VARIABLES + | FULL_VALIDATION + deriving (Eq, Show) + +data DataFingerprint = DataFingerprint TypeName [String] deriving (Show, Eq, Ord, Lift) + +internalFingerprint :: TypeName -> [String] -> DataFingerprint +internalFingerprint name = DataFingerprint ("SYSTEM.INTERNAL." <> name) + +data OperationType + = Query + | Subscription + | Mutation + deriving (Show, Eq, Lift) + +type QUERY = 'Query + +type MUTATION = 'Mutation + +type SUBSCRIPTION = 'Subscription + +data TypeNameRef = TypeNameRef + { typeNameRef :: TypeName, + typeNamePosition :: Position + } + deriving (Show, Lift, Eq) + +-- Refference with Position information +-- +-- includes position for debugging, where Ref "a" 1 === Ref "a" 3 +-- +data Ref = Ref + { refName :: FieldName, + refPosition :: Position + } + deriving (Show, Lift, Eq) + +instance Ord Ref where + compare (Ref x _) (Ref y _) = compare x y + +anonymousRef :: FieldName -> Ref +anonymousRef refName = Ref {refName, refPosition = Position 0 0} + +-- TypeRef +------------------------------------------------------------------- +data TypeRef = TypeRef + { typeConName :: TypeName, + typeArgs :: Maybe TypeName, + typeWrappers :: [TypeWrapper] + } + deriving (Show, Eq, Lift) + +isNullable :: TypeRef -> Bool +isNullable TypeRef {typeWrappers = typeWrappers} = isNullableWrapper typeWrappers + +instance RenderGQL TypeRef where + render TypeRef {typeConName, typeWrappers} = renderWrapped typeConName typeWrappers + +instance Msg TypeRef where + msg = msg . FieldName . render + +-- Kind +----------------------------------------------------------------------------------- +data DataTypeKind + = KindScalar + | KindObject (Maybe OperationType) + | KindUnion + | KindEnum + | KindInputObject + | KindList + | KindNonNull + | KindInputUnion + | KindInterface + deriving (Eq, Show, Lift) + +isSubscription :: DataTypeKind -> Bool +isSubscription (KindObject (Just Subscription)) = True +isSubscription _ = False + +isOutputObject :: DataTypeKind -> Bool +isOutputObject (KindObject _) = True +isOutputObject KindInterface = True +isOutputObject _ = False + +isObject :: DataTypeKind -> Bool +isObject (KindObject _) = True +isObject KindInputObject = True +isObject KindInterface = True +isObject _ = False + +isInput :: DataTypeKind -> Bool +isInput KindInputObject = True +isInput _ = False + +-- TypeWrappers +----------------------------------------------------------------------------------- +data TypeWrapper + = TypeList + | TypeMaybe + deriving (Show, Eq, Lift) + +data DataTypeWrapper + = ListType + | NonNullType + deriving (Show, Lift) + +isNullableWrapper :: [TypeWrapper] -> Bool +isNullableWrapper (TypeMaybe : _) = True +isNullableWrapper _ = False + +isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool +isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2 +isWeaker (TypeMaybe : _) _ = True +isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2 +isWeaker _ _ = False + +toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper] +toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw) +toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw +toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw +toGQLWrapper [TypeMaybe] = [] +toGQLWrapper [] = [NonNullType] + +toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper] +toHSWrappers (NonNullType : (NonNullType : xs)) = + toHSWrappers (NonNullType : xs) +toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs +toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs +toHSWrappers [] = [TypeMaybe] +toHSWrappers [NonNullType] = [] + +renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Token +renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers) + where + showGQLWrapper [] = render x + showGQLWrapper (ListType : xs) = "[" <> showGQLWrapper xs <> "]" + showGQLWrapper (NonNullType : xs) = showGQLWrapper xs <> "!" + +isSystemTypeName :: TypeName -> Bool +isSystemTypeName = (`elem` sysTypes) + +sysTypes :: [TypeName] +sysTypes = + [ "__Schema", + "__Type", + "__Directive", + "__TypeKind", + "__Field", + "__DirectiveLocation", + "__InputValue", + "__EnumValue", + "String", + "Float", + "Int", + "Boolean", + "ID" + ] + +sysFields :: [FieldName] +sysFields = ["__typename", "__schema", "__type"] + +typeFromScalar :: TypeName -> TypeName +typeFromScalar "Boolean" = "Bool" +typeFromScalar "Int" = "Int" +typeFromScalar "Float" = "Float" +typeFromScalar "String" = "Text" +typeFromScalar "ID" = "ID" +typeFromScalar _ = "ScalarValue" + +hsTypeName :: TypeName -> TypeName +hsTypeName "String" = "Text" +hsTypeName "Boolean" = "Bool" +hsTypeName name = name + +toOperationType :: TypeName -> Maybe OperationType +toOperationType "Subscription" = Just Subscription +toOperationType "Mutation" = Just Mutation +toOperationType "Query" = Just Query +toOperationType _ = Nothing + +removeDuplicates :: Eq a => [a] -> [a] +removeDuplicates = fst . splitDuplicates + +-- elems -> (unique elements, duplicate elems) +splitDuplicates :: Eq a => [a] -> ([a], [a]) +splitDuplicates = collectElems ([], []) + where + collectElems :: Eq a => ([a], [a]) -> [a] -> ([a], [a]) + collectElems collected [] = collected + collectElems (collected, errors) (x : xs) + | x `elem` collected = collectElems (collected, errors <> [x]) xs + | otherwise = collectElems (collected <> [x], errors) xs + +-- handle reserved Names +isReserved :: FieldName -> Bool +isReserved "case" = True +isReserved "class" = True +isReserved "data" = True +isReserved "default" = True +isReserved "deriving" = True +isReserved "do" = True +isReserved "else" = True +isReserved "foreign" = True +isReserved "if" = True +isReserved "import" = True +isReserved "in" = True +isReserved "infix" = True +isReserved "infixl" = True +isReserved "infixr" = True +isReserved "instance" = True +isReserved "let" = True +isReserved "module" = True +isReserved "newtype" = True +isReserved "of" = True +isReserved "then" = True +isReserved "type" = True +isReserved "where" = True +isReserved "_" = True +isReserved _ = False +{-# INLINE isReserved #-} + +convertToJSONName :: FieldName -> FieldName +convertToJSONName (FieldName hsName) + | not (T.null hsName) && isReserved (FieldName name) && (T.last hsName == '\'') = FieldName name + | otherwise = FieldName hsName + where + name = T.init hsName + +convertToHaskellName :: FieldName -> FieldName +convertToHaskellName name + | isReserved name = name <> "'" + | otherwise = name diff --git a/src/Data/Morpheus/Types/Internal/AST/Data.hs b/src/Data/Morpheus/Types/Internal/AST/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/Data.hs @@ -0,0 +1,765 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.AST.Data + ( Arguments, + ScalarDefinition (..), + DataEnum, + FieldsDefinition, + ArgumentDefinition, + DataUnion, + ArgumentsDefinition (..), + FieldDefinition (..), + InputFieldsDefinition, + TypeContent (..), + TypeDefinition (..), + Schema (..), + DataEnumValue (..), + TypeLib, + Meta (..), + Directive (..), + TypeUpdater, + TypeCategory, + DataInputUnion, + Argument (..), + Fields, + createField, + createArgument, + createEnumType, + createScalarType, + createType, + createUnionType, + createAlias, + createInputUnionFields, + createEnumValue, + defineType, + isTypeDefined, + initTypeLib, + isFieldNullable, + insertType, + fieldVisibility, + kindOf, + toNullableField, + toListField, + isEntNode, + lookupDeprecated, + lookupDeprecatedReason, + lookupWith, + hasArguments, + unsafeFromFields, + __inputname, + updateSchema, + OUT, + IN, + ANY, + FromAny (..), + ToAny (..), + DirectiveDefinitions, + DirectiveDefinition (..), + Directives, + argumentsToFields, + fieldsToArguments, + DirectiveLocation (..), + ) +where + +import Data.HashMap.Lazy + ( HashMap, + union, + ) +import qualified Data.HashMap.Lazy as HM +import Data.List (find) +-- MORPHEUS + +import Data.Morpheus.Error (globalErrorMessage) +import Data.Morpheus.Error.NameCollision + ( NameCollision (..), + ) +import Data.Morpheus.Error.Schema (nameCollisionError) +import Data.Morpheus.Internal.Utils + ( Collection (..), + KeyOf (..), + Listable (..), + Merge (..), + Selectable (..), + elems, + ) +import Data.Morpheus.Rendering.RenderGQL + ( RenderGQL (..), + renderIndent, + renderObject, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( DataFingerprint (..), + DataTypeKind (..), + Description, + FieldName, + FieldName (..), + GQLError (..), + Msg (..), + Position, + Stage, + TRUE, + Token, + TypeName, + TypeRef (..), + TypeWrapper (..), + VALID, + isNullable, + isSystemTypeName, + msg, + sysFields, + toFieldName, + toOperationType, + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap, + unsafeFromValues, + ) +import Data.Morpheus.Types.Internal.AST.Value + ( ScalarValue (..), + ValidValue, + Value (..), + ) +import Data.Morpheus.Types.Internal.Resolving.Core + ( Failure (..), + LibUpdater, + resolveUpdates, + ) +import Data.Semigroup ((<>), Semigroup (..)) +import Data.Text (intercalate) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift (..)) + +type DataEnum = [DataEnumValue] + +type DataUnion = [TypeName] + +type DataInputUnion = [(TypeName, Bool)] + +-- scalar +------------------------------------------------------------------ +newtype ScalarDefinition = ScalarDefinition + {validateValue :: ValidValue -> Either Token ValidValue} + +instance Show ScalarDefinition where + show _ = "ScalarDefinition" + +instance Lift ScalarDefinition where + lift _ = [|ScalarDefinition pure|] + +data Argument (valid :: Stage) = Argument + { argumentName :: FieldName, + argumentValue :: Value valid, + argumentPosition :: Position + } + deriving (Show, Eq, Lift) + +instance KeyOf (Argument stage) where + keyOf = argumentName + +instance NameCollision (Argument s) where + nameCollision _ Argument {argumentName, argumentPosition} = + GQLError + { message = "There can Be only One Argument Named " <> msg argumentName, + locations = [argumentPosition] + } + +type Arguments s = OrderedMap FieldName (Argument s) + +-- directive +------------------------------------------------------------------ +data Directive (s :: Stage) = Directive + { directiveName :: FieldName, + directivePosition :: Position, + directiveArgs :: Arguments s + } + deriving (Show, Lift, Eq) + +instance KeyOf (Directive s) where + keyOf = directiveName + +type Directives s = [Directive s] + +data DirectiveDefinition = DirectiveDefinition + { directiveDefinitionName :: FieldName, + directiveDefinitionDescription :: Maybe Description, + directiveDefinitionLocations :: [DirectiveLocation], + directiveDefinitionArgs :: ArgumentsDefinition + } + deriving (Show, Lift) + +type DirectiveDefinitions = [DirectiveDefinition] + +instance KeyOf DirectiveDefinition where + keyOf = directiveDefinitionName + +instance Selectable DirectiveDefinition ArgumentDefinition where + selectOr fb f key DirectiveDefinition {directiveDefinitionArgs} = + selectOr fb f key directiveDefinitionArgs + +data DirectiveLocation + = QUERY + | MUTATION + | SUBSCRIPTION + | FIELD + | FRAGMENT_DEFINITION + | FRAGMENT_SPREAD + | INLINE_FRAGMENT + | SCHEMA + | SCALAR + | OBJECT + | FIELD_DEFINITION + | ARGUMENT_DEFINITION + | INTERFACE + | UNION + | ENUM + | ENUM_VALUE + | INPUT_OBJECT + | INPUT_FIELD_DEFINITION + deriving (Show, Eq, Lift) + +instance Msg DirectiveLocation where + msg = msg . show + +lookupDeprecated :: Meta -> Maybe (Directive VALID) +lookupDeprecated Meta {metaDirectives} = find isDeprecation metaDirectives + where + isDeprecation Directive {directiveName = "deprecated"} = True + isDeprecation _ = False + +lookupDeprecatedReason :: Directive VALID -> Maybe Description +lookupDeprecatedReason Directive {directiveArgs} = + selectOr Nothing (Just . maybeString) "reason" directiveArgs + where + maybeString :: Argument VALID -> Description + maybeString Argument {argumentValue = (Scalar (String x))} = x + maybeString _ = "can't read deprecated Reason Value" + +-- META +data Meta = Meta + { metaDescription :: Maybe Description, + metaDirectives :: [Directive VALID] + } + deriving (Show, Lift) + +-- ENUM VALUE +data DataEnumValue = DataEnumValue + { enumName :: TypeName, + enumMeta :: Maybe Meta + } + deriving (Show, Lift) + +instance RenderGQL DataEnumValue where + render DataEnumValue {enumName} = render enumName + +-- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema +--------------------------------------------------------------------------- +-- SchemaDefinition : +-- schema Directives[Const](opt) { RootOperationTypeDefinition(list)} +-- +-- RootOperationTypeDefinition : +-- OperationType: NamedType + +data Schema = Schema + { types :: TypeLib, + query :: TypeDefinition 'Out, + mutation :: Maybe (TypeDefinition 'Out), + subscription :: Maybe (TypeDefinition 'Out) + } + deriving (Show) + +type TypeLib = HashMap TypeName (TypeDefinition ANY) + +instance Selectable Schema (TypeDefinition ANY) where + selectOr fb f name lib = maybe fb f (lookupDataType name lib) + +instance Listable (TypeDefinition ANY) Schema where + elems = HM.elems . typeRegister + fromElems types = case popByKey "Query" types of + (Nothing, _) -> failure (globalErrorMessage "INTERNAL: Query Not Defined") + (Just query, lib1) -> do + let (mutation, lib2) = popByKey "Mutation" lib1 + let (subscription, lib3) = popByKey "Subscription" lib2 + pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription} + +initTypeLib :: TypeDefinition 'Out -> Schema +initTypeLib query = + Schema + { types = empty, + query = query, + mutation = Nothing, + subscription = Nothing + } + +typeRegister :: Schema -> TypeLib +typeRegister Schema {types, query, mutation, subscription} = + types + `union` HM.fromList + (concatMap fromOperation [Just query, mutation, subscription]) + +lookupDataType :: TypeName -> Schema -> Maybe (TypeDefinition ANY) +lookupDataType name = HM.lookup name . typeRegister + +isTypeDefined :: TypeName -> Schema -> Maybe DataFingerprint +isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib + +-- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types +------------------------------------------------------------------------- +-- TypeDefinition : +-- ScalarTypeDefinition +-- ObjectTypeDefinition +-- InterfaceTypeDefinition +-- UnionTypeDefinition +-- EnumTypeDefinition +-- InputObjectTypeDefinition + +data TypeDefinition (a :: TypeCategory) = TypeDefinition + { typeName :: TypeName, + typeFingerprint :: DataFingerprint, + typeMeta :: Maybe Meta, + typeContent :: TypeContent TRUE a + } + deriving (Show, Lift) + +instance KeyOf (TypeDefinition a) where + type KEY (TypeDefinition a) = TypeName + keyOf = typeName + +data TypeCategory = In | Out | Any + +type IN = 'In + +type OUT = 'Out + +type ANY = 'Any + +class ToAny a where + toAny :: a (k :: TypeCategory) -> a ANY + +instance ToAny TypeDefinition where + toAny TypeDefinition {typeContent, ..} = TypeDefinition {typeContent = toAny typeContent, ..} + +instance ToAny (TypeContent TRUE) where + toAny DataScalar {..} = DataScalar {..} + toAny DataEnum {..} = DataEnum {..} + toAny DataInputObject {..} = DataInputObject {..} + toAny DataInputUnion {..} = DataInputUnion {..} + toAny DataObject {..} = DataObject {..} + toAny DataUnion {..} = DataUnion {..} + toAny DataInterface {..} = DataInterface {..} + +class FromAny a (k :: TypeCategory) where + fromAny :: a ANY -> Maybe (a k) + +instance (FromAny (TypeContent TRUE) a) => FromAny TypeDefinition a where + fromAny TypeDefinition {typeContent, ..} = bla <$> fromAny typeContent + where + bla x = TypeDefinition {typeContent = x, ..} + +instance FromAny (TypeContent TRUE) IN where + fromAny DataScalar {..} = Just DataScalar {..} + fromAny DataEnum {..} = Just DataEnum {..} + fromAny DataInputObject {..} = Just DataInputObject {..} + fromAny DataInputUnion {..} = Just DataInputUnion {..} + fromAny _ = Nothing + +instance FromAny (TypeContent TRUE) OUT where + fromAny DataScalar {..} = Just DataScalar {..} + fromAny DataEnum {..} = Just DataEnum {..} + fromAny DataObject {..} = Just DataObject {..} + fromAny DataUnion {..} = Just DataUnion {..} + fromAny DataInterface {..} = Just DataInterface {..} + fromAny _ = Nothing + +class SelectType (c :: TypeCategory) (a :: TypeCategory) where + type IsSelected c a :: Bool + +instance SelectType ANY a where + type IsSelected ANY a = TRUE + +instance SelectType OUT OUT where + type IsSelected OUT OUT = TRUE + +instance SelectType IN IN where + type IsSelected IN IN = TRUE + +data TypeContent (b :: Bool) (a :: TypeCategory) where + DataScalar :: + { dataScalar :: ScalarDefinition + } -> + TypeContent TRUE a + DataEnum :: + { enumMembers :: DataEnum + } -> + TypeContent TRUE a + DataInputObject :: + { inputObjectFields :: FieldsDefinition IN + } -> + TypeContent (IsSelected a IN) a + DataInputUnion :: + { inputUnionMembers :: DataInputUnion + } -> + TypeContent (IsSelected a IN) a + DataObject :: + { objectImplements :: [TypeName], + objectFields :: FieldsDefinition OUT + } -> + TypeContent (IsSelected a OUT) a + DataUnion :: + { unionMembers :: DataUnion + } -> + TypeContent (IsSelected a OUT) a + DataInterface :: + { interfaceFields :: FieldsDefinition OUT + } -> + TypeContent (IsSelected a OUT) a + +deriving instance Show (TypeContent a b) + +deriving instance Lift (TypeContent a b) + +createType :: TypeName -> TypeContent TRUE a -> TypeDefinition a +createType typeName typeContent = + TypeDefinition + { typeName, + typeMeta = Nothing, + typeFingerprint = DataFingerprint typeName [], + typeContent + } + +createScalarType :: TypeName -> TypeDefinition a +createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) + +createEnumType :: TypeName -> [TypeName] -> TypeDefinition a +createEnumType typeName typeData = createType typeName (DataEnum enumValues) + where + enumValues = map createEnumValue typeData + +createEnumValue :: TypeName -> DataEnumValue +createEnumValue enumName = DataEnumValue {enumName, enumMeta = Nothing} + +createUnionType :: TypeName -> [TypeName] -> TypeDefinition OUT +createUnionType typeName typeData = createType typeName (DataUnion typeData) + +isEntNode :: TypeContent TRUE a -> Bool +isEntNode DataScalar {} = True +isEntNode DataEnum {} = True +isEntNode _ = False + +kindOf :: TypeDefinition a -> DataTypeKind +kindOf TypeDefinition {typeName, typeContent} = __kind typeContent + where + __kind DataScalar {} = KindScalar + __kind DataEnum {} = KindEnum + __kind DataInputObject {} = KindInputObject + __kind DataObject {} = KindObject (toOperationType typeName) + __kind DataUnion {} = KindUnion + __kind DataInputUnion {} = KindInputUnion + __kind DataInterface {} = KindInterface + +fromOperation :: Maybe (TypeDefinition OUT) -> [(TypeName, TypeDefinition ANY)] +fromOperation (Just datatype) = [(typeName datatype, toAny datatype)] +fromOperation Nothing = [] + +defineType :: TypeDefinition cat -> Schema -> Schema +defineType dt@TypeDefinition {typeName, typeContent = DataInputUnion enumKeys, typeFingerprint} lib = + lib {types = HM.insert name unionTags (HM.insert typeName (toAny dt) (types lib))} + where + name = typeName <> "Tags" + unionTags = + TypeDefinition + { typeName = name, + typeFingerprint, + typeMeta = Nothing, + typeContent = DataEnum $ map (createEnumValue . fst) enumKeys + } +defineType datatype lib = + lib {types = HM.insert (typeName datatype) (toAny datatype) (types lib)} + +insertType :: + TypeDefinition ANY -> + TypeUpdater +insertType datatype@TypeDefinition {typeName} lib = case isTypeDefined typeName lib of + Nothing -> resolveUpdates (defineType datatype lib) [] + Just fingerprint + | fingerprint == typeFingerprint datatype -> return lib + -- throw error if 2 different types has same name + | otherwise -> failure $ nameCollisionError typeName + +updateSchema :: + TypeName -> + DataFingerprint -> + [TypeUpdater] -> + (a -> TypeDefinition cat) -> + a -> + TypeUpdater +updateSchema name fingerprint stack f x lib = + case isTypeDefined name lib of + Nothing -> + resolveUpdates + (defineType (f x) lib) + stack + Just fingerprint' | fingerprint' == fingerprint -> return lib + -- throw error if 2 different types has same name + Just _ -> failure $ nameCollisionError name + +lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a +lookupWith f key = find ((== key) . f) + +-- lookups and removes TypeDefinition from hashmap +popByKey :: TypeName -> [TypeDefinition ANY] -> (Maybe (TypeDefinition OUT), [TypeDefinition ANY]) +popByKey name types = case lookupWith typeName name types of + Just dt@TypeDefinition {typeContent = DataObject {}} -> + (fromAny dt, filter ((/= name) . typeName) types) + _ -> (Nothing, types) + +newtype Fields def = Fields + {unFields :: OrderedMap FieldName def} + deriving + ( Show, + Lift, + Functor, + Foldable, + Traversable + ) + +deriving instance (KEY def ~ FieldName, KeyOf def) => Collection def (Fields def) + +instance Merge (FieldsDefinition cat) where + merge path (Fields x) (Fields y) = Fields <$> merge path x y + +instance Selectable (Fields (FieldDefinition cat)) (FieldDefinition cat) where + selectOr fb f name (Fields lib) = selectOr fb f name lib + +unsafeFromFields :: [FieldDefinition cat] -> FieldsDefinition cat +unsafeFromFields = Fields . unsafeFromValues + +argumentsToFields :: ArgumentsDefinition -> FieldsDefinition IN +argumentsToFields = Fields . arguments + +fieldsToArguments :: FieldsDefinition IN -> ArgumentsDefinition +fieldsToArguments = ArgumentsDefinition Nothing . unFields + +instance (KEY def ~ FieldName, KeyOf def, NameCollision def) => Listable def (Fields def) where + fromElems = fmap Fields . fromElems + elems = elems . unFields + +-- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects +------------------------------------------------------------------------------ +-- ObjectTypeDefinition: +-- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) +-- +-- ImplementsInterfaces +-- implements &(opt) NamedType +-- ImplementsInterfaces & NamedType +-- +-- FieldsDefinition +-- { FieldDefinition(list) } +-- +type FieldsDefinition cat = Fields (FieldDefinition cat) + +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +data FieldDefinition (cat :: TypeCategory) = FieldDefinition + { fieldName :: FieldName, + fieldArgs :: ArgumentsDefinition, + fieldType :: TypeRef, + fieldMeta :: Maybe Meta + } + deriving (Show, Lift) + +instance KeyOf (FieldDefinition cat) where + keyOf = fieldName + +instance Selectable (FieldDefinition OUT) ArgumentDefinition where + selectOr fb f key FieldDefinition {fieldArgs} = selectOr fb f key fieldArgs + +instance NameCollision (FieldDefinition cat) where + nameCollision name _ = + GQLError + { message = "There can Be only One field Named " <> msg name, + locations = [] + } + +instance RenderGQL (FieldDefinition cat) where + render FieldDefinition {fieldName = FieldName name, fieldType, fieldArgs} = + name <> render fieldArgs <> ": " <> render fieldType + +instance RenderGQL (FieldsDefinition OUT) where + render = renderObject render . ignoreHidden . elems + +instance RenderGQL (FieldsDefinition IN) where + render = renderObject render . ignoreHidden . elems + +fieldVisibility :: FieldDefinition cat -> Bool +fieldVisibility FieldDefinition {fieldName} = fieldName `notElem` sysFields + +isFieldNullable :: FieldDefinition cat -> Bool +isFieldNullable = isNullable . fieldType + +createField :: ArgumentsDefinition -> FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition cat +createField dataArguments fieldName (typeWrappers, typeConName) = + FieldDefinition + { fieldArgs = dataArguments, + fieldName, + fieldType = TypeRef {typeConName, typeWrappers, typeArgs = Nothing}, + fieldMeta = Nothing + } + +toNullableField :: FieldDefinition cat -> FieldDefinition cat +toNullableField dataField + | isNullable (fieldType dataField) = dataField + | otherwise = dataField {fieldType = nullable (fieldType dataField)} + where + nullable alias@TypeRef {typeWrappers} = + alias {typeWrappers = TypeMaybe : typeWrappers} + +toListField :: FieldDefinition cat -> FieldDefinition cat +toListField dataField = dataField {fieldType = listW (fieldType dataField)} + where + listW alias@TypeRef {typeWrappers} = + alias {typeWrappers = TypeList : typeWrappers} + +-- 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects +--------------------------------------------------------------------------- +-- InputObjectTypeDefinition +-- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt) +-- +--- InputFieldsDefinition +-- { InputValueDefinition(list) } + +type InputFieldsDefinition = Fields InputValueDefinition + +type InputValueDefinition = FieldDefinition IN + +-- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments +----------------------------------------------------------------------------------------------- +-- ArgumentsDefinition: +-- (InputValueDefinition(list)) + +data ArgumentsDefinition + = ArgumentsDefinition + { argumentsTypename :: Maybe TypeName, + arguments :: OrderedMap FieldName ArgumentDefinition + } + | NoArguments + deriving (Show, Lift) + +instance RenderGQL ArgumentsDefinition where + render NoArguments = "" + render arguments = "(" <> intercalate ", " (map render $ elems arguments) <> ")" + +type ArgumentDefinition = FieldDefinition IN + +instance Selectable ArgumentsDefinition ArgumentDefinition where + selectOr fb _ _ NoArguments = fb + selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args + +instance Collection ArgumentDefinition ArgumentsDefinition where + empty = ArgumentsDefinition Nothing empty + singleton = ArgumentsDefinition Nothing . singleton + +instance Listable ArgumentDefinition ArgumentsDefinition where + elems NoArguments = [] + elems (ArgumentsDefinition _ args) = elems args + fromElems [] = pure NoArguments + fromElems args = ArgumentsDefinition Nothing <$> fromElems args + +createArgument :: FieldName -> ([TypeWrapper], TypeName) -> FieldDefinition IN +createArgument = createField NoArguments + +hasArguments :: ArgumentsDefinition -> Bool +hasArguments NoArguments = False +hasArguments _ = True + +-- https://spec.graphql.org/June2018/#InputValueDefinition +-- InputValueDefinition +-- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt) +-- TODO: implement inputValue + +-- data InputValueDefinition = InputValueDefinition +-- { inputValueName :: FieldName +-- , inputValueType :: TypeRef +-- , inputValueMeta :: Maybe Meta +-- } deriving (Show,Lift) + +__inputname :: FieldName +__inputname = "inputname" + +createInputUnionFields :: TypeName -> [TypeName] -> [FieldDefinition IN] +createInputUnionFields name members = fieldTag : map unionField members + where + fieldTag = + FieldDefinition + { fieldName = __inputname, + fieldArgs = NoArguments, + fieldType = createAlias (name <> "Tags"), + fieldMeta = Nothing + } + unionField memberName = + FieldDefinition + { fieldArgs = NoArguments, + fieldName = toFieldName memberName, + fieldType = + TypeRef + { typeConName = memberName, + typeWrappers = [TypeMaybe], + typeArgs = Nothing + }, + fieldMeta = Nothing + } + +-- +-- OTHER +-------------------------------------------------------------------------------------------------- + +createAlias :: TypeName -> TypeRef +createAlias typeConName = + TypeRef {typeConName, typeWrappers = [], typeArgs = Nothing} + +type TypeUpdater = LibUpdater Schema + +instance RenderGQL Schema where + render schema = intercalate "\n\n" $ map render visibleTypes + where + visibleTypes = filter (not . isSystemTypeName . typeName) (elems schema) + +instance RenderGQL (TypeDefinition a) where + render TypeDefinition {typeName, typeContent} = __render typeContent + where + __render DataInterface {interfaceFields} = "interface " <> render typeName <> render interfaceFields + __render DataScalar {} = "scalar " <> render typeName + __render (DataEnum tags) = "enum " <> render typeName <> renderObject render tags + __render (DataUnion members) = + "union " + <> render typeName + <> " =\n " + <> intercalate ("\n" <> renderIndent <> "| ") (map render members) + __render (DataInputObject fields) = "input " <> render typeName <> render fields + __render (DataInputUnion members) = "input " <> render typeName <> render fieldsDef + where + fieldsDef = unsafeFromFields fields + fields :: [FieldDefinition IN] + fields = createInputUnionFields typeName (fst <$> members :: [TypeName]) + __render DataObject {objectFields} = "type " <> render typeName <> render objectFields + +ignoreHidden :: [FieldDefinition cat] -> [FieldDefinition cat] +ignoreHidden = filter fieldVisibility diff --git a/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs b/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/MergeSet.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.AST.MergeSet + ( MergeSet, + toOrderedMap, + concatTraverse, + join, + ) +where + +import Data.List ((\\), find) +import Data.Maybe (maybe) +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( (<:>), + Collection (..), + Failure (..), + KeyOf (..), + Listable (..), + Merge (..), + Selectable (..), + elems, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + GQLErrors, + RAW, + Ref, + Stage, + VALID, + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap (..), + ) +import qualified Data.Morpheus.Types.Internal.AST.OrderedMap as OM +import Data.Semigroup ((<>)) +import Language.Haskell.TH.Syntax (Lift (..)) + +-- set with mergeable components +newtype MergeSet (dups :: Stage) a = MergeSet + { unpack :: [a] + } + deriving + ( Show, + Eq, + Functor, + Foldable, + Lift, + Traversable, + Collection a + ) + +concatTraverse :: + ( Eq a, + Eq b, + Merge a, + Merge b, + KeyOf b, + Monad m, + Failure GQLErrors m + ) => + (a -> m (MergeSet VALID b)) -> + MergeSet RAW a -> + m (MergeSet VALID b) +concatTraverse f smap = + traverse f (elems smap) + >>= join + +join :: + ( Eq a, + KeyOf a, + Merge a, + Monad m, + Failure GQLErrors m, + Listable a (MergeSet opt a), + Merge (MergeSet opt a) + ) => + [MergeSet opt a] -> + m (MergeSet opt a) +join = __join empty + where + __join acc [] = pure acc + __join acc (x : xs) = acc <:> x >>= (`__join` xs) + +toOrderedMap :: (KEY a ~ FieldName, KeyOf a) => MergeSet opt a -> OrderedMap FieldName a +toOrderedMap = OM.unsafeFromValues . unpack + +instance (KeyOf a, k ~ KEY a) => Selectable (MergeSet opt a) a where + selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls) + +-- must merge files on collision + +instance + ( KeyOf a, + Listable a (MergeSet VALID a), + Merge a, + Eq a + ) => + Merge (MergeSet VALID a) + where + merge = safeJoin + +instance + ( Listable a (MergeSet VALID a), + KeyOf a, + Merge a, + Eq a + ) => + Listable a (MergeSet VALID a) + where + fromElems = safeFromList + elems = unpack + +instance Merge (MergeSet RAW a) where + merge _ (MergeSet x) (MergeSet y) = pure $ MergeSet $ x <> y + +instance Listable a (MergeSet RAW a) where + fromElems = pure . MergeSet + elems = unpack + +safeFromList :: (Monad m, KeyOf a, Eq a, Merge a, Failure GQLErrors m) => [a] -> m (MergeSet opt a) +safeFromList = insertList [] empty + +safeJoin :: (Monad m, KeyOf a, Eq a, Listable a (MergeSet opt a), Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> MergeSet opt a -> m (MergeSet opt a) +safeJoin path hm1 hm2 = insertList path hm1 (elems hm2) + +insertList :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> [a] -> m (MergeSet opt a) +insertList _ smap [] = pure smap +insertList path smap (x : xs) = insert path smap x >>= flip (insertList path) xs + +insert :: (Monad m, Eq a, KeyOf a, Merge a, Failure GQLErrors m) => [Ref] -> MergeSet opt a -> a -> m (MergeSet opt a) +insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert + where + __insert = + selectOr + (pure $ ls <> [currentValue]) + mergeWith + (keyOf currentValue) + mSet + ------------------ + mergeWith oldValue + | oldValue == currentValue = pure ls + | otherwise = do + mergedValue <- merge path oldValue currentValue + pure $ (ls \\ [oldValue]) <> [mergedValue] diff --git a/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap (..), + unsafeFromValues, + ) +where + +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HM +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe, isJust) +-- MORPHEUS +import Data.Morpheus.Error.NameCollision (NameCollision (..)) +import Data.Morpheus.Internal.Utils + ( Collection (..), + Failure (..), + KeyOf (..), + Listable (..), + Merge (..), + Selectable (..), + toPair, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLErrors, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH.Syntax (Lift (..)) + +-- OrderedMap +data OrderedMap k a = OrderedMap + { mapKeys :: [k], + mapEntries :: HashMap k a + } + deriving (Show, Eq, Functor) + +instance (Lift a, Lift k) => Lift (OrderedMap k a) where + lift (OrderedMap names x) = [|OrderedMap names (HM.fromList ls)|] + where + ls = HM.toList x + +instance Foldable (OrderedMap k) where + foldMap f OrderedMap {mapEntries} = foldMap f mapEntries + +instance Traversable (OrderedMap k) where + traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values + +instance (KeyOf a, Hashable k, KEY a ~ k) => Collection a (OrderedMap k a) where + empty = OrderedMap [] HM.empty + singleton x = OrderedMap [keyOf x] $ HM.singleton (keyOf x) x + +instance (Eq k, Hashable k, k ~ KEY a) => Selectable (OrderedMap k a) a where + selectOr fb f key OrderedMap {mapEntries} = maybe fb f (HM.lookup key mapEntries) + +instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Merge (OrderedMap k a) where + merge _ (OrderedMap k1 x) (OrderedMap k2 y) = OrderedMap (k1 <> k2) <$> safeJoin x y + +instance (NameCollision a, Eq k, Hashable k, k ~ KEY a) => Listable a (OrderedMap k a) where + fromElems = safeFromList + elems OrderedMap {mapKeys, mapEntries} = map takeValue mapKeys + where + takeValue key = fromMaybe (error "TODO: invalid Ordered Map") (key `HM.lookup` mapEntries) + +safeFromList :: + ( Failure GQLErrors m, + Applicative m, + NameCollision a, + Eq (KEY a), + Hashable (KEY a), + KeyOf a + ) => + [a] -> + m (OrderedMap (KEY a) a) +safeFromList values = OrderedMap (map keyOf values) <$> safeUnionWith HM.empty (map toPair values) + +unsafeFromValues :: + ( KeyOf a, + Eq (KEY a), + Hashable (KEY a) + ) => + [a] -> + OrderedMap (KEY a) a +unsafeFromValues x = OrderedMap (map keyOf x) $ HM.fromList $ fmap toPair x + +safeJoin :: (Failure GQLErrors m, Eq k, Hashable k, KEY a ~ k, Applicative m, NameCollision a) => HashMap k a -> HashMap k a -> m (HashMap k a) +safeJoin hm newls = safeUnionWith hm (HM.toList newls) + +safeUnionWith :: + ( Failure GQLErrors m, + Applicative m, + Eq k, + Hashable k, + NameCollision a, + KEY a ~ k + ) => + HashMap k a -> + [(k, a)] -> + m (HashMap k a) +safeUnionWith hm names = case insertNoDups (hm, []) names of + (res, dupps) + | null dupps -> pure res + | otherwise -> failure $ map (uncurry nameCollision) dupps + +type NoDupHashMap k a = (HashMap k a, [(k, a)]) + +insertNoDups :: (Eq k, Hashable k) => NoDupHashMap k a -> [(k, a)] -> NoDupHashMap k a +insertNoDups collected [] = collected +insertNoDups (coll, errors) (pair@(name, value) : xs) + | isJust (name `HM.lookup` coll) = insertNoDups (coll, errors <> [pair]) xs + | otherwise = insertNoDups (HM.insert name value coll, errors) xs diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.AST.Selection + ( Selection (..), + SelectionContent (..), + SelectionSet, + UnionTag (..), + UnionSelection, + Fragment (..), + Fragments, + Operation (..), + Variable (..), + VariableDefinitions, + DefaultValue, + getOperationName, + getOperationDataType, + ) +where + +import Data.Maybe (fromMaybe, isJust) +-- MORPHEUS + +import Data.Morpheus.Error.NameCollision + ( NameCollision (..), + ) +import Data.Morpheus.Error.Operation + ( mutationIsNotDefined, + subscriptionIsNotDefined, + ) +import Data.Morpheus.Internal.Utils + ( Failure (..), + KeyOf (..), + Merge (..), + ) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + GQLError (..), + GQLErrors, + Message, + OperationType (..), + Position, + RAW, + Ref (..), + Stage, + TypeName (..), + VALID, + intercalateName, + msg, + readName, + ) +import Data.Morpheus.Types.Internal.AST.Data + ( Arguments, + Directives, + OUT, + Schema (..), + TypeDefinition (..), + ) +import Data.Morpheus.Types.Internal.AST.MergeSet + ( MergeSet, + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap, + ) +import Data.Morpheus.Types.Internal.AST.Value + ( ResolvedValue, + Variable (..), + VariableDefinitions, + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH.Syntax (Lift (..)) + +data Fragment = Fragment + { fragmentName :: FieldName, + fragmentType :: TypeName, + fragmentPosition :: Position, + fragmentSelection :: SelectionSet RAW, + fragmentDirectives :: Directives RAW + } + deriving (Show, Eq, Lift) + +-- ERRORs +instance NameCollision Fragment where + nameCollision _ Fragment {fragmentName, fragmentPosition} = + GQLError + { message = "There can be only one fragment named " <> msg fragmentName <> ".", + locations = [fragmentPosition] + } + +instance KeyOf Fragment where + keyOf = fragmentName + +type Fragments = OrderedMap FieldName Fragment + +data SelectionContent (s :: Stage) where + SelectionField :: SelectionContent s + SelectionSet :: SelectionSet s -> SelectionContent s + UnionSelection :: UnionSelection VALID -> SelectionContent VALID + +instance + Merge (SelectionSet s) => + Merge (SelectionContent s) + where + merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2 + merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2 + merge path oldC currC + | oldC == currC = pure oldC + | otherwise = + failure + [ GQLError + { message = msg (intercalateName "." $ map refName path), + locations = map refPosition path + } + ] + +deriving instance Show (SelectionContent a) + +deriving instance Eq (SelectionContent a) + +deriving instance Lift (SelectionContent a) + +data UnionTag = UnionTag + { unionTagName :: TypeName, + unionTagSelection :: SelectionSet VALID + } + deriving (Show, Eq, Lift) + +mergeConflict :: [Ref] -> GQLError -> GQLErrors +mergeConflict [] err = [err] +mergeConflict refs@(rootField : xs) err = + [ GQLError + { message = renderSubfields <> message err, + locations = map refPosition refs <> locations err + } + ] + where + fieldConflicts ref = msg (refName ref) <> " conflict because " + renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref + renderStart = "Fields " <> fieldConflicts rootField + renderSubfields = + foldr + renderSubfield + renderStart + xs + +instance Merge UnionTag where + merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) = + UnionTag oldTag <$> merge path oldSel currentSel + +instance KeyOf UnionTag where + type KEY UnionTag = TypeName + keyOf = unionTagName + +type UnionSelection (s :: Stage) = MergeSet s UnionTag + +type SelectionSet (s :: Stage) = MergeSet s (Selection s) + +data Selection (s :: Stage) where + Selection :: + { selectionName :: FieldName, + selectionAlias :: Maybe FieldName, + selectionPosition :: Position, + selectionArguments :: Arguments s, + selectionContent :: SelectionContent s, + selectionDirectives :: Directives s + } -> + Selection s + InlineFragment :: Fragment -> Selection RAW + Spread :: Directives RAW -> Ref -> Selection RAW + +instance KeyOf (Selection s) where + keyOf + Selection + { selectionName, + selectionAlias + } = fromMaybe selectionName selectionAlias + keyOf _ = "" + +useDufferentAliases :: Message +useDufferentAliases = + "Use different aliases on the " + <> "fields to fetch both if this was intentional." + +instance + Merge (SelectionSet a) => + Merge (Selection a) + where + merge + path + old@Selection {selectionPosition = pos1} + current@Selection {selectionPosition = pos2} = + do + selectionName <- mergeName + let currentPath = path <> [Ref selectionName pos1] + selectionArguments <- mergeArguments currentPath + selectionContent <- merge currentPath (selectionContent old) (selectionContent current) + pure $ + Selection + { selectionAlias = mergeAlias, + selectionPosition = pos1, + selectionDirectives = selectionDirectives old <> selectionDirectives current, + .. + } + where + -- passes if: + + -- user1: user + -- } + -- fails if: + + -- user1: product + -- } + mergeName + | selectionName old == selectionName current = pure $ selectionName current + | otherwise = + failure $ mergeConflict path $ + GQLError + { message = + "" <> msg (selectionName old) <> " and " <> msg (selectionName current) + <> " are different fields. " + <> useDufferentAliases, + locations = [pos1, pos2] + } + --------------------- + -- allias name is relevant only if they collide by allias like: + -- { user1: user + -- user1: user + -- } + mergeAlias + | all (isJust . selectionAlias) [old, current] = selectionAlias old + | otherwise = Nothing + --- arguments must be equal + mergeArguments currentPath + | selectionArguments old == selectionArguments current = pure $ selectionArguments current + | otherwise = + failure $ mergeConflict currentPath $ + GQLError + { message = "they have differing arguments. " <> useDufferentAliases, + locations = [pos1, pos2] + } + merge path _ _ = + failure $ mergeConflict path $ + GQLError + { message = "INTERNAL: can't merge. " <> useDufferentAliases, + locations = [] + } + +deriving instance Show (Selection a) + +deriving instance Lift (Selection a) + +deriving instance Eq (Selection a) + +type DefaultValue = Maybe ResolvedValue + +data Operation (s :: Stage) = Operation + { operationName :: Maybe FieldName, + operationType :: OperationType, + operationArguments :: VariableDefinitions s, + operationSelection :: SelectionSet s, + operationPosition :: Position, + operationDirectives :: Directives s + } + deriving (Show, Lift) + +getOperationName :: Maybe FieldName -> TypeName +getOperationName = maybe "AnonymousOperation" (TypeName . readName) + +getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m (TypeDefinition OUT) +getOperationDataType Operation {operationType = Query} lib = pure (query lib) +getOperationDataType Operation {operationType = Mutation, operationPosition} lib = + case mutation lib of + Just x -> pure x + Nothing -> failure $ mutationIsNotDefined operationPosition +getOperationDataType Operation {operationType = Subscription, operationPosition} lib = + case subscription lib of + Just x -> pure x + Nothing -> failure $ subscriptionIsNotDefined operationPosition diff --git a/src/Data/Morpheus/Types/Internal/AST/TH.hs b/src/Data/Morpheus/Types/Internal/AST/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/TH.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Morpheus.Types.Internal.AST.TH + ( TypeD (..), + ConsD (..), + mkCons, + GQLTypeD (..), + isEnum, + mkConsEnum, + ) +where + +import Data.Morpheus.Internal.Utils (elems) +import Data.Morpheus.Types.Internal.AST.Base + ( DataTypeKind, + FieldName, + TypeName, + TypeRef (..), + hsTypeName, + ) +import Data.Morpheus.Types.Internal.AST.Data + ( ANY, + DataEnumValue (..), + FieldDefinition (..), + FieldsDefinition, + Meta, + TypeDefinition, + ) + +toHSFieldDefinition :: FieldDefinition cat -> FieldDefinition cat +toHSFieldDefinition field@FieldDefinition {fieldType = tyRef@TypeRef {typeConName}} = + field + { fieldType = tyRef {typeConName = hsTypeName typeConName} + } + +-- Template Haskell Types +-- Document +data GQLTypeD = GQLTypeD + { typeD :: TypeD, + typeArgD :: [TypeD], + typeOriginal :: TypeDefinition ANY + } + deriving (Show) + +--- Core +data TypeD = TypeD + { tName :: TypeName, + tNamespace :: [FieldName], + tCons :: [ConsD], + tKind :: DataTypeKind, + tMeta :: Maybe Meta + } + deriving (Show) + +data ConsD = ConsD + { cName :: TypeName, + cFields :: [FieldDefinition ANY] + } + deriving (Show) + +mkCons :: TypeName -> FieldsDefinition cat -> ConsD +mkCons typename fields = + ConsD + { cName = hsTypeName typename, + cFields = map (toHSFieldDefinition . mockFieldDefinition) (elems fields) + } + +isEnum :: [ConsD] -> Bool +isEnum = all (null . cFields) + +mockFieldDefinition :: FieldDefinition a -> FieldDefinition b +mockFieldDefinition FieldDefinition {..} = FieldDefinition {..} + +mkConsEnum :: DataEnumValue -> ConsD +mkConsEnum DataEnumValue {enumName} = ConsD {cName = hsTypeName enumName, cFields = []} diff --git a/src/Data/Morpheus/Types/Internal/AST/Value.hs b/src/Data/Morpheus/Types/Internal/AST/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/AST/Value.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.Internal.AST.Value + ( Value (..), + ScalarValue (..), + Object, + GQLValue (..), + replaceValue, + decodeScientific, + RawValue, + ValidValue, + RawObject, + ValidObject, + Variable (..), + ResolvedValue, + ResolvedObject, + VariableContent (..), + ObjectEntry (..), + VariableDefinitions, + ) +where + +import qualified Data.Aeson as A + ( (.=), + FromJSON (..), + ToJSON (..), + Value (..), + encode, + object, + pairs, + ) +import qualified Data.HashMap.Strict as M + ( toList, + ) +-- MORPHEUS +import Data.Morpheus.Error.NameCollision + ( NameCollision (..), + ) +import Data.Morpheus.Internal.Utils + ( KeyOf (..), + elems, + mapTuple, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + FieldName (..), + GQLError (..), + Msg (..), + Position, + RAW, + RESOLVED, + Ref (..), + Stage, + TypeName (..), + TypeRef, + TypeRef (..), + VALID, + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( OrderedMap, + unsafeFromValues, + ) +import Data.Scientific + ( Scientific, + floatingOrInteger, + ) +import Data.Semigroup ((<>)) +import Data.Text + ( Text, + unpack, + ) +import qualified Data.Vector as V + ( toList, + ) +import GHC.Generics (Generic) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift (..)) + +-- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. +-- for performance reason type 'Text' represents GraphQl 'String' value +data ScalarValue + = Int Int + | Float Float + | String Text + | Boolean Bool + deriving (Show, Eq, Generic, Lift) + +instance A.ToJSON ScalarValue where + toJSON (Float x) = A.toJSON x + toJSON (Int x) = A.toJSON x + toJSON (Boolean x) = A.toJSON x + toJSON (String x) = A.toJSON x + +instance A.FromJSON ScalarValue where + parseJSON (A.Bool v) = pure $ Boolean v + parseJSON (A.Number v) = pure $ decodeScientific v + parseJSON (A.String v) = pure $ String v + parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar + +type family VAR (a :: Stage) :: Stage + +type instance VAR RAW = RESOLVED + +type instance VAR RESOLVED = RESOLVED + +type instance VAR VALID = VALID + +data VariableContent (stage :: Stage) where + DefaultValue :: Maybe ResolvedValue -> VariableContent RESOLVED + ValidVariableValue :: {validVarContent :: ValidValue} -> VariableContent VALID + +instance Lift (VariableContent a) where + lift (DefaultValue x) = [|DefaultValue x|] + lift (ValidVariableValue x) = [|ValidVariableValue x|] + +deriving instance Show (VariableContent a) + +deriving instance Eq (VariableContent a) + +data Variable (stage :: Stage) = Variable + { variableName :: FieldName, + variableType :: TypeRef, + variablePosition :: Position, + variableValue :: VariableContent (VAR stage) + } + deriving (Show, Eq, Lift) + +instance KeyOf (Variable s) where + keyOf = variableName + +instance NameCollision (Variable s) where + nameCollision _ Variable {variableName, variablePosition} = + GQLError + { message = "There can Be only One Variable Named " <> msg variableName, + locations = [variablePosition] + } + +type VariableDefinitions s = OrderedMap FieldName (Variable s) + +data Value (stage :: Stage) where + ResolvedVariable :: Ref -> Variable VALID -> Value RESOLVED + VariableValue :: Ref -> Value RAW + Object :: Object stage -> Value stage + List :: [Value stage] -> Value stage + Enum :: TypeName -> Value stage + Scalar :: ScalarValue -> Value stage + Null :: Value stage + +deriving instance Eq (Value s) + +data ObjectEntry (s :: Stage) = ObjectEntry + { entryName :: FieldName, + entryValue :: Value s + } + deriving (Eq) + +instance Show (ObjectEntry s) where + show (ObjectEntry (FieldName name) value) = unpack name <> ":" <> show value + +instance NameCollision (ObjectEntry s) where + nameCollision _ ObjectEntry {entryName} = + GQLError + { message = "There can Be only One field Named " <> msg entryName, + locations = [] + } + +instance KeyOf (ObjectEntry s) where + keyOf = entryName + +type Object a = OrderedMap FieldName (ObjectEntry a) + +type ValidObject = Object VALID + +type RawObject = Object RAW + +type ResolvedObject = Object RESOLVED + +type RawValue = Value RAW + +type ValidValue = Value VALID + +type ResolvedValue = Value RESOLVED + +deriving instance Lift (Value a) + +deriving instance Lift (ObjectEntry a) + +instance Show (Value a) where + show Null = "null" + show (Enum x) = "" <> unpack (readTypeName x) + show (Scalar x) = show x + show (ResolvedVariable Ref {refName} Variable {variableValue}) = + "($" <> unpack (readName refName) <> ": " <> show variableValue <> ") " + show (VariableValue Ref {refName}) = "$" <> unpack (readName refName) <> " " + show (Object keys) = "{" <> foldr toEntry "" keys <> "}" + where + toEntry :: ObjectEntry a -> String -> String + toEntry value "" = show value + toEntry value txt = txt <> ", " <> show value + show (List list) = "[" <> foldl toEntry "" list <> "]" + where + toEntry :: String -> Value a -> String + toEntry "" value = show value + toEntry txt value = txt <> ", " <> show value + +instance Msg (Value a) where + msg = msg . A.encode + +instance A.ToJSON (Value a) where + toJSON (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) = + A.toJSON x + toJSON (VariableValue Ref {refName}) = + A.String $ "($ref:" <> readName refName <> ")" + toJSON Null = A.Null + toJSON (Enum (TypeName x)) = A.String x + toJSON (Scalar x) = A.toJSON x + toJSON (List x) = A.toJSON x + toJSON (Object fields) = A.object $ map toEntry (elems fields) + where + toEntry (ObjectEntry (FieldName name) value) = name A..= A.toJSON value + + ------------------------------------------- + toEncoding (ResolvedVariable _ Variable {variableValue = ValidVariableValue x}) = + A.toEncoding x + toEncoding (VariableValue Ref {refName}) = + A.toEncoding $ "($ref:" <> refName <> ")" + toEncoding Null = A.toEncoding A.Null + toEncoding (Enum x) = A.toEncoding x + toEncoding (Scalar x) = A.toEncoding x + toEncoding (List x) = A.toEncoding x + toEncoding (Object ordmap) + | null ordmap = A.toEncoding $ A.object [] + | otherwise = A.pairs $ foldl1 (<>) $ map encodeField (elems ordmap) + where + encodeField (ObjectEntry (FieldName key) value) = key A..= value + +decodeScientific :: Scientific -> ScalarValue +decodeScientific v = case floatingOrInteger v of + Left float -> Float float + Right int -> Int int + +replaceValue :: A.Value -> Value a +replaceValue (A.Bool v) = gqlBoolean v +replaceValue (A.Number v) = Scalar $ decodeScientific v +replaceValue (A.String v) = gqlString v +replaceValue (A.Object v) = + gqlObject $ + map + (mapTuple FieldName replaceValue) + (M.toList v) +replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li)) +replaceValue A.Null = gqlNull + +instance A.FromJSON (Value a) where + parseJSON = pure . replaceValue + +-- DEFAULT VALUES +class GQLValue a where + gqlNull :: a + gqlScalar :: ScalarValue -> a + gqlBoolean :: Bool -> a + gqlString :: Text -> a + gqlList :: [a] -> a + gqlObject :: [(FieldName, a)] -> a + +-- build GQL Values for Subscription Resolver +instance GQLValue (Value a) where + gqlNull = Null + gqlScalar = Scalar + gqlBoolean = Scalar . Boolean + gqlString = Scalar . String + gqlList = List + gqlObject = Object . unsafeFromValues . map toEntry + where + toEntry (key, value) = ObjectEntry key value diff --git a/src/Data/Morpheus/Types/Internal/Resolving.hs b/src/Data/Morpheus/Types/Internal/Resolving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Resolving.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Types.Internal.Resolving + ( Event (..), + UnSubResolver, + Resolver, + MapStrategy (..), + LiftOperation, + runRootResModel, + toResolver, + lift, + SubEvent, + Eventless, + Failure (..), + GQLChannel (..), + ResponseEvent (..), + ResponseStream, + cleanEvents, + Result (..), + ResultT (..), + unpackEvents, + LibUpdater, + resolveUpdates, + setTypeName, + ObjectResModel (..), + ResModel (..), + FieldResModel, + WithOperation, + PushEvents (..), + subscribe, + Context (..), + unsafeInternalContext, + RootResModel (..), + unsafeBind, + liftStateless, + resultOr, + withArguments, + -- Dynamic Resolver + mkBoolean, + mkFloat, + mkInt, + mkEnum, + mkList, + mkUnion, + mkObject, + mkNull, + mkString, + ) +where + +import Data.Morpheus.Types.Internal.AST + ( FieldName, + ScalarValue (..), + Token, + TypeName, + ) +import Data.Morpheus.Types.Internal.Resolving.Core +import Data.Morpheus.Types.Internal.Resolving.Resolver + +mkString :: Token -> ResModel o e m +mkString = ResScalar . String + +mkFloat :: Float -> ResModel o e m +mkFloat = ResScalar . Float + +mkInt :: Int -> ResModel o e m +mkInt = ResScalar . Int + +mkBoolean :: Bool -> ResModel o e m +mkBoolean = ResScalar . Boolean + +mkEnum :: TypeName -> TypeName -> ResModel o e m +mkEnum = ResEnum + +mkList :: [ResModel o e m] -> ResModel o e m +mkList = ResList + +mkUnion :: TypeName -> Resolver o e m (ResModel o e m) -> ResModel o e m +mkUnion = ResUnion + +mkNull :: ResModel o e m +mkNull = ResNull + +mkObject :: + TypeName -> + [(FieldName, Resolver o e m (ResModel o e m))] -> + ResModel o e m +mkObject __typename objectFields = + ResObject + ( ObjectResModel + { __typename, + objectFields + } + ) diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Core.hs b/src/Data/Morpheus/Types/Internal/Resolving/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Resolving/Core.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.Resolving.Core + ( Eventless, + Result (..), + Failure (..), + ResultT (..), + unpackEvents, + LibUpdater, + resolveUpdates, + mapEvent, + cleanEvents, + Event (..), + Channel (..), + GQLChannel (..), + PushEvents (..), + statelessToResultT, + resultOr, + ) +where + +import Control.Applicative (liftA2) +import Control.Monad (foldM) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Function ((&)) +import Data.Morpheus.Internal.Utils + ( Failure (..), + ) +import Data.Morpheus.Types.Internal.AST.Base + ( GQLError (..), + GQLErrors, + Message, + ) +import Data.Semigroup ((<>)) + +type Eventless = Result () + +-- EVENTS +class PushEvents e m where + pushEvents :: [e] -> m () + +-- Channel +newtype Channel event = Channel + { _unChannel :: StreamChannel event + } + +instance (Eq (StreamChannel event)) => Eq (Channel event) where + Channel x == Channel y = x == y + +class GQLChannel a where + type StreamChannel a :: * + streamChannels :: a -> [Channel a] + +instance GQLChannel () where + type StreamChannel () = () + streamChannels _ = [] + +instance GQLChannel (Event channel content) where + type StreamChannel (Event channel content) = channel + streamChannels Event {channels} = map Channel channels + +data Event e c = Event + {channels :: [e], content :: c} + +unpackEvents :: Result event a -> [event] +unpackEvents Success {events} = events +unpackEvents _ = [] + +-- +-- Result +-- +-- +data Result events a + = Success {result :: a, warnings :: GQLErrors, events :: [events]} + | Failure {errors :: GQLErrors} + deriving (Functor) + +instance Applicative (Result e) where + pure x = Success x [] [] + Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2) + Failure e1 <*> Failure e2 = Failure (e1 <> e2) + Failure e <*> Success _ w _ = Failure (e <> w) + Success _ w _ <*> Failure e = Failure (e <> w) + +instance Monad (Result e) where + return = pure + Success v w1 e1 >>= fm = case fm v of + (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2) + (Failure e) -> Failure (e <> w1) + Failure e >>= _ = Failure e + +instance Failure [GQLError] (Result ev) where + failure = Failure + +instance Failure Message (Result e) where + failure text = + Failure [GQLError {message = "INTERNAL: " <> text, locations = []}] + +instance PushEvents events (Result events) where + pushEvents events = Success {result = (), warnings = [], events} + +resultOr :: (GQLErrors -> a') -> (a -> a') -> Result e a -> a' +resultOr _ f (Success x _ _) = f x +resultOr f _ (Failure e) = f e + +-- ResultT +newtype ResultT event (m :: * -> *) a = ResultT + { runResultT :: m (Result event a) + } + deriving (Functor) + +statelessToResultT :: + Applicative m => + Eventless a -> + ResultT e m a +statelessToResultT = + cleanEvents + . ResultT + . pure + +instance Applicative m => Applicative (ResultT event m) where + pure = ResultT . pure . pure + ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2 + +instance Monad m => Monad (ResultT event m) where + return = pure + (ResultT m1) >>= mFunc = ResultT $ do + result1 <- m1 + case result1 of + Failure errors -> pure $ Failure errors + Success value1 w1 e1 -> do + result2 <- runResultT (mFunc value1) + case result2 of + Failure errors -> pure $ Failure (errors <> w1) + Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2) + +instance MonadTrans (ResultT event) where + lift = ResultT . fmap pure + +-- instance Applicative m => Failure String (ResultT event m) where +-- failure x = +-- ResultT $ pure $ Failure [GQLError {message = pack x, locations = []}] + +instance Monad m => Failure GQLErrors (ResultT event m) where + failure = ResultT . pure . failure + +instance Applicative m => Failure Message (ResultT event m) where + failure = ResultT . pure . failure + +instance Applicative m => PushEvents event (ResultT event m) where + pushEvents = ResultT . pure . pushEvents + +cleanEvents :: + Functor m => + ResultT e m a -> + ResultT e' m a +cleanEvents resT = ResultT $ replace <$> runResultT resT + where + replace (Success v w _) = Success v w [] + replace (Failure e) = Failure e + +mapEvent :: + Monad m => + (e -> e') -> + ResultT e m value -> + ResultT e' m value +mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma + where + mapEv Success {result, warnings, events} = + Success {result, warnings, events = map func events} + mapEv (Failure err) = Failure err + +-- Helper Functions +type LibUpdater lib = lib -> Eventless lib + +resolveUpdates :: Monad m => lib -> [lib -> m lib] -> m lib +resolveUpdates = foldM (&) diff --git a/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Morpheus.Types.Internal.Resolving.Resolver + ( Event (..), + UnSubResolver, + Resolver, + MapStrategy (..), + LiftOperation, + unsafeBind, + toResolver, + lift, + subscribe, + SubEvent, + GQLChannel (..), + ResponseEvent (..), + ResponseStream, + ObjectResModel (..), + ResModel (..), + FieldResModel, + WithOperation, + Context (..), + unsafeInternalContext, + runRootResModel, + setTypeName, + RootResModel (..), + liftStateless, + withArguments, + ) +where + +import Control.Monad.Fail (MonadFail (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Reader (ReaderT (..), ask, mapReaderT, withReaderT) +import Data.Maybe (maybe) +-- MORPHEUS +import Data.Morpheus.Error.Internal (internalResolvingError) +import Data.Morpheus.Error.Selection (subfieldsNotSelected) +import Data.Morpheus.Internal.Utils + ( Merge (..), + empty, + keyOf, + selectOr, + ) +import Data.Morpheus.Types.IO + ( GQLResponse, + renderResponse, + ) +import Data.Morpheus.Types.Internal.AST.Base + ( FieldName, + GQLError (..), + GQLErrors, + MUTATION, + Message, + OperationType, + OperationType (..), + QUERY, + SUBSCRIPTION, + TypeName (..), + VALID, + msg, + ) +import Data.Morpheus.Types.Internal.AST.Data + ( Arguments, + Schema, + ) +import Data.Morpheus.Types.Internal.AST.MergeSet + ( toOrderedMap, + ) +import Data.Morpheus.Types.Internal.AST.Selection + ( Operation (..), + Selection (..), + SelectionContent (..), + SelectionSet, + UnionSelection, + UnionTag (..), + ) +import Data.Morpheus.Types.Internal.AST.Value + ( GQLValue (..), + ObjectEntry (..), + ScalarValue (..), + ValidValue, + Value (..), + ) +import Data.Morpheus.Types.Internal.Resolving.Core + ( Channel (..), + Event (..), + Eventless, + Failure (..), + GQLChannel (..), + PushEvents (..), + Result (..), + ResultT (..), + StreamChannel, + cleanEvents, + mapEvent, + statelessToResultT, + ) +import Data.Semigroup + ( (<>), + Semigroup (..), + ) + +type WithOperation (o :: OperationType) = LiftOperation o + +type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m + +data ResponseEvent event (m :: * -> *) + = Publish event + | Subscribe (SubEvent event m) + +type SubEvent event m = Event (Channel event) (event -> m GQLResponse) + +-- | A datatype to expose 'Schema' and the query's AST information ('Selection', 'Operation'). +data Context = Context + { currentSelection :: Selection VALID, + schema :: Schema, + operation :: Operation VALID, + currentTypeName :: TypeName + } + deriving (Show) + +-- Resolver Internal State +newtype ResolverState event m a = ResolverState + { runResolverState :: ReaderT Context (ResultT event m) a + } + deriving + ( Functor, + Applicative, + Monad + ) + +instance MonadTrans (ResolverState e) where + lift = ResolverState . lift . lift + +instance (Monad m) => Failure Message (ResolverState e m) where + failure message = ResolverState $ do + selection <- currentSelection <$> ask + lift $ failure [resolverFailureMessage selection message] + +instance (Monad m) => Failure GQLErrors (ResolverState e m) where + failure = ResolverState . lift . failure + +instance (Monad m) => PushEvents e (ResolverState e m) where + pushEvents = ResolverState . lift . pushEvents + +mapResolverState :: + ( ReaderT Context (ResultT e m) a -> + ReaderT Context (ResultT e' m') a' + ) -> + ResolverState e m a -> + ResolverState e' m' a' +mapResolverState f (ResolverState x) = ResolverState (f x) + +getState :: (Monad m) => ResolverState e m (Selection VALID) +getState = ResolverState $ currentSelection <$> ask + +mapState :: (Context -> Context) -> ResolverState e m a -> ResolverState e m a +mapState f = mapResolverState (withReaderT f) + +-- clear evets and starts new resolver with diferenct type of events but with same value +-- use properly. only if you know what you are doing +clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a +clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents) + +resolverFailureMessage :: Selection VALID -> Message -> GQLError +resolverFailureMessage Selection {selectionName, selectionPosition} message = + GQLError + { message = "Failure on Resolving Field " <> msg selectionName <> ": " <> message, + locations = [selectionPosition] + } + +-- +-- GraphQL Field Resolver +-- +--------------------------------------------------------------- +data Resolver (o :: OperationType) event (m :: * -> *) value where + ResolverQ :: {runResolverQ :: ResolverState () m value} -> Resolver QUERY event m value + ResolverM :: {runResolverM :: ResolverState event m value} -> Resolver MUTATION event m value + ResolverS :: {runResolverS :: ResolverState (Channel event) m (ReaderT event (Resolver QUERY event m) value)} -> Resolver SUBSCRIPTION event m value + +instance Show (Resolver o e m value) where + show ResolverQ {} = "Resolver QUERY e m a" + show ResolverM {} = "Resolver MUTATION e m a" + show ResolverS {} = "Resolver SUBSCRIPTION e m a" + +deriving instance (Functor m) => Functor (Resolver o e m) + +-- Applicative +instance (LiftOperation o, Monad m) => Applicative (Resolver o e m) where + pure = packResolver . pure + ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2 + ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2 + ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2 + +-- Monad +instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where + return = pure + (>>=) = unsafeBind + +#if __GLASGOW_HASKELL__ < 808 + fail = failure . msg +# endif + +-- MonadIO +instance (MonadIO m, LiftOperation o) => MonadIO (Resolver o e m) where + liftIO = lift . liftIO + +-- Monad Transformers +instance (LiftOperation o) => MonadTrans (Resolver o e) where + lift = packResolver . lift + +-- Failure +instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where + failure = packResolver . failure + +instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where + failure = packResolver . failure + +instance (Monad m, LiftOperation o) => MonadFail (Resolver o e m) where + fail = failure . msg + +-- PushEvents +instance (Monad m) => PushEvents e (Resolver MUTATION e m) where + pushEvents = packResolver . pushEvents + +instance (Monad m, Semigroup a, LiftOperation o) => Semigroup (Resolver o e m a) where + x <> y = fmap (<>) x <*> y + +liftStateless :: + ( LiftOperation o, + Monad m + ) => + Eventless a -> + Resolver o e m a +liftStateless = + packResolver + . ResolverState + . ReaderT + . const + . statelessToResultT + +class LiftOperation (o :: OperationType) where + packResolver :: Monad m => ResolverState e m a -> Resolver o e m a + withResolver :: Monad m => ResolverState e m a -> (a -> Resolver o e m b) -> Resolver o e m b + +-- packResolver +instance LiftOperation QUERY where + packResolver = ResolverQ . clearStateResolverEvents + withResolver ctxRes toRes = ResolverQ $ do + v <- clearStateResolverEvents ctxRes + runResolverQ $ toRes v + +instance LiftOperation MUTATION where + packResolver = ResolverM + withResolver ctxRes toRes = ResolverM $ ctxRes >>= runResolverM . toRes + +instance LiftOperation SUBSCRIPTION where + packResolver = ResolverS . pure . lift . packResolver + withResolver ctxRes toRes = ResolverS $ do + value <- clearStateResolverEvents ctxRes + runResolverS $ toRes value + +mapResolverContext :: Monad m => (Context -> Context) -> Resolver o e m a -> Resolver o e m a +mapResolverContext f (ResolverQ res) = ResolverQ (mapState f res) +mapResolverContext f (ResolverM res) = ResolverM (mapState f res) +mapResolverContext f (ResolverS resM) = ResolverS $ do + res <- resM + pure $ ReaderT $ \e -> ResolverQ $ mapState f (runResolverQ (runReaderT res e)) + +setSelection :: Monad m => Selection VALID -> Resolver o e m a -> Resolver o e m a +setSelection currentSelection = + mapResolverContext (\ctx -> ctx {currentSelection}) + +setTypeName :: Monad m => TypeName -> Resolver o e m a -> Resolver o e m a +setTypeName currentTypeName = + mapResolverContext (\ctx -> ctx {currentTypeName}) + +-- unsafe variant of >>= , not for public api. user can be confused: +-- ignores `channels` on second Subsciption, only returns events from first Subscription monad. +-- reason: second monad is waiting for `event` until he does not have some event can't tell which +-- channel does it have to listen +unsafeBind :: + forall o e m a b. + Monad m => + Resolver o e m a -> + (a -> Resolver o e m b) -> + Resolver o e m b +unsafeBind (ResolverQ x) m2 = ResolverQ (x >>= runResolverQ . m2) +unsafeBind (ResolverM x) m2 = ResolverM (x >>= runResolverM . m2) +unsafeBind (ResolverS res) m2 = ResolverS $ do + (readResA :: ReaderT e (Resolver QUERY e m) a) <- res + pure $ ReaderT $ \e -> ResolverQ $ do + let (resA :: Resolver QUERY e m a) = runReaderT readResA e + (valA :: a) <- runResolverQ resA + (readResB :: ReaderT e (Resolver QUERY e m) b) <- clearStateResolverEvents $ runResolverS (m2 valA) + runResolverQ $ runReaderT readResB e + +subscribe :: + forall e m a. + ( PushEvents (Channel e) (ResolverState (Channel e) m), + Monad m + ) => + [StreamChannel e] -> + Resolver QUERY e m (e -> Resolver QUERY e m a) -> + Resolver SUBSCRIPTION e m a +subscribe ch res = ResolverS $ do + pushEvents (map Channel ch :: [Channel e]) + (eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res) + pure $ ReaderT eventRes + +-- | A function to return the internal 'Context' within a resolver's monad. +-- Using the 'Context' itself is unsafe because it expposes internal structures +-- of the AST, but you can use the "Data.Morpheus.Types.SelectionTree" typeclass to manipulate +-- the internal AST with a safe interface. +unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m Context +unsafeInternalContext = packResolver $ ResolverState ask + +-- Converts Subscription Resolver Type to Query Resolver +type family UnSubResolver (a :: * -> *) :: (* -> *) + +type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m + +withArguments :: + forall o e m a. + (LiftOperation o, Monad m) => + (Arguments VALID -> Resolver o e m a) -> + Resolver o e m a +withArguments = withResolver args + where + args :: ResolverState e m (Arguments VALID) + args = selectionArguments <$> getState + +-- +-- Selection Processing +toResolver :: + forall o e m a b. + (LiftOperation o, Monad m) => + (Arguments VALID -> Eventless a) -> + (a -> Resolver o e m b) -> + Resolver o e m b +toResolver toArgs = withResolver args + where + args :: ResolverState e m a + args = + ResultT . pure . toArgs . selectionArguments <$> getState + >>= ResolverState . lift . cleanEvents + +pickSelection :: TypeName -> UnionSelection VALID -> SelectionSet VALID +pickSelection = selectOr empty unionTagSelection + +withObject :: + (LiftOperation o, Monad m) => + (SelectionSet VALID -> Resolver o e m value) -> + Selection VALID -> + Resolver o e m value +withObject f Selection {selectionName, selectionContent, selectionPosition} = checkContent selectionContent + where + checkContent (SelectionSet selection) = f selection + checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition) + +lookupRes :: + (LiftOperation o, Monad m) => + Selection VALID -> + ObjectResModel o e m -> + Resolver o e m ValidValue +lookupRes Selection {selectionName} + | selectionName == "__typename" = + pure . Scalar . String . readTypeName . __typename + | otherwise = + maybe + (pure gqlNull) + (`unsafeBind` runDataResolver) + . lookup selectionName + . objectFields + +resolveObject :: + forall o e m. + (LiftOperation o, Monad m) => + SelectionSet VALID -> + ResModel o e m -> + Resolver o e m ValidValue +resolveObject selectionSet (ResObject drv@ObjectResModel {__typename}) = + Object . toOrderedMap <$> traverse resolver selectionSet + where + resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID) + resolver sel = + setSelection sel + $ setTypeName __typename + $ ObjectEntry (keyOf sel) <$> lookupRes sel drv +resolveObject _ _ = + failure $ internalResolvingError "expected object as resolver" + +toEventResolver :: Monad m => ReaderT event (Resolver QUERY event m) ValidValue -> Context -> event -> m GQLResponse +toEventResolver (ReaderT subRes) sel event = do + value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel + pure $ renderResponse value + +runDataResolver :: (Monad m, LiftOperation o) => ResModel o e m -> Resolver o e m ValidValue +runDataResolver = withResolver getState . __encode + where + __encode obj sel@Selection {selectionContent} = encodeNode obj selectionContent + where + -- LIST + encodeNode (ResList x) _ = List <$> traverse runDataResolver x + -- Object ----------------- + encodeNode objDrv@ResObject {} _ = withObject (`resolveObject` objDrv) sel + -- ENUM + encodeNode (ResEnum _ enum) SelectionField = pure $ gqlString $ readTypeName enum + encodeNode (ResEnum typename enum) unionSel@UnionSelection {} = + encodeNode (unionDrv (typename <> "EnumObject")) unionSel + where + unionDrv name = + ResUnion name + $ pure + $ ResObject + $ ObjectResModel name [("enum", pure $ ResScalar $ String $ readTypeName enum)] + encodeNode ResEnum {} _ = + failure ("wrong selection on enum value" :: Message) + -- UNION + encodeNode (ResUnion typename unionRef) (UnionSelection selections) = + unionRef >>= resolveObject currentSelection + where + currentSelection = pickSelection typename selections + encodeNode (ResUnion name _) _ = + failure ("union Resolver " <> msg name <> " should only recieve UnionSelection") + -- SCALARS + encodeNode ResNull _ = pure Null + encodeNode (ResScalar x) SelectionField = pure $ Scalar x + encodeNode ResScalar {} _ = + failure ("scalar Resolver should only recieve SelectionField" :: Message) + +runResolver :: + Monad m => + Resolver o event m ValidValue -> + Context -> + ResponseStream event m ValidValue +runResolver (ResolverQ resT) sel = cleanEvents $ runReaderT (runResolverState resT) sel +runResolver (ResolverM resT) sel = mapEvent Publish $ runReaderT (runResolverState resT) sel +runResolver (ResolverS resT) sel = ResultT $ do + readResValue <- runResultT $ runReaderT (runResolverState resT) sel + pure $ case readResValue of + Failure x -> Failure x + Success {warnings, result, events = channels} -> do + let eventRes = toEventResolver result sel + Success + { events = [Subscribe $ Event channels eventRes], + warnings, + result = gqlNull + } + +-- Resolver Models ------------------------------------------------------------------- +type FieldResModel o e m = + (FieldName, Resolver o e m (ResModel o e m)) + +data ObjectResModel o e m = ObjectResModel + { __typename :: TypeName, + objectFields :: + [FieldResModel o e m] + } + deriving (Show) + +instance Merge (ObjectResModel o e m) where + merge _ (ObjectResModel tyname x) (ObjectResModel _ y) = + pure $ ObjectResModel tyname (x <> y) + +data ResModel (o :: OperationType) e (m :: * -> *) + = ResNull + | ResScalar ScalarValue + | ResEnum TypeName TypeName + | ResList [ResModel o e m] + | ResObject (ObjectResModel o e m) + | ResUnion TypeName (Resolver o e m (ResModel o e m)) + deriving (Show) + +instance Merge (ResModel o e m) where + merge p (ResObject x) (ResObject y) = + ResObject <$> merge p x y + merge _ _ _ = + failure $ internalResolvingError "can't merge: incompatible resolvers" + +data RootResModel e m = RootResModel + { query :: Eventless (ResModel QUERY e m), + mutation :: Eventless (ResModel MUTATION e m), + subscription :: Eventless (ResModel SUBSCRIPTION e m) + } + +runRootDataResolver :: + (Monad m, LiftOperation o) => + Eventless (ResModel o e m) -> + Context -> + ResponseStream e m (Value VALID) +runRootDataResolver + res + ctx@Context {operation = Operation {operationSelection}} = + do + root <- statelessToResultT res + runResolver (resolveObject operationSelection root) ctx + +runRootResModel :: Monad m => RootResModel e m -> Context -> ResponseStream e m (Value VALID) +runRootResModel + RootResModel + { query, + mutation, + subscription + } + ctx@Context {operation = Operation {operationType}} = + selectByOperation operationType + where + selectByOperation Query = + runRootDataResolver query ctx + selectByOperation Mutation = + runRootDataResolver mutation ctx + selectByOperation Subscription = + runRootDataResolver subscription ctx + +-- map Resolving strategies +class + MapStrategy + (from :: OperationType) + (to :: OperationType) + where + mapStrategy :: + Monad m => + Resolver from e m (ResModel from e m) -> + Resolver to e m (ResModel to e m) + +instance MapStrategy o o where + mapStrategy = id + +instance MapStrategy QUERY SUBSCRIPTION where + mapStrategy = ResolverS . pure . lift . fmap mapDeriving + +mapDeriving :: + ( MapStrategy o o', + Monad m + ) => + ResModel o e m -> + ResModel o' e m +mapDeriving ResNull = ResNull +mapDeriving (ResScalar x) = ResScalar x +mapDeriving (ResEnum typeName enum) = ResEnum typeName enum +mapDeriving (ResList x) = ResList $ map mapDeriving x +mapDeriving (ResObject x) = ResObject (mapObjectDeriving x) +mapDeriving (ResUnion name x) = ResUnion name (mapStrategy x) + +mapObjectDeriving :: + ( MapStrategy o o', + Monad m + ) => + ObjectResModel o e m -> + ObjectResModel o' e m +mapObjectDeriving (ObjectResModel tyname x) = + ObjectResModel tyname $ + map (mapEntry mapStrategy) x + +mapEntry :: (a -> b) -> (k, a) -> (k, b) +mapEntry f (name, value) = (name, f value) diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.Internal.Validation + ( Validator, + SelectionValidator, + InputValidator, + BaseValidator, + InputSource (..), + Context (..), + SelectionContext (..), + runValidator, + askSchema, + askContext, + askFragments, + askFieldType, + askTypeMember, + selectRequired, + selectKnown, + Constraint (..), + constraint, + withScope, + withScopeType, + withScopePosition, + askScopeTypeName, + selectWithDefaultValue, + askScopePosition, + askInputFieldType, + askInputMember, + startInput, + withInputScope, + inputMessagePrefix, + checkUnused, + Prop (..), + constraintInputUnion, + ScopeKind (..), + withDirective, + ) +where + +import Control.Monad.Trans.Reader + ( ReaderT (..), + ask, + withReaderT, + ) +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( Failure (..), + KeyOf (..), + Selectable, + member, + selectBy, + selectOr, + size, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + Directive (..), + FieldDefinition (..), + FieldName, + FieldsDefinition, + Fragments, + IN, + Message, + OUT, + Object, + Position, + Ref (..), + Schema, + TypeContent (..), + TypeDefinition (..), + TypeName (..), + TypeRef (..), + Value (..), + __inputname, + entryValue, + fromAny, + isFieldNullable, + msg, + toFieldName, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Morpheus.Types.Internal.Validation.Error + ( InternalError (..), + KindViolation (..), + MissingRequired (..), + Unknown (..), + Unused (..), + ) +import Data.Morpheus.Types.Internal.Validation.Validator + ( BaseValidator, + Constraint (..), + Context (..), + InputContext (..), + InputSource (..), + InputValidator, + Prop (..), + Resolution, + ScopeKind (..), + SelectionContext (..), + SelectionValidator, + Target (..), + Validator (..), + renderInputPrefix, + ) +import Data.Semigroup + ( (<>), + Semigroup (..), + ) + +getUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a) => ca -> [b] -> [b] +getUnused uses = filter (not . (`member` uses) . keyOf) + +failOnUnused :: Unused b => [b] -> Validator ctx () +failOnUnused x + | null x = return () + | otherwise = do + (gctx, _) <- Validator ask + failure $ map (unused gctx) x + +checkUnused :: (KeyOf b, KEY a ~ KEY b, Selectable ca a, Unused b) => ca -> [b] -> Validator ctx () +checkUnused uses = failOnUnused . getUnused uses + +constraint :: + forall (a :: Target) inp ctx. + KindViolation a inp => + Constraint (a :: Target) -> + inp -> + TypeDefinition ANY -> + Validator ctx (Resolution a) +constraint OBJECT _ TypeDefinition {typeContent = DataObject {objectFields}, typeName} = + pure (typeName, objectFields) +constraint INPUT ctx x = maybe (failure [kindViolation INPUT ctx]) pure (fromAny x) +constraint target ctx _ = failure [kindViolation target ctx] + +selectRequired :: + ( Selectable c value, + MissingRequired c ctx, + KEY Ref ~ KEY value + ) => + Ref -> + c -> + Validator ctx value +selectRequired selector container = + do + (gctx, ctx) <- Validator ask + selectBy + [missingRequired gctx ctx selector container] + (keyOf selector) + container + +selectWithDefaultValue :: + ( Selectable values value, + MissingRequired values ctx, + KEY value ~ FieldName + ) => + value -> + FieldDefinition IN -> + values -> + Validator ctx value +selectWithDefaultValue + fallbackValue + field@FieldDefinition {fieldName} + values = + selectOr + handleNullable + pure + fieldName + values + where + ------------------ + handleNullable + | isFieldNullable field = pure fallbackValue + | otherwise = failSelection + ----------------- + failSelection = do + (gctx, ctx) <- Validator ask + failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values] + +selectKnown :: + ( Selectable c a, + Unknown c ctx, + KeyOf sel, + sel ~ UnknownSelector c, + KEY sel ~ KEY a + ) => + sel -> + c -> + Validator ctx a +selectKnown selector lib = + do + (gctx, ctx) <- Validator ask + selectBy + (unknown gctx ctx lib selector) + (keyOf selector) + lib + +askFieldType :: + FieldDefinition OUT -> + SelectionValidator (TypeDefinition OUT) +askFieldType field@FieldDefinition {fieldType = TypeRef {typeConName}} = + do + schema <- askSchema + anyType <- + selectBy + [internalError field] + typeConName + schema + case fromAny anyType of + Just x -> pure x + Nothing -> + failure $ + "Type \"" <> msg (typeName anyType) + <> "\" referenced by OBJECT \"" + <> "\" must be an OUTPUT_TYPE." + +askTypeMember :: + TypeName -> + SelectionValidator (TypeName, FieldsDefinition OUT) +askTypeMember name = + askSchema + >>= selectOr notFound pure name + >>= constraintOBJECT + where + notFound = do + scopeType <- askScopeTypeName + failure $ + "Type \"" + <> msg name + <> "\" referenced by union \"" + <> msg scopeType + <> "\" can't found in Schema." + -------------------------------------- + constraintOBJECT :: TypeDefinition ANY -> SelectionValidator (TypeName, FieldsDefinition OUT) + constraintOBJECT TypeDefinition {typeName, typeContent} = con typeContent + where + con DataObject {objectFields} = pure (typeName, objectFields) + con _ = do + scopeType <- askScopeTypeName + failure $ + "Type \"" <> msg typeName + <> "\" referenced by union \"" + <> msg scopeType + <> "\" must be an OBJECT." + +askInputFieldType :: + FieldDefinition IN -> + InputValidator (TypeDefinition IN) +askInputFieldType field@FieldDefinition {fieldName, fieldType = TypeRef {typeConName}} = + askSchema + >>= selectBy + [internalError field] + typeConName + >>= constraintINPUT + where + constraintINPUT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN) + constraintINPUT x = case (fromAny x :: Maybe (TypeDefinition IN)) of + Just inputType -> pure inputType + Nothing -> + failure $ + "Type \"" + <> msg (typeName x) + <> "\" referenced by field \"" + <> msg fieldName + <> "\" must be an input type." + +askInputMember :: + TypeName -> + InputValidator (TypeDefinition IN) +askInputMember name = + askSchema + >>= selectOr notFound pure name + >>= constraintINPUT_OBJECT + where + typeInfo tName = + "Type \"" <> msg tName <> "\" referenced by inputUnion " + notFound = do + scopeType <- askScopeTypeName + failure $ + typeInfo name + <> msg scopeType + <> "\" can't found in Schema." + -------------------------------------- + constraintINPUT_OBJECT :: TypeDefinition ANY -> InputValidator (TypeDefinition IN) + constraintINPUT_OBJECT TypeDefinition {typeContent, ..} = con (fromAny typeContent) + where + con :: Maybe (TypeContent a IN) -> InputValidator (TypeDefinition IN) + con (Just content@DataInputObject {}) = pure TypeDefinition {typeContent = content, ..} + con _ = do + scopeType <- askScopeTypeName + failure $ + typeInfo typeName + <> "\"" + <> msg scopeType + <> "\" must be an INPUT_OBJECT." + +startInput :: InputSource -> InputValidator a -> Validator ctx a +startInput inputSource = + setContext $ + const + InputContext + { inputSource, + inputPath = [] + } + +withDirective :: Directive s -> Validator ctx a -> Validator ctx a +withDirective + Directive + { directiveName, + directivePosition + } = setGlobalContext update + where + update ctx = + ctx + { scopePosition = directivePosition, + scopeSelectionName = directiveName, + scopeKind = DIRECTIVE + } + +withInputScope :: Prop -> InputValidator a -> InputValidator a +withInputScope prop = setContext update + where + update ctx@InputContext {inputPath = old} = + ctx {inputPath = old <> [prop]} + +runValidator :: Validator ctx a -> Context -> ctx -> Eventless a +runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx) + +askContext :: Validator ctx ctx +askContext = snd <$> Validator ask + +askSchema :: Validator ctx Schema +askSchema = schema . fst <$> Validator ask + +askFragments :: Validator ctx Fragments +askFragments = fragments . fst <$> Validator ask + +askScopeTypeName :: Validator ctx TypeName +askScopeTypeName = scopeTypeName . fst <$> Validator ask + +askScopePosition :: Validator ctx Position +askScopePosition = scopePosition . fst <$> Validator ask + +setContext :: + (c' -> c) -> + Validator c a -> + Validator c' a +setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator + +setGlobalContext :: + (Context -> Context) -> + Validator c a -> + Validator c a +setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator + +withScope :: TypeName -> Ref -> Validator ctx a -> Validator ctx a +withScope scopeTypeName (Ref scopeSelectionName scopePosition) = setGlobalContext update + where + update ctx = ctx {scopeTypeName, scopePosition, scopeSelectionName} + +withScopePosition :: Position -> Validator ctx a -> Validator ctx a +withScopePosition scopePosition = setGlobalContext update + where + update ctx = ctx {scopePosition} + +withScopeType :: TypeName -> Validator ctx a -> Validator ctx a +withScopeType scopeTypeName = setGlobalContext update + where + update ctx = ctx {scopeTypeName} + +inputMessagePrefix :: InputValidator Message +inputMessagePrefix = renderInputPrefix <$> askContext + +constraintInputUnion :: + forall stage. + [(TypeName, Bool)] -> + Object stage -> + Either Message (TypeName, Maybe (Value stage)) +constraintInputUnion tags hm = do + (enum :: Value stage) <- + entryValue + <$> selectBy + ( "valid input union should contain \"" + <> msg __inputname + <> "\" and actual value" + ) + __inputname + hm + tyName <- isPosibeInputUnion tags enum + case size hm of + 1 -> pure (tyName, Nothing) + 2 -> do + value <- + entryValue + <$> selectBy + ( "value for Union \"" + <> msg tyName + <> "\" was not Provided." + ) + (toFieldName tyName) + hm + pure (tyName, Just value) + _ -> failure ("input union can have only one variant." :: Message) + +isPosibeInputUnion :: [(TypeName, Bool)] -> Value stage -> Either Message TypeName +isPosibeInputUnion tags (Enum name) = case lookup name tags of + Nothing -> + failure + ( msg name + <> " is not posible union type" + ) + _ -> pure name +isPosibeInputUnion _ _ = + failure $ + "\"" + <> msg __inputname + <> "\" must be Enum" diff --git a/src/Data/Morpheus/Types/Internal/Validation/Error.hs b/src/Data/Morpheus/Types/Internal/Validation/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation/Error.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.Internal.Validation.Error + ( MissingRequired (..), + KindViolation (..), + Unknown (..), + InternalError (..), + Target (..), + Unused (..), + ) +where + +-- MORPHEUS + +import Data.Morpheus.Error.Selection (unknownSelectionField) +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + Arguments, + Directive (..), + DirectiveDefinition (..), + DirectiveDefinitions, + FieldDefinition (..), + FieldsDefinition, + Fragment (..), + Fragments, + GQLError (..), + GQLErrors, + IN, + OUT, + Object, + ObjectEntry (..), + RAW, + RESOLVED, + Ref (..), + Schema, + TypeNameRef (..), + TypeRef (..), + Variable (..), + VariableDefinitions, + getOperationName, + msg, + ) +import Data.Morpheus.Types.Internal.Validation.Validator + ( Context (..), + InputContext (..), + ScopeKind (..), + Target (..), + renderInputPrefix, + ) +import Data.Semigroup ((<>)) + +class InternalError a where + internalError :: a -> GQLError + +instance InternalError (FieldDefinition cat) where + internalError + FieldDefinition + { fieldName, + fieldType = TypeRef {typeConName} + } = + GQLError + { message = + "INTERNAL: Type " <> msg typeConName + <> " referenced by field " + <> msg fieldName + <> " can't found in Schema ", + locations = [] + } + +class Unused c where + unused :: Context -> c -> GQLError + +-- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".", +instance Unused (Variable s) where + unused + Context {operationName} + Variable {variableName, variablePosition} = + GQLError + { message = + "Variable " <> msg ("$" <> variableName) + <> " is never used in operation " + <> msg (getOperationName operationName) + <> ".", + locations = [variablePosition] + } + +instance Unused Fragment where + unused + _ + Fragment {fragmentName, fragmentPosition} = + GQLError + { message = + "Fragment " <> msg fragmentName + <> " is never used.", + locations = [fragmentPosition] + } + +class MissingRequired c ctx where + missingRequired :: Context -> ctx -> Ref -> c -> GQLError + +instance MissingRequired (Arguments s) ctx where + missingRequired + Context {scopePosition, scopeSelectionName, scopeKind} + _ + Ref {refName} + _ = + GQLError + { message = + inScope scopeKind + <> " argument " + <> msg refName + <> " is required but not provided.", + locations = [scopePosition] + } + where + inScope SELECTION = "Field " <> msg scopeSelectionName + inScope DIRECTIVE = "Directive " <> msg ("@" <> scopeSelectionName) + +instance MissingRequired (Object s) InputContext where + missingRequired + Context {scopePosition} + inputCTX + Ref {refName} + _ = + GQLError + { message = + renderInputPrefix inputCTX + <> "Undefined Field " + <> msg refName + <> ".", + locations = [scopePosition] + } + +instance MissingRequired (VariableDefinitions s) ctx where + missingRequired + Context {operationName} + _ + Ref {refName, refPosition} + _ = + GQLError + { message = + "Variable " + <> msg refName + <> " is not defined by operation " + <> msg (getOperationName operationName) + <> ".", + locations = [refPosition] + } + +class Unknown c ctx where + type UnknownSelector c + unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors + +-- {...H} -> "Unknown fragment \"H\"." +instance Unknown Fragments ctx where + type UnknownSelector Fragments = Ref + unknown _ _ _ (Ref name pos) = + errorMessage + pos + ("Unknown Fragment " <> msg name <> ".") + +instance Unknown Schema ctx where + type UnknownSelector Schema = TypeNameRef + unknown _ _ _ TypeNameRef {typeNameRef, typeNamePosition} = + errorMessage typeNamePosition ("Unknown type " <> msg typeNameRef <> ".") + +instance Unknown (FieldDefinition OUT) ctx where + type UnknownSelector (FieldDefinition OUT) = Argument RESOLVED + unknown _ _ FieldDefinition {fieldName} Argument {argumentName, argumentPosition} = + errorMessage + argumentPosition + ("Unknown Argument " <> msg argumentName <> " on Field " <> msg fieldName <> ".") + +instance Unknown (FieldsDefinition IN) InputContext where + type UnknownSelector (FieldsDefinition IN) = ObjectEntry RESOLVED + unknown Context {scopePosition} ctx _ ObjectEntry {entryName} = + [ GQLError + { message = renderInputPrefix ctx <> "Unknown Field " <> msg entryName <> ".", + locations = [scopePosition] + } + ] + +instance Unknown DirectiveDefinition ctx where + type UnknownSelector DirectiveDefinition = Argument RESOLVED + unknown _ _ DirectiveDefinition {directiveDefinitionName} Argument {argumentName, argumentPosition} = + errorMessage + argumentPosition + ("Unknown Argument " <> msg argumentName <> " on Directive " <> msg directiveDefinitionName <> ".") + +instance Unknown DirectiveDefinitions ctx where + type UnknownSelector DirectiveDefinitions = Directive RAW + unknown _ _ _ Directive {directiveName, directivePosition} = + errorMessage + directivePosition + ("Unknown Directive " <> msg directiveName <> ".") + +instance Unknown (FieldsDefinition OUT) ctx where + type UnknownSelector (FieldsDefinition OUT) = Ref + unknown Context {scopeTypeName} _ _ = + unknownSelectionField scopeTypeName + +class KindViolation (t :: Target) ctx where + kindViolation :: c t -> ctx -> GQLError + +instance KindViolation 'TARGET_OBJECT Fragment where + kindViolation _ Fragment {fragmentName, fragmentType, fragmentPosition} = + GQLError + { message = + "Fragment " + <> msg fragmentName + <> " cannot condition on non composite type " + <> msg fragmentType + <> ".", + locations = [fragmentPosition] + } + +instance KindViolation 'TARGET_INPUT (Variable s) where + kindViolation + _ + Variable + { variableName, + variablePosition, + variableType = TypeRef {typeConName} + } = + GQLError + { message = + "Variable " + <> msg ("$" <> variableName) + <> " cannot be non-input type " + <> msg typeConName + <> ".", + locations = [variablePosition] + } diff --git a/src/Data/Morpheus/Types/Internal/Validation/Validator.hs b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Validation/Validator.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Types.Internal.Validation.Validator + ( Validator (..), + SelectionValidator, + InputValidator, + BaseValidator, + runValidator, + askSchema, + askContext, + askFragments, + Constraint (..), + withScope, + withScopeType, + withScopePosition, + askScopeTypeName, + askScopePosition, + withInputScope, + inputMessagePrefix, + Context (..), + InputSource (..), + InputContext (..), + SelectionContext (..), + renderInputPrefix, + Target (..), + Prop (..), + Resolution, + ScopeKind (..), + ) +where + +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Trans.Reader + ( ReaderT (..), + ask, + withReaderT, + ) +-- MORPHEUS + +import Data.Morpheus.Internal.Utils + ( Failure (..), + ) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + FieldName, + FieldsDefinition, + Fragments, + GQLError (..), + GQLErrors, + IN, + Message, + OUT, + Position, + RAW, + RESOLVED, + Schema, + TypeDefinition (..), + TypeName, + VALID, + Variable (..), + VariableDefinitions, + intercalateName, + msg, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Semigroup + ( (<>), + Semigroup (..), + ) + +data Prop = Prop + { propName :: FieldName, + propTypeName :: TypeName + } + deriving (Show) + +type Path = [Prop] + +renderPath :: Path -> Message +renderPath [] = "" +renderPath path = "in field " <> msg (intercalateName "." $ map propName path) <> ": " + +renderInputPrefix :: InputContext -> Message +renderInputPrefix InputContext {inputPath, inputSource} = + renderSource inputSource <> renderPath inputPath + +renderSource :: InputSource -> Message +renderSource (SourceArgument Argument {argumentName}) = + "Argument " <> msg argumentName <> " got invalid value. " +renderSource (SourceVariable Variable {variableName}) = + "Variable " <> msg ("$" <> variableName) <> " got invalid value. " + +data ScopeKind + = DIRECTIVE + | SELECTION + deriving (Show) + +data Context = Context + { schema :: Schema, + fragments :: Fragments, + scopePosition :: Position, + scopeTypeName :: TypeName, + operationName :: Maybe FieldName, + scopeSelectionName :: FieldName, + scopeKind :: ScopeKind + } + deriving (Show) + +data InputContext = InputContext + { inputSource :: InputSource, + inputPath :: [Prop] + } + deriving (Show) + +data InputSource + = SourceArgument (Argument RESOLVED) + | SourceVariable (Variable RAW) + deriving (Show) + +newtype SelectionContext = SelectionContext + { variables :: VariableDefinitions VALID + } + deriving (Show) + +data Target + = TARGET_OBJECT + | TARGET_INPUT + +data Constraint (a :: Target) where + OBJECT :: Constraint 'TARGET_OBJECT + INPUT :: Constraint 'TARGET_INPUT + +-- UNION :: Constraint 'TARGET_UNION + +type family Resolution (a :: Target) + +type instance Resolution 'TARGET_OBJECT = (TypeName, FieldsDefinition OUT) + +type instance Resolution 'TARGET_INPUT = TypeDefinition IN + +--type instance Resolution 'TARGET_UNION = DataUnion + +withInputScope :: Prop -> InputValidator a -> InputValidator a +withInputScope prop = setContext update + where + update ctx@InputContext {inputPath = old} = + ctx {inputPath = old <> [prop]} + +askContext :: Validator ctx ctx +askContext = snd <$> Validator ask + +askSchema :: Validator ctx Schema +askSchema = schema . fst <$> Validator ask + +askFragments :: Validator ctx Fragments +askFragments = fragments . fst <$> Validator ask + +askScopeTypeName :: Validator ctx TypeName +askScopeTypeName = scopeTypeName . fst <$> Validator ask + +askScopePosition :: Validator ctx Position +askScopePosition = scopePosition . fst <$> Validator ask + +setContext :: + (c' -> c) -> + Validator c a -> + Validator c' a +setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator + +setGlobalContext :: + (Context -> Context) -> + Validator c a -> + Validator c a +setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator + +withScope :: TypeName -> Position -> Validator ctx a -> Validator ctx a +withScope scopeTypeName scopePosition = setGlobalContext update + where + update ctx = ctx {scopeTypeName, scopePosition} + +withScopePosition :: Position -> Validator ctx a -> Validator ctx a +withScopePosition scopePosition = setGlobalContext update + where + update ctx = ctx {scopePosition} + +withScopeType :: TypeName -> Validator ctx a -> Validator ctx a +withScopeType scopeTypeName = setGlobalContext update + where + update ctx = ctx {scopeTypeName} + +inputMessagePrefix :: InputValidator Message +inputMessagePrefix = renderInputPrefix <$> askContext + +runValidator :: Validator ctx a -> Context -> ctx -> Eventless a +runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx) + +newtype Validator ctx a = Validator + { _runValidator :: + ReaderT + (Context, ctx) + Eventless + a + } + deriving + ( Functor, + Applicative, + Monad + ) + +type BaseValidator = Validator () + +type SelectionValidator = Validator SelectionContext + +type InputValidator = Validator InputContext + +-- can be only used for internal errors +instance Failure Message (Validator ctx) where + failure inputMessage = do + position <- askScopePosition + failure + [ GQLError + { message = "INTERNAL: " <> inputMessage, + locations = [position] + } + ] + +instance Failure GQLErrors (Validator ctx) where + failure = Validator . lift . failure diff --git a/src/Data/Morpheus/Types/SelectionTree.hs b/src/Data/Morpheus/Types/SelectionTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/SelectionTree.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Data.Morpheus.Types.SelectionTree +-- Description : A simple interface for Morpheus internal Selection Set's representation. +module Data.Morpheus.Types.SelectionTree where + +import Data.Morpheus.Internal.Utils (elems, keyOf) +import Data.Morpheus.Types.Internal.AST.Base (FieldName, VALID) +import Data.Morpheus.Types.Internal.AST.Selection + ( Selection (..), + Selection (selectionContent), + SelectionContent (SelectionField, SelectionSet), + ) + +-- | The 'SelectionTree' instance is a simple interface for interacting +-- with morpheus's internal AST while keeping the ability to safely change the concrete +-- representation of the AST. +-- The set of operation is very limited on purpose. +class SelectionTree nodeType where + -- | leaf test: is the list of children empty? + isLeaf :: nodeType -> Bool + + -- | Get the children + getChildrenList :: nodeType -> [nodeType] + + -- | get a node's name + getName :: nodeType -> FieldName + +instance SelectionTree (Selection VALID) where + isLeaf node = case selectionContent node of + SelectionField -> True + _ -> False + + getChildrenList node = case selectionContent node of + SelectionField -> mempty + (SelectionSet deeperSel) -> elems deeperSel + + getName = keyOf diff --git a/src/Data/Morpheus/Validation/Document/Validation.hs b/src/Data/Morpheus/Validation/Document/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Document/Validation.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Validation.Document.Validation + ( validatePartialDocument, + validateSchema, + ) +where + +import Data.Functor (($>)) +-- +-- Morpheus +import Data.Morpheus.Error.Document.Interface + ( ImplementsError (..), + partialImplements, + unknownInterface, + ) +import Data.Morpheus.Internal.Utils + ( Selectable (..), + elems, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + FieldDefinition (..), + FieldName (..), + FieldsDefinition, + OUT, + Schema, + TypeContent (..), + TypeDefinition (..), + TypeName, + TypeRef (..), + isWeaker, + lookupWith, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Failure (..), + ) + +validateSchema :: Schema -> Eventless Schema +validateSchema schema = validatePartialDocument (elems schema) $> schema + +validatePartialDocument :: [TypeDefinition ANY] -> Eventless [TypeDefinition ANY] +validatePartialDocument lib = traverse validateType lib + where + validateType :: TypeDefinition ANY -> Eventless (TypeDefinition ANY) + validateType dt@TypeDefinition {typeName, typeContent = DataObject {objectImplements, objectFields}} = do + interface <- traverse getInterfaceByKey objectImplements + case concatMap (mustBeSubset objectFields) interface of + [] -> pure dt + errors -> failure $ partialImplements typeName errors + validateType x = pure x + mustBeSubset :: + FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> [(TypeName, FieldName, ImplementsError)] + mustBeSubset objFields (typeName, fields) = concatMap checkField (elems fields) + where + checkField :: FieldDefinition OUT -> [(TypeName, FieldName, ImplementsError)] + checkField FieldDefinition {fieldName, fieldType = interfaceT@TypeRef {typeConName = interfaceTypeName, typeWrappers = interfaceWrappers}} = + selectOr err checkTypeEq fieldName objFields + where + err = [(typeName, fieldName, UndefinedField)] + checkTypeEq FieldDefinition {fieldType = objT@TypeRef {typeConName, typeWrappers}} + | typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers) = + [] + | otherwise = + [ ( typeName, + fieldName, + UnexpectedType + { expectedType = interfaceT, + foundType = objT + } + ) + ] + ------------------------------- + getInterfaceByKey :: TypeName -> Eventless (TypeName, FieldsDefinition OUT) + getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of + Just TypeDefinition {typeContent = DataInterface {interfaceFields}} -> pure (interfaceName, interfaceFields) + _ -> failure $ unknownInterface interfaceName diff --git a/src/Data/Morpheus/Validation/Internal/Directive.hs b/src/Data/Morpheus/Validation/Internal/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Internal/Directive.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Validation.Internal.Directive + ( shouldIncludeSelection, + validateDirectives, + ) +where + +-- MORPHEUS +import Data.Morpheus.Error (errorMessage, globalErrorMessage) +import Data.Morpheus.Internal.Utils + ( Failure (..), + selectBy, + selectOr, + ) +import Data.Morpheus.Schema.Directives (defaultDirectives) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + Directive (..), + DirectiveDefinition (..), + DirectiveLocation (..), + Directives, + FieldName, + RAW, + ScalarValue (..), + VALID, + Value (..), + msg, + ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator, + selectKnown, + withDirective, + ) +import Data.Morpheus.Validation.Query.Arguments + ( validateDirectiveArguments, + ) +import Data.Semigroup ((<>)) + +validateDirective :: DirectiveLocation -> [DirectiveDefinition] -> Directive RAW -> SelectionValidator (Directive VALID) +validateDirective location directiveDefs directive@Directive {directiveArgs, ..} = + withDirective directive $ do + directiveDef <- selectKnown directive directiveDefs + args <- validateDirectiveArguments directiveDef directiveArgs + validateDirectiveLocation location directive directiveDef + pure Directive {directiveArgs = args, ..} + +validateDirectiveLocation :: + DirectiveLocation -> + Directive s -> + DirectiveDefinition -> + SelectionValidator () +validateDirectiveLocation + loc + Directive {directiveName, directivePosition} + DirectiveDefinition {directiveDefinitionLocations} + | loc `elem` directiveDefinitionLocations = pure () + | otherwise = + failure $ + errorMessage + directivePosition + ("Directive " <> msg directiveName <> " may not to be used on " <> msg loc) + +validateDirectives :: DirectiveLocation -> Directives RAW -> SelectionValidator (Directives VALID) +validateDirectives location = traverse (validateDirective location defaultDirectives) + +directiveFulfilled :: Bool -> FieldName -> Directives s -> SelectionValidator Bool +directiveFulfilled target = selectOr (pure True) (argumentIf target) + +shouldIncludeSelection :: Directives VALID -> SelectionValidator Bool +shouldIncludeSelection directives = do + dontSkip <- directiveFulfilled False "skip" directives + include <- directiveFulfilled True "include" directives + pure (dontSkip && include) + +argumentIf :: Bool -> Directive s -> SelectionValidator Bool +argumentIf target Directive {directiveName, directiveArgs} = + selectBy err "if" directiveArgs + >>= assertArgument target + where + err = globalErrorMessage $ "Directive " <> msg ("@" <> directiveName) <> " argument \"if\" of type \"Boolean!\" is required but not provided." + +assertArgument :: Bool -> Argument s -> SelectionValidator Bool +assertArgument asserted Argument {argumentValue = Scalar (Boolean actual)} = pure (asserted == actual) +assertArgument _ Argument {argumentValue} = failure $ "Expected type Boolean!, found " <> msg argumentValue <> "." diff --git a/src/Data/Morpheus/Validation/Internal/Value.hs b/src/Data/Morpheus/Validation/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Internal/Value.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Validation.Internal.Value (validateInput) where + +import Data.Foldable (traverse_) +import Data.List (elem) +import Data.Maybe (maybe) +-- MORPHEUS + +import Data.Morpheus.Error.Input (typeViolation) +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Error.Variable (incompatibleVariableType) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + ) +import Data.Morpheus.Types.Internal.AST + ( DataEnumValue (..), + FieldDefinition (..), + IN, + Message, + ObjectEntry (..), + RESOLVED, + Ref (..), + ResolvedValue, + ScalarDefinition (..), + ScalarValue (..), + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeName (..), + TypeRef (..), + TypeRef (..), + TypeWrapper (..), + VALID, + ValidValue, + Value (..), + Variable (..), + Variable (..), + VariableContent (..), + isNullableWrapper, + isWeaker, + msg, + toFieldName, + ) +import Data.Morpheus.Types.Internal.AST.OrderedMap + ( unsafeFromValues, + ) +import Data.Morpheus.Types.Internal.Validation + ( InputValidator, + Prop (..), + askInputFieldType, + askInputMember, + askScopePosition, + constraintInputUnion, + inputMessagePrefix, + selectKnown, + selectWithDefaultValue, + withInputScope, + withScopeType, + ) +import Data.Semigroup ((<>)) + +castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a +castFailure expected message value = do + pos <- askScopePosition + prefix <- inputMessagePrefix + failure + $ errorMessage pos + $ prefix <> typeViolation expected value <> maybe "" (" " <>) message + +checkTypeEquality :: + (TypeName, [TypeWrapper]) -> + Ref -> + Variable VALID -> + InputValidator ValidValue +checkTypeEquality (tyConName, tyWrappers) ref var@Variable {variableValue = ValidVariableValue value, variableType} + | typeConName variableType == tyConName + && not + (isWeaker (typeWrappers variableType) tyWrappers) = + pure value + | otherwise = + failure $ + incompatibleVariableType + ref + var + TypeRef + { typeConName = tyConName, + typeWrappers = tyWrappers, + typeArgs = Nothing + } + +-- Validate Variable Argument or all Possible input Values +validateInput :: + [TypeWrapper] -> + TypeDefinition IN -> + ObjectEntry RESOLVED -> + InputValidator ValidValue +validateInput tyWrappers TypeDefinition {typeContent = tyCont, typeName} = + withScopeType typeName + . validateWrapped tyWrappers tyCont + where + mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue + mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing + -- VALIDATION + validateWrapped :: + [TypeWrapper] -> + TypeContent TRUE IN -> + ObjectEntry RESOLVED -> + InputValidator ValidValue + -- Validate Null. value = null ? + validateWrapped wrappers _ ObjectEntry {entryValue = ResolvedVariable ref variable} = + checkTypeEquality (typeName, wrappers) ref variable + validateWrapped wrappers _ ObjectEntry {entryValue = Null} + | isNullableWrapper wrappers = return Null + | otherwise = mismatchError wrappers Null + -- Validate LIST + validateWrapped (TypeMaybe : wrappers) _ value = + validateWrapped wrappers tyCont value + validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) = + List <$> traverse validateElement list + where + validateElement = validateWrapped wrappers tyCont . ObjectEntry key + {-- 2. VALIDATE TYPES, all wrappers are already Processed --} + {-- VALIDATE OBJECT--} + validateWrapped [] dt v = validate dt v + where + validate :: + TypeContent TRUE IN -> ObjectEntry RESOLVED -> InputValidator ValidValue + validate (DataInputObject parentFields) ObjectEntry {entryValue = Object fields} = do + traverse_ requiredFieldsDefined (elems parentFields) + Object <$> traverse validateField fields + where + requiredFieldsDefined :: FieldDefinition IN -> InputValidator (ObjectEntry RESOLVED) + requiredFieldsDefined fieldDef@FieldDefinition {fieldName} = + selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields + validateField :: + ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID) + validateField entry@ObjectEntry {entryName} = do + inputField@FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}} <- getField + inputTypeDef <- askInputFieldType inputField + withInputScope (Prop entryName typeConName) $ + ObjectEntry entryName + <$> validateInput + typeWrappers + inputTypeDef + entry + where + getField = selectKnown entry parentFields + -- VALIDATE INPUT UNION + -- TODO: enhance input union Validation + validate (DataInputUnion inputUnion) ObjectEntry {entryValue = Object rawFields} = + case constraintInputUnion inputUnion rawFields of + Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields) + Right (name, Nothing) -> return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name)]) + Right (name, Just value) -> do + inputDef <- askInputMember name + validValue <- + validateInput + [TypeMaybe] + inputDef + (ObjectEntry (toFieldName name) value) + return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry (toFieldName name) validValue]) + {-- VALIDATE ENUM --} + validate (DataEnum tags) ObjectEntry {entryValue} = + validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue + {-- VALIDATE SCALAR --} + validate (DataScalar dataScalar) ObjectEntry {entryValue} = + validateScalar typeName dataScalar entryValue (castFailure (TypeRef typeName Nothing [])) + validate _ ObjectEntry {entryValue} = mismatchError [] entryValue + {-- 3. THROW ERROR: on invalid values --} + validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers entryValue + +validateScalar :: + TypeName -> + ScalarDefinition -> + ResolvedValue -> + (Maybe Message -> ResolvedValue -> InputValidator ValidValue) -> + InputValidator ValidValue +validateScalar typeName ScalarDefinition {validateValue} value err = do + scalarValue <- toScalar value + case validateValue scalarValue of + Right _ -> pure scalarValue + Left "" -> err Nothing value + Left message -> err (Just $ msg message) value + where + toScalar :: ResolvedValue -> InputValidator ValidValue + toScalar (Scalar x) | isValidDefault typeName x = pure (Scalar x) + toScalar _ = err Nothing value + isValidDefault :: TypeName -> ScalarValue -> Bool + isValidDefault "Boolean" = isBoolean + isValidDefault "String" = isString + isValidDefault "Float" = \x -> isFloat x || isInt x + isValidDefault "Int" = isInt + isValidDefault _ = const True + +isBoolean :: ScalarValue -> Bool +isBoolean Boolean {} = True +isBoolean _ = False + +isString :: ScalarValue -> Bool +isString String {} = True +isString _ = False + +isFloat :: ScalarValue -> Bool +isFloat Float {} = True +isFloat _ = False + +isInt :: ScalarValue -> Bool +isInt Int {} = True +isInt _ = False + +validateEnum :: + (ResolvedValue -> InputValidator ValidValue) -> + [DataEnumValue] -> + ResolvedValue -> + InputValidator ValidValue +validateEnum err enumValues value@(Enum enumValue) + | enumValue `elem` tags = pure (Enum enumValue) + | otherwise = err value + where + tags = map enumName enumValues +validateEnum err _ value = err value diff --git a/src/Data/Morpheus/Validation/Query/Arguments.hs b/src/Data/Morpheus/Validation/Query/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/Arguments.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Morpheus.Validation.Query.Arguments + ( validateDirectiveArguments, + validateFieldArguments, + ) +where + +import Data.Foldable (traverse_) +import Data.Morpheus.Internal.Utils + ( elems, + empty, + ) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + ArgumentDefinition, + Arguments, + ArgumentsDefinition (..), + DirectiveDefinition, + DirectiveDefinition (..), + FieldDefinition (..), + OUT, + ObjectEntry (..), + RAW, + RESOLVED, + RawValue, + ResolvedValue, + TypeRef (..), + VALID, + Value (..), + ) +import Data.Morpheus.Types.Internal.Validation + ( InputSource (..), + SelectionContext (..), + SelectionValidator, + askContext, + askInputFieldType, + askScopePosition, + selectKnown, + selectRequired, + selectWithDefaultValue, + startInput, + withScopePosition, + ) +import Data.Morpheus.Validation.Internal.Value + ( validateInput, + ) + +-- only Resolves , doesnot checks the types +resolveObject :: RawValue -> SelectionValidator ResolvedValue +resolveObject = resolve + where + resolveEntry :: ObjectEntry RAW -> SelectionValidator (ObjectEntry RESOLVED) + resolveEntry (ObjectEntry name v) = ObjectEntry name <$> resolve v + ------------------------------------------------ + resolve :: RawValue -> SelectionValidator ResolvedValue + resolve Null = pure Null + resolve (Scalar x) = pure $ Scalar x + resolve (Enum x) = pure $ Enum x + resolve (List x) = List <$> traverse resolve x + resolve (Object obj) = Object <$> traverse resolveEntry obj + resolve (VariableValue ref) = + variables <$> askContext + >>= fmap (ResolvedVariable ref) + . selectRequired ref + +resolveArgumentVariables :: + Arguments RAW -> + SelectionValidator (Arguments RESOLVED) +resolveArgumentVariables = + traverse resolveVariable + where + resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED) + resolveVariable (Argument key val position) = do + constValue <- resolveObject val + pure $ Argument key constValue position + +validateArgument :: + Arguments RESOLVED -> + ArgumentDefinition -> + SelectionValidator (Argument VALID) +validateArgument + requestArgs + argumentDef@FieldDefinition + { fieldName, + fieldType = TypeRef {typeWrappers} + } = + do + argumentPosition <- askScopePosition + argument <- + selectWithDefaultValue + Argument {argumentName = fieldName, argumentValue = Null, argumentPosition} + argumentDef + requestArgs + validateArgumentValue argument + where + ------------------------------------------------------------------------- + validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID) + validateArgumentValue arg@Argument {argumentValue = value, ..} = + withScopePosition argumentPosition + $ startInput (SourceArgument arg) + $ do + datatype <- askInputFieldType argumentDef + argumentValue <- + validateInput + typeWrappers + datatype + (ObjectEntry fieldName value) + pure Argument {argumentValue, ..} + +validateFieldArguments :: + FieldDefinition OUT -> + Arguments RAW -> + SelectionValidator (Arguments VALID) +validateFieldArguments + fieldDef@FieldDefinition {fieldArgs} + rawArgs = + do + args <- resolveArgumentVariables rawArgs + traverse_ checkUnknown (elems args) + traverse (validateArgument args) argsDef + where + argsDef = case fieldArgs of + (ArgumentsDefinition _ argsD) -> argsD + NoArguments -> empty + ------------------------------------------------- + checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition + checkUnknown = (`selectKnown` fieldDef) + +validateDirectiveArguments :: + DirectiveDefinition -> + Arguments RAW -> + SelectionValidator (Arguments VALID) +validateDirectiveArguments + directiveDef@DirectiveDefinition {directiveDefinitionArgs} + rawArgs = + do + args <- resolveArgumentVariables rawArgs + traverse_ checkUnknown (elems args) + traverse (validateArgument args) argsDef + where + argsDef = case directiveDefinitionArgs of + (ArgumentsDefinition _ argsD) -> argsD + NoArguments -> empty + ------------------------------------------------- + checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition + checkUnknown = (`selectKnown` directiveDef) diff --git a/src/Data/Morpheus/Validation/Query/Fragment.hs b/src/Data/Morpheus/Validation/Query/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/Fragment.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Validation.Query.Fragment + ( validateFragments, + castFragmentType, + resolveSpread, + ) +where + +import Data.Foldable (traverse_) +-- MORPHEUS +import Data.Morpheus.Error.Fragment + ( cannotBeSpreadOnType, + cannotSpreadWithinItself, + ) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + selectOr, + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + Fragment (..), + Fragments, + Position, + RAW, + Ref (..), + Selection (..), + SelectionContent (..), + SelectionSet, + TypeName, + TypeNameRef (..), + ) +import Data.Morpheus.Types.Internal.Validation + ( BaseValidator, + Constraint (..), + Validator, + askFragments, + askSchema, + checkUnused, + constraint, + selectKnown, + ) +import Data.Semigroup ((<>)) + +validateFragments :: SelectionSet RAW -> BaseValidator () +validateFragments selectionSet = + fragmentsCycleChecking + *> checkUnusedFragments selectionSet + *> fragmentsConditionTypeChecking + +checkUnusedFragments :: SelectionSet RAW -> BaseValidator () +checkUnusedFragments selectionSet = do + fragments <- askFragments + checkUnused + (usedFragments fragments (elems selectionSet)) + (elems fragments) + +castFragmentType :: + Maybe FieldName -> Position -> [TypeName] -> Fragment -> Validator ctx Fragment +castFragmentType key position typeMembers fragment@Fragment {fragmentType} + | fragmentType `elem` typeMembers = pure fragment + | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers + +resolveSpread :: [TypeName] -> Ref -> Validator ctx Fragment +resolveSpread allowedTargets ref@Ref {refName, refPosition} = + askFragments + >>= selectKnown ref + >>= castFragmentType (Just refName) refPosition allowedTargets + +usedFragments :: Fragments -> [Selection RAW] -> [Node] +usedFragments fragments = concatMap findAllUses + where + findUsesSelectionContent :: SelectionContent RAW -> [Node] + findUsesSelectionContent (SelectionSet selectionSet) = + concatMap findAllUses selectionSet + findUsesSelectionContent SelectionField = [] + findAllUses :: Selection RAW -> [Node] + findAllUses Selection {selectionContent} = + findUsesSelectionContent selectionContent + findAllUses (InlineFragment Fragment {fragmentSelection}) = + concatMap findAllUses fragmentSelection + findAllUses (Spread _ Ref {refName, refPosition}) = + [Ref refName refPosition] <> searchInFragment + where + searchInFragment = + selectOr + [] + (concatMap findAllUses . fragmentSelection) + refName + fragments + +fragmentsConditionTypeChecking :: BaseValidator () +fragmentsConditionTypeChecking = + elems <$> askFragments + >>= traverse_ checkTypeExistence + +checkTypeExistence :: Fragment -> BaseValidator () +checkTypeExistence fr@Fragment {fragmentType, fragmentPosition} = + askSchema + >>= selectKnown (TypeNameRef fragmentType fragmentPosition) + >>= constraint OBJECT fr + >> pure () + +fragmentsCycleChecking :: BaseValidator () +fragmentsCycleChecking = exploreSpreads >>= fragmentCycleChecking + +exploreSpreads :: BaseValidator Graph +exploreSpreads = map exploreFragmentSpreads . elems <$> askFragments + +exploreFragmentSpreads :: Fragment -> NodeEdges +exploreFragmentSpreads Fragment {fragmentName, fragmentSelection, fragmentPosition} = + (Ref fragmentName fragmentPosition, concatMap scanForSpread fragmentSelection) + +scanForSpreadContent :: SelectionContent RAW -> [Node] +scanForSpreadContent SelectionField = [] +scanForSpreadContent (SelectionSet selectionSet) = + concatMap scanForSpread selectionSet + +scanForSpread :: Selection RAW -> [Node] +scanForSpread Selection {selectionContent} = + scanForSpreadContent selectionContent +scanForSpread (InlineFragment Fragment {fragmentSelection}) = + concatMap scanForSpread fragmentSelection +scanForSpread (Spread _ Ref {refName, refPosition}) = + [Ref refName refPosition] + +type Node = Ref + +type NodeEdges = (Node, [Node]) + +type Graph = [NodeEdges] + +fragmentCycleChecking :: Graph -> BaseValidator () +fragmentCycleChecking lib = traverse_ checkFragment lib + where + checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID] + +checkForCycle :: Graph -> Node -> [Node] -> BaseValidator Graph +checkForCycle lib parentNode history = case lookup parentNode lib of + Just node -> concat <$> traverse 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 = failure $ cannotSpreadWithinItself (n : history) diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/Selection.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Validation.Query.Selection + ( validateOperation, + ) +where + +-- MORPHEUS +import Data.Morpheus.Error.Selection + ( hasNoSubfields, + subfieldsNotSelected, + ) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + empty, + keyOf, + singleton, + ) +import Data.Morpheus.Types.Internal.AST + ( Arguments, + DirectiveLocation (FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT, MUTATION, QUERY, SUBSCRIPTION), + Directives, + FieldDefinition, + FieldName, + FieldsDefinition, + Fragment (..), + GQLError (..), + OUT, + Operation (..), + OperationType (..), + RAW, + Ref (..), + Selection (..), + SelectionContent (..), + SelectionSet, + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeName, + VALID, + getOperationDataType, + isEntNode, + msg, + ) +import Data.Morpheus.Types.Internal.AST.MergeSet + ( concatTraverse, + ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator, + askFieldType, + askSchema, + selectKnown, + withScope, + ) +import Data.Morpheus.Validation.Internal.Directive + ( shouldIncludeSelection, + validateDirectives, + ) +import Data.Morpheus.Validation.Query.Arguments + ( validateFieldArguments, + ) +import Data.Morpheus.Validation.Query.Fragment + ( castFragmentType, + resolveSpread, + ) +import Data.Morpheus.Validation.Query.UnionSelection + ( validateUnionSelection, + ) +import Data.Semigroup ((<>)) + +type TypeDef = (TypeName, FieldsDefinition OUT) + +getOperationObject :: + Operation a -> SelectionValidator (TypeName, FieldsDefinition OUT) +getOperationObject operation = do + dt <- askSchema >>= getOperationDataType operation + case dt of + TypeDefinition {typeContent = DataObject {objectFields}, typeName} -> pure (typeName, objectFields) + TypeDefinition {typeName} -> + failure $ + "Type Mismatch: operation \"" + <> msg typeName + <> "\" must be an Object" + +selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID] +selectionsWitoutTypename = filter (("__typename" /=) . keyOf) . elems + +singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator () +singleTopLevelSelection Operation {operationType = Subscription, operationName} selSet = + case selectionsWitoutTypename selSet of + (_ : xs) | not (null xs) -> failure $ map (singleTopLevelSelectionError operationName) xs + _ -> pure () +singleTopLevelSelection _ _ = pure () + +singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError +singleTopLevelSelectionError name Selection {selectionPosition} = + GQLError + { message = + subscriptionName + <> " must select " + <> "only one top level field.", + locations = [selectionPosition] + } + where + subscriptionName = maybe "Anonymous Subscription" (("Subscription " <>) . msg) name + +validateOperation :: + Operation RAW -> + SelectionValidator (Operation VALID) +validateOperation + rawOperation@Operation + { operationName, + operationType, + operationSelection, + operationDirectives, + .. + } = + do + typeDef <- getOperationObject rawOperation + selection <- validateSelectionSet typeDef operationSelection + singleTopLevelSelection rawOperation selection + directives <- + validateDirectives + (toDirectiveLocation operationType) + operationDirectives + pure $ + Operation + { operationName, + operationType, + operationArguments = empty, + operationSelection = selection, + operationDirectives = directives, + .. + } + +toDirectiveLocation :: OperationType -> DirectiveLocation +toDirectiveLocation Subscription = SUBSCRIPTION +toDirectiveLocation Mutation = MUTATION +toDirectiveLocation Query = QUERY + +processSelectionDirectives :: + DirectiveLocation -> + Directives RAW -> + (Directives VALID -> SelectionValidator (SelectionSet VALID)) -> + SelectionValidator (SelectionSet VALID) +processSelectionDirectives location rawDirectives sel = do + directives <- validateDirectives location rawDirectives + include <- shouldIncludeSelection directives + selection <- sel directives + pure $ + if include + then selection + else empty + +validateSelectionSet :: + TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID) +validateSelectionSet dataType@(typeName, fieldsDef) = + concatTraverse validateSelection + where + -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet + validateSelection :: Selection RAW -> SelectionValidator (SelectionSet VALID) + validateSelection + sel@Selection + { selectionName, + selectionArguments, + selectionContent, + selectionPosition, + selectionDirectives + } = + withScope + typeName + currentSelectionRef + $ processSelectionDirectives + FIELD + selectionDirectives + (`validateSelectionContent` selectionContent) + where + currentSelectionRef = Ref selectionName selectionPosition + commonValidation :: SelectionValidator (TypeDefinition OUT, Arguments VALID) + commonValidation = do + (fieldDef :: FieldDefinition OUT) <- selectKnown (Ref selectionName selectionPosition) fieldsDef + -- validate field Argument ----- + arguments <- + validateFieldArguments + fieldDef + selectionArguments + -- check field Type existence ----- + (typeDef :: TypeDefinition OUT) <- askFieldType fieldDef + pure (typeDef, arguments) + ----------------------------------------------------------------------------------- + validateSelectionContent :: Directives VALID -> SelectionContent RAW -> SelectionValidator (SelectionSet VALID) + validateSelectionContent directives SelectionField + | null selectionArguments && selectionName == "__typename" = + pure $ singleton $ + sel + { selectionArguments = empty, + selectionDirectives = directives, + selectionContent = SelectionField + } + | otherwise = do + (datatype, validArgs) <- commonValidation + isLeaf datatype + pure $ singleton $ + sel + { selectionArguments = validArgs, + selectionDirectives = directives, + selectionContent = SelectionField + } + where + ------------------------------------------------------------ + isLeaf :: TypeDefinition OUT -> SelectionValidator () + isLeaf TypeDefinition {typeName = typename, typeContent} + | isEntNode typeContent = pure () + | otherwise = + failure $ + subfieldsNotSelected selectionName typename selectionPosition + ----- SelectionSet + validateSelectionContent directives (SelectionSet rawSelectionSet) = + do + (TypeDefinition {typeName = name, typeContent}, validArgs) <- commonValidation + selContent <- withScope name currentSelectionRef $ validateByTypeContent name typeContent + pure $ singleton $ + sel + { selectionArguments = validArgs, + selectionDirectives = directives, + selectionContent = selContent + } + where + validateByTypeContent :: TypeName -> TypeContent TRUE OUT -> SelectionValidator (SelectionContent VALID) + -- Validate UnionSelection + validateByTypeContent _ DataUnion {unionMembers} = + validateUnionSelection + validateSelectionSet + rawSelectionSet + unionMembers + -- Validate Regular selection set + validateByTypeContent typename DataObject {objectFields} = + SelectionSet + <$> validateSelectionSet + (typename, objectFields) + rawSelectionSet + validateByTypeContent typename DataInterface {interfaceFields} = + SelectionSet + <$> validateSelectionSet + (typename, interfaceFields) + rawSelectionSet + validateByTypeContent typename _ = + failure $ + hasNoSubfields + (Ref selectionName selectionPosition) + typename + validateSelection (Spread dirs ref) = + processSelectionDirectives FRAGMENT_SPREAD dirs + $ const + -- TODO: add directives to selection + $ resolveSpread [typeName] ref + >>= validateFragment + validateSelection + ( InlineFragment + fragment@Fragment + { fragmentDirectives, + fragmentPosition + } + ) = + processSelectionDirectives INLINE_FRAGMENT fragmentDirectives + $ const + -- TODO: add directives to selection + $ castFragmentType Nothing fragmentPosition [typeName] fragment + >>= validateFragment + -------------------------------------------------------------------------------- + validateFragment Fragment {fragmentSelection} = validateSelectionSet dataType fragmentSelection diff --git a/src/Data/Morpheus/Validation/Query/UnionSelection.hs b/src/Data/Morpheus/Validation/Query/UnionSelection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/UnionSelection.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Validation.Query.UnionSelection + ( validateUnionSelection, + ) +where + +import Control.Monad ((>=>)) +-- MORPHEUS +import Data.Morpheus.Error.Selection (unknownSelectionField) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + empty, + fromElems, + selectOr, + singleton, + ) +import Data.Morpheus.Types.Internal.AST + ( DataUnion, + FieldsDefinition, + Fragment (..), + OUT, + RAW, + Ref (..), + Selection (..), + SelectionContent (..), + SelectionSet, + SelectionSet, + TypeName, + UnionTag (..), + VALID, + ) +import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS + ( join, + ) +import Data.Morpheus.Types.Internal.Validation + ( SelectionValidator, + askScopeTypeName, + askTypeMember, + ) +import Data.Morpheus.Validation.Query.Fragment + ( castFragmentType, + resolveSpread, + ) + +type TypeDef = (TypeName, FieldsDefinition OUT) + +-- returns all Fragments used in Union +exploreUnionFragments :: + [TypeName] -> + Selection RAW -> + SelectionValidator [Fragment] +exploreUnionFragments unionTags = splitFrag + where + packFragment fragment = [fragment] + splitFrag :: + Selection RAW -> SelectionValidator [Fragment] + splitFrag (Spread _ ref) = packFragment <$> resolveSpread unionTags ref + splitFrag Selection {selectionName = "__typename", selectionContent = SelectionField} = pure [] + splitFrag Selection {selectionName, selectionPosition} = do + typeName <- askScopeTypeName + failure $ unknownSelectionField typeName (Ref selectionName selectionPosition) + splitFrag (InlineFragment fragment) = + packFragment + <$> castFragmentType Nothing (fragmentPosition fragment) unionTags fragment + +-- sorts Fragment by contitional Types +-- [ +-- ( Type for Tag User , [ Fragment for User] ) +-- ( Type for Tag Product , [ Fragment for Product] ) +-- ] +tagUnionFragments :: + [TypeDef] -> [Fragment] -> [(TypeDef, [Fragment])] +tagUnionFragments types fragments = + filter notEmpty $ + map categorizeType types + where + notEmpty = not . null . snd + categorizeType :: (TypeName, FieldsDefinition OUT) -> (TypeDef, [Fragment]) + categorizeType datatype = (datatype, filter matches fragments) + where + matches fragment = fragmentType fragment == fst datatype + +{- + - all Variable and Fragment references will be: resolved and validated + - unionTypes: will be clustered under type names + ...A on T1 {} + ...B on T2 {} + ...C on T2 {} + will be become : [ + UnionTag "T1" {}, + UnionTag "T2" {,} + ] + -} +validateCluster :: + (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) -> + SelectionSet RAW -> + [(TypeDef, [Fragment])] -> + SelectionValidator (SelectionContent VALID) +validateCluster validator __typename = traverse _validateCluster >=> fmap UnionSelection . fromElems + where + _validateCluster :: (TypeDef, [Fragment]) -> SelectionValidator UnionTag + _validateCluster (unionType, fragmets) = do + fragmentSelections <- MS.join (__typename : map fragmentSelection fragmets) + UnionTag (fst unionType) <$> validator unionType fragmentSelections + +validateUnionSelection :: + (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) -> + SelectionSet RAW -> + DataUnion -> + SelectionValidator (SelectionContent VALID) +validateUnionSelection validate selectionSet members = do + let (__typename :: SelectionSet RAW) = selectOr empty singleton "__typename" selectionSet + -- get union Types defined in GraphQL schema -> (union Tag, union Selection set) + -- [("User", FieldsDefinition { ... }), ("Product", FieldsDefinition { ... + unionTypes <- traverse askTypeMember members + -- find all Fragments used in Selection + spreads <- concat <$> traverse (exploreUnionFragments members) (elems selectionSet) + let categories = tagUnionFragments unionTypes spreads + validateCluster validate __typename categories diff --git a/src/Data/Morpheus/Validation/Query/Validation.hs b/src/Data/Morpheus/Validation/Query/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/Validation.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Validation.Query.Validation + ( validateRequest, + ) +where + +import Data.HashMap.Lazy (fromList) +import Data.Morpheus.Types.Internal.AST + ( GQLQuery (..), + Operation (..), + Schema (..), + VALID, + VALIDATION_MODE, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Morpheus.Types.Internal.Validation + ( Context (..), + ScopeKind (..), + SelectionContext (..), + runValidator, + ) +import Data.Morpheus.Validation.Query.Fragment + ( validateFragments, + ) +import Data.Morpheus.Validation.Query.Selection + ( validateOperation, + ) +import Data.Morpheus.Validation.Query.Variable + ( resolveOperationVariables, + ) + +validateRequest :: + Schema -> + VALIDATION_MODE -> + GQLQuery -> + Eventless (Operation VALID) +validateRequest + schema + validationMode + GQLQuery + { fragments, + inputVariables, + operation = + operation@Operation + { operationName, + operationSelection, + operationPosition + } + } = + do + variables <- runValidator validateHelpers ctx () + runValidator + (validateOperation operation) + ctx + SelectionContext + { variables + } + where + ctx = + Context + { schema, + fragments, + scopeTypeName = "Root", + scopeSelectionName = "Root", + scopePosition = operationPosition, + operationName, + scopeKind = SELECTION + } + validateHelpers = + validateFragments operationSelection + *> resolveOperationVariables + (fromList inputVariables) + validationMode + operation diff --git a/src/Data/Morpheus/Validation/Query/Variable.hs b/src/Data/Morpheus/Validation/Query/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Validation/Query/Variable.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Data.Morpheus.Validation.Query.Variable + ( resolveOperationVariables, + ) +where + +import qualified Data.HashMap.Lazy as M + ( lookup, + ) +import Data.Maybe (maybe) +--- MORPHEUS +import Data.Morpheus.Error.Variable (uninitializedVariable) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + ) +import Data.Morpheus.Types.Internal.AST + ( Argument (..), + DefaultValue, + Directive (..), + Fragment (..), + IN, + ObjectEntry (..), + Operation (..), + RAW, + RawValue, + Ref (..), + ResolvedValue, + Selection (..), + SelectionContent (..), + SelectionSet, + TypeDefinition, + TypeNameRef (..), + TypeRef (..), + VALID, + VALIDATION_MODE (..), + ValidValue, + Value (..), + Variable (..), + VariableContent (..), + VariableDefinitions, + Variables, + isNullable, + ) +import Data.Morpheus.Types.Internal.Validation + ( BaseValidator, + Constraint (..), + InputSource (..), + askFragments, + askSchema, + checkUnused, + constraint, + selectKnown, + startInput, + withScopePosition, + ) +import Data.Morpheus.Validation.Internal.Value + ( validateInput, + ) +import Data.Semigroup ((<>)) + +class ExploreRefs a where + exploreRefs :: a -> [Ref] + +instance ExploreRefs RawValue where + exploreRefs (VariableValue ref) = [ref] + exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields + exploreRefs (List ls) = concatMap exploreRefs ls + exploreRefs _ = [] + +instance ExploreRefs (Directive RAW) where + exploreRefs Directive {directiveArgs} = concatMap exploreRefs directiveArgs + +instance ExploreRefs (Argument RAW) where + exploreRefs = exploreRefs . argumentValue + +mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b] +mapSelection f = fmap concat . traverse f + +allVariableRefs :: [SelectionSet RAW] -> BaseValidator [Ref] +allVariableRefs = fmap concat . traverse (mapSelection searchRefs) + where + exploreSelectionContent :: SelectionContent RAW -> BaseValidator [Ref] + exploreSelectionContent SelectionField = pure [] + exploreSelectionContent (SelectionSet selSet) = mapSelection searchRefs selSet + --------------------------------------- + searchRefs :: Selection RAW -> BaseValidator [Ref] + searchRefs Selection {selectionArguments, selectionDirectives, selectionContent} = do + let directiveRefs = concatMap exploreRefs selectionDirectives + contentRefs <- exploreSelectionContent selectionContent + pure $ directiveRefs <> contentRefs <> concatMap exploreRefs selectionArguments + searchRefs (InlineFragment Fragment {fragmentSelection, fragmentDirectives}) = + (concatMap exploreRefs fragmentDirectives <>) + <$> mapSelection searchRefs fragmentSelection + searchRefs (Spread directives reference) = + (concatMap exploreRefs directives <>) + <$> ( askFragments + >>= selectKnown reference + >>= mapSelection searchRefs + . fragmentSelection + ) + +resolveOperationVariables :: + Variables -> + VALIDATION_MODE -> + Operation RAW -> + BaseValidator (VariableDefinitions VALID) +resolveOperationVariables + root + validationMode + Operation + { operationSelection, + operationArguments + } = + checkUnusedVariables + *> traverse (lookupAndValidateValueOnBody root validationMode) operationArguments + where + checkUnusedVariables :: BaseValidator () + checkUnusedVariables = do + uses <- allVariableRefs [operationSelection] + checkUnused uses (elems operationArguments) + +lookupAndValidateValueOnBody :: + Variables -> + VALIDATION_MODE -> + Variable RAW -> + BaseValidator (Variable VALID) +lookupAndValidateValueOnBody + bodyVariables + validationMode + var@Variable + { variableName, + variableType, + variablePosition, + variableValue = DefaultValue defaultValue + } = + withScopePosition variablePosition $ + toVariable + <$> ( askSchema + >>= selectKnown (TypeNameRef (typeConName variableType) variablePosition) + >>= constraint INPUT var + >>= checkType getVariable defaultValue + ) + where + toVariable x = var {variableValue = ValidVariableValue x} + getVariable :: Maybe ResolvedValue + getVariable = M.lookup variableName bodyVariables + ------------------------------------------------------------------ + -- checkType :: + checkType :: + Maybe ResolvedValue -> + DefaultValue -> + TypeDefinition IN -> + BaseValidator ValidValue + checkType (Just variable) Nothing varType = validator varType variable + checkType (Just variable) (Just defValue) varType = + validator varType defValue >> validator varType variable + checkType Nothing (Just defValue) varType = validator varType defValue + checkType Nothing Nothing varType + | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) = + failure $ uninitializedVariable var + | otherwise = + returnNull + where + returnNull = + maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables) + ----------------------------------------------------------------------------------------------- + validator :: TypeDefinition IN -> ResolvedValue -> BaseValidator ValidValue + validator varType varValue = + startInput (SourceVariable var) $ + validateInput + (typeWrappers variableType) + varType + (ObjectEntry variableName varValue) diff --git a/test/Lib.hs b/test/Lib.hs new file mode 100644 --- /dev/null +++ b/test/Lib.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Lib + ( getGQLBody, + getResponseBody, + getCases, + maybeVariables, + readSource, + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON, Value (..), decode) +import qualified Data.ByteString.Lazy as L (readFile) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Maybe (fromMaybe) +import Data.Morpheus.Types.Internal.AST (FieldName (..)) +import Data.Text (Text, unpack) + +readSource :: FieldName -> IO ByteString +readSource = L.readFile . path . readName + +path :: Text -> String +path name = "test/" ++ unpack name + +gqlLib :: Text -> String +gqlLib x = path x ++ "/query.gql" + +resLib :: Text -> String +resLib x = path x ++ "/response.json" + +maybeVariables :: FieldName -> IO (Maybe Value) +maybeVariables (FieldName x) = decode <$> (L.readFile (path x ++ "/variables.json") <|> return "{}") + +getGQLBody :: FieldName -> IO ByteString +getGQLBody (FieldName p) = L.readFile (gqlLib p) + +getCases :: FromJSON a => String -> IO [a] +getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" ++ dir ++ "/cases.json") + +getResponseBody :: FieldName -> IO Value +getResponseBody (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p) diff --git a/test/Schema.hs b/test/Schema.hs new file mode 100644 --- /dev/null +++ b/test/Schema.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Schema + ( testSchema, + ) +where + +import Control.Monad ((<=<)) +import Data.Aeson ((.:), (.=), FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, object) +import qualified Data.ByteString.Lazy.Char8 as LB (unpack) +import Data.Either (either) +import Data.Morpheus.Core (parseFullGQLDocument, validateSchema) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + GQLErrors, + Schema, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Result (..), + ) +import Data.Semigroup ((<>)) +import Data.Text (pack) +import GHC.Generics (Generic) +import Lib (readSource) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase) + +readSchema :: FieldName -> IO (Eventless Schema) +readSchema = fmap (validateSchema <=< parseFullGQLDocument) . readSource . ("schema/" <>) . (<> "/schema.gql") + +readResponse :: FieldName -> IO Response +readResponse = fmap (either AesonError id . eitherDecode) . readSource . ("schema/" <>) . (<> "/response.json") + +data Response + = OK + | Errors {errors :: GQLErrors} + | AesonError String + deriving (Generic) + +instance FromJSON Response where + parseJSON (Object v) = + Errors <$> v .: "errors" + parseJSON (String "OK") = pure OK + parseJSON v = pure $ AesonError (show v) + +instance ToJSON Response where + toJSON OK = String "OK" + toJSON (Errors err) = object ["errors" .= toJSON err] + toJSON (AesonError err) = String (pack err) + +testSchema :: TestTree +testSchema = + testGroup + "Test Schema" + [ testGroup + "Validation" + $ map + (uncurry schemaCase) + [ ("validation/interface/ok", "interface validation success"), + ("validation/interface/fail", "interface validation fails") + ] + ] + +schemaCase :: FieldName -> String -> TestTree +schemaCase path description = testCase description $ do + schema <- readSchema path + expected <- readResponse path + assertion expected schema + +assertion :: Response -> Eventless Schema -> IO () +assertion OK Success {} = return () +assertion Errors {errors = err} Failure {errors} + | err == errors = + pure + () +assertion expected Success {} = + assertFailure $ + LB.unpack + ("expected: \n " <> encode expected <> " \n but got: \n OK") +assertion expected Failure {errors} = + assertFailure $ + LB.unpack + ("expected: \n " <> encode expected <> " \n but got: \n " <> encode (Errors errors)) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main + ( main, + ) +where + +import qualified Data.Aeson as A +import Data.Aeson (decode, encode) +import Data.Functor.Identity (Identity (..)) +import Data.Morpheus.Core (runApi) +import Data.Morpheus.Internal.Utils + ( fromElems, + ) +import Data.Morpheus.QuasiQuoter (dsl) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + Schema, + VALID, + Value (..), + msg, + ) +import Data.Morpheus.Types.Internal.Resolving + ( ResModel, + Resolver, + ResponseStream, + Result (..), + ResultT (..), + RootResModel (..), + WithOperation, + mkList, + mkNull, + mkObject, + mkString, + ) +import Data.Semigroup ((<>)) +import qualified Data.Text.Lazy as LT (toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Lib + ( getGQLBody, + getResponseBody, + maybeVariables, + ) +import Schema + ( testSchema, + ) +import Test.Tasty + ( TestTree, + defaultMain, + testGroup, + ) +import Test.Tasty.HUnit + ( assertFailure, + testCase, + ) + +getSchema :: Monad m => ResponseStream e m Schema +getSchema = + fromElems + [dsl| + + type Query { + deity(name: String): Deity! + } + + interface Character { + name : String + } + + interface Supernatural { + power: [String!]! + } + + type Hero implements Character { + name: String + } + + type Deity implements Character Supernatural { + name: String! + power: [String!]! + } +|] + +resolver :: Monad m => RootResModel e m +resolver = + RootResModel + { query = + pure $ + mkObject + "Query" + [("deity", resolveDeity)], + mutation = pure mkNull, + subscription = pure mkNull + } + +resolveDeity :: (WithOperation o, Monad m) => Resolver o e m (ResModel o e m) +resolveDeity = + pure $ + mkObject + "Deity" + [ ("name", pure $ mkString "Morpheus"), + ("power", pure $ mkList [mkString "Shapeshifting"]) + ] + +main :: IO () +main = + defaultMain + $ testGroup + "core tests" + $ map + (uncurry basicTest) + [ ("basic Test", "simple"), + ("test interface", "interface") + ] + <> [testSchema] + +basicTest :: String -> FieldName -> TestTree +basicTest description path = testCase description $ do + actual <- simpleTest <$> getRequest path + expected <- expectedResponse path + assertion expected actual + +simpleTest :: GQLRequest -> ResponseStream e Identity (Value VALID) +simpleTest request = do + schema <- getSchema + runApi schema resolver request + +expectedResponse :: FieldName -> IO A.Value +expectedResponse = getResponseBody + +assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO () +assertion expected (ResultT (Identity Success {result})) + | Just expected == decode (encode result) = return () + | otherwise = + assertFailure $ show ("expected: \n " <> msg expected <> " \n but got: \n " <> msg result) +assertion _ (ResultT (Identity Failure {errors})) = assertFailure (show errors) + +getRequest :: FieldName -> IO GQLRequest +getRequest path = do + queryBS <- LT.toStrict . decodeUtf8 <$> getGQLBody path + variables <- maybeVariables path + pure $ + GQLRequest + { operationName = Nothing, + query = queryBS, + variables + } diff --git a/test/interface/query.gql b/test/interface/query.gql new file mode 100644 --- /dev/null +++ b/test/interface/query.gql @@ -0,0 +1,79 @@ +query Get__Type { + interface: __type(name: "Character") { + ...FullType + } + deity: __type(name: "Deity") { + ...FullType + } +} + +fragment FullType on __Type { + kind + name + fields(includeDeprecated: true) { + name + args { + ...InputValue + } + type { + ...TypeRef + } + isDeprecated + deprecationReason + } + inputFields { + ...InputValue + } + interfaces { + ...TypeRef + } + enumValues(includeDeprecated: true) { + name + isDeprecated + deprecationReason + } + possibleTypes { + ...TypeRef + } +} + +fragment InputValue on __InputValue { + name + type { + ...TypeRef + } + defaultValue +} + +fragment TypeRef on __Type { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + ofType { + kind + name + } + } + } + } + } + } + } +} diff --git a/test/interface/response.json b/test/interface/response.json new file mode 100644 --- /dev/null +++ b/test/interface/response.json @@ -0,0 +1,65 @@ +{ + "interface": { + "kind": "INTERFACE", + "name": "Character", + "fields": [ + { + "name": "name", + "args": [], + "type": { "kind": "SCALAR", "name": "String", "ofType": null }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": null, + "enumValues": null, + "possibleTypes": [ + { "kind": "OBJECT", "name": "Deity", "ofType": null }, + { "kind": "OBJECT", "name": "Hero", "ofType": null } + ] + }, + "deity": { + "kind": "OBJECT", + "name": "Deity", + "fields": [ + { + "name": "name", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + }, + "isDeprecated": false, + "deprecationReason": null + }, + { + "name": "power", + "args": [], + "type": { + "kind": "NON_NULL", + "name": null, + "ofType": { + "kind": "LIST", + "name": null, + "ofType": { + "kind": "NON_NULL", + "name": null, + "ofType": { "kind": "SCALAR", "name": "String", "ofType": null } + } + } + }, + "isDeprecated": false, + "deprecationReason": null + } + ], + "inputFields": null, + "interfaces": [ + { "kind": "INTERFACE", "name": "Character", "ofType": null }, + { "kind": "INTERFACE", "name": "Supernatural", "ofType": null } + ], + "enumValues": null, + "possibleTypes": null + } +} diff --git a/test/schema/validation/interface/fail/response.json b/test/schema/validation/interface/fail/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/fail/response.json @@ -0,0 +1,16 @@ +{ + "errors": [ + { + "message": "type \"Deity\" implements Interface \"Character\" Partially, on key \"name\" expected type \"String\" found \"Int\".", + "locations": [] + }, + { + "message": "type \"Deity\" implements Interface \"Supernatural\" Partially, on key \"power\" expected type \"[String!]!\" found \"[String!]\".", + "locations": [] + }, + { + "message": "type \"Hero\" implements Interface \"Character\" Partially, key \"name\" not found .", + "locations": [] + } + ] +} diff --git a/test/schema/validation/interface/fail/schema.gql b/test/schema/validation/interface/fail/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/fail/schema.gql @@ -0,0 +1,33 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name: String +} + +interface Supernatural { + power: [String!]! +} + +type Hero implements Character { + field: String +} + +type Deity implements Character & Supernatural { + name: Int + power: [String!] +} + +# TODO: validate arguments +# interface Aged { +# age(num: Int): String! +# } + +# type Human implements Aged { +# age(num: Int!): String +# } + +# type God implements Aged { +# age(date: String!): String +# } diff --git a/test/schema/validation/interface/ok/response.json b/test/schema/validation/interface/ok/response.json new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/ok/response.json @@ -0,0 +1,1 @@ +"OK" diff --git a/test/schema/validation/interface/ok/schema.gql b/test/schema/validation/interface/ok/schema.gql new file mode 100644 --- /dev/null +++ b/test/schema/validation/interface/ok/schema.gql @@ -0,0 +1,20 @@ +type Query { + deity(name: String): Deity! +} + +interface Character { + name: String +} + +interface Supernatural { + power: [String!]! +} + +type Hero implements Character { + name: String +} + +type Deity implements Character & Supernatural { + name: String! + power: [String!]! +} diff --git a/test/simple/query.gql b/test/simple/query.gql new file mode 100644 --- /dev/null +++ b/test/simple/query.gql @@ -0,0 +1,6 @@ +{ + deity { + name + power + } +} diff --git a/test/simple/response.json b/test/simple/response.json new file mode 100644 --- /dev/null +++ b/test/simple/response.json @@ -0,0 +1,6 @@ +{ + "deity": { + "name": "Morpheus", + "power": ["Shapeshifting"] + } +}