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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal new file mode 100644 --- /dev/null +++ b/morpheus-graphql.cabal @@ -0,0 +1,113 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: d7cc2512dba12ffbd4ce4220a0c8dfc022a9ea87b81033770a75b7146ec2c5e1 + +name: morpheus-graphql +version: 0.0.1 +synopsis: Morpheus GraphQL +description: Build GraphQL APIs with your favourite functional language! +category: web, graphql +homepage: https://github.com/nalchevanidze/morpheus-graphql#readme +bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues +author: Daviti Nalchevanidze +maintainer: d.nalchevanidze@gmail.com +copyright: (c) 2019 Daviti Nalchevanidze +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/nalchevanidze/morpheus-graphql + +library + exposed-modules: + Data.Morpheus + Data.Morpheus.Error.Arguments + Data.Morpheus.Error.Fragment + Data.Morpheus.Error.Input + Data.Morpheus.Error.Internal + Data.Morpheus.Error.Mutation + Data.Morpheus.Error.Selection + Data.Morpheus.Error.Spread + Data.Morpheus.Error.Syntax + Data.Morpheus.Error.Utils + Data.Morpheus.Error.Variable + Data.Morpheus.Generics.DeriveResolvers + Data.Morpheus.Generics.GDecode + Data.Morpheus.Generics.GDecodeEnum + Data.Morpheus.Generics.TypeRep + Data.Morpheus.Generics.Utils + Data.Morpheus.Kind + Data.Morpheus.Kind.GQLArgs + Data.Morpheus.Kind.GQLEnum + Data.Morpheus.Kind.GQLInput + Data.Morpheus.Kind.GQLKind + Data.Morpheus.Kind.GQLMutation + Data.Morpheus.Kind.GQLObject + Data.Morpheus.Kind.GQLQuery + Data.Morpheus.Kind.GQLScalar + Data.Morpheus.Parser.Arguments + Data.Morpheus.Parser.Body + Data.Morpheus.Parser.Fragment + Data.Morpheus.Parser.Mutation + Data.Morpheus.Parser.Parser + Data.Morpheus.Parser.Primitive + Data.Morpheus.Parser.Query + Data.Morpheus.Parser.RootHead + Data.Morpheus.PreProcess.Fragment + Data.Morpheus.PreProcess.Input.Enum + Data.Morpheus.PreProcess.Input.Object + Data.Morpheus.PreProcess.PreProcess + Data.Morpheus.PreProcess.Resolve.Arguments + Data.Morpheus.PreProcess.Resolve.ResolveRawQuery + Data.Morpheus.PreProcess.Resolve.Spread + Data.Morpheus.PreProcess.Selection + Data.Morpheus.PreProcess.Utils + Data.Morpheus.PreProcess.Validate.Arguments + Data.Morpheus.PreProcess.Validate.Validate + Data.Morpheus.PreProcess.Variable + Data.Morpheus.Schema.Directive + Data.Morpheus.Schema.DirectiveLocation + Data.Morpheus.Schema.EnumValue + Data.Morpheus.Schema.Field + Data.Morpheus.Schema.InputValue + Data.Morpheus.Schema.Internal.Types + Data.Morpheus.Schema.Schema + Data.Morpheus.Schema.Type + Data.Morpheus.Schema.TypeKind + Data.Morpheus.Schema.Utils.Utils + Data.Morpheus.Types.Core + Data.Morpheus.Types.Describer + Data.Morpheus.Types.Error + Data.Morpheus.Types.JSType + Data.Morpheus.Types.MetaInfo + Data.Morpheus.Types.Query.Fragment + Data.Morpheus.Types.Query.Operator + Data.Morpheus.Types.Query.RawSelection + Data.Morpheus.Types.Query.Selection + Data.Morpheus.Types.Request + Data.Morpheus.Types.Response + Data.Morpheus.Types.Types + Data.Morpheus.Wrapper + other-modules: + Paths_morpheus_graphql + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson >=1.0 && <=1.4.2.0 + , attoparsec >=0.13.2.2 && <0.14 + , base >=4.7 && <5 + , bytestring >=0.10.4 && <0.11 + , containers >=0.4.2.1 && <0.7 + , mtl >=2.0 && <=2.2.2 + , scientific >=0.3.6.2 && <0.4 + , text >=1.2.3.0 && <1.3 + , transformers >=0.3.0.0 && <0.6 + , unordered-containers >=0.2.8.0 && <0.3 + , vector >=0.12.0.1 && <0.13 + default-language: Haskell2010 diff --git a/src/Data/Morpheus.hs b/src/Data/Morpheus.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus + ( interpreter + ) where + +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Aeson (decode, encode) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Morpheus.Error.Utils (errorMessage, renderErrors) +import Data.Morpheus.Kind.GQLMutation (GQLMutation (..)) +import Data.Morpheus.Kind.GQLQuery (GQLQuery (..)) +import Data.Morpheus.Parser.Parser (parseGQL, parseLineBreaks) +import Data.Morpheus.PreProcess.PreProcess (preProcessQuery) +import Data.Morpheus.Schema.Internal.Types (TypeLib) +import Data.Morpheus.Types.Error (ResolveIO, failResolveIO) +import Data.Morpheus.Types.JSType (JSType) +import Data.Morpheus.Types.Query.Operator (Operator (..)) +import Data.Morpheus.Types.Request (GQLRequest) +import Data.Morpheus.Types.Response (GQLResponse (..)) +import Data.Morpheus.Types.Types (GQLRoot (..)) +import Data.Text (pack) + +schema :: (GQLQuery a, GQLMutation b) => a -> b -> TypeLib +schema queryRes mutationRes = mutationSchema mutationRes $ querySchema queryRes + +resolve :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> GQLRequest -> ResolveIO JSType +resolve rootResolver body = do + rootGQL <- ExceptT $ pure (parseGQL body >>= preProcessQuery gqlSchema) + case rootGQL of + Query _ _args selection _pos -> encodeQuery queryRes gqlSchema selection + Mutation _ _args selection _pos -> encodeMutation mutationRes selection + where + gqlSchema = schema queryRes mutationRes + queryRes = query rootResolver + mutationRes = mutation rootResolver + +lineBreaks :: B.ByteString -> [Int] +lineBreaks req = + case decode req of + Just x -> parseLineBreaks x + Nothing -> [] + +interpreterRaw :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> B.ByteString -> IO GQLResponse +interpreterRaw rootResolver request = do + value <- runExceptT $ parseRequest request >>= resolve rootResolver + case value of + Left x -> pure $ Errors $ renderErrors (lineBreaks request) x + Right x -> pure $ Data x + +interpreter :: (GQLQuery a, GQLMutation b) => GQLRoot a b -> B.ByteString -> IO B.ByteString +interpreter rootResolver request = encode <$> interpreterRaw rootResolver request + +parseRequest :: B.ByteString -> ResolveIO GQLRequest +parseRequest text = + case decode text of + Just x -> pure x + Nothing -> failResolveIO $ errorMessage 0 (pack $ show text) diff --git a/src/Data/Morpheus/Error/Arguments.hs b/src/Data/Morpheus/Error/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Arguments.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Arguments + ( undefinedArgument + , unknownArguments + , argumentGotInvalidValue + , argumentNameCollision + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (GQLError (..), GQLErrors) +import Data.Text (Text) +import qualified Data.Text as T (concat) + +{- + 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\"." +-} +argumentGotInvalidValue :: Text -> Text -> Int -> GQLErrors +argumentGotInvalidValue key' inputMessage' position' = errorMessage position' text + where + text = T.concat ["Argument ", key', " got invalid value ;", inputMessage'] + +unknownArguments :: Text -> [EnhancedKey] -> GQLErrors +unknownArguments fieldName = map keyToError + where + keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, posIndex = [pos]} + toMessage argName = T.concat ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."] + +argumentNameCollision :: [EnhancedKey] -> GQLErrors +argumentNameCollision = map keyToError + where + keyToError (EnhancedKey argName pos) = GQLError {desc = toMessage argName, posIndex = [pos]} + toMessage argName = T.concat ["There can Be only One Argument Named \"", argName] + +undefinedArgument :: EnhancedKey -> GQLErrors +undefinedArgument (EnhancedKey key' position') = errorMessage position' text + where + text = T.concat ["Required Argument: \"", key', "\" was not Defined"] 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,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Fragment + ( cannotSpreadWithinItself + ) where + +-- import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (GQLError (..), GQLErrors) + +-- import Data.Morpheus.Types.MetaInfo (MetaInfo(..)) +import qualified Data.Text as T + +{- + 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 :: [EnhancedKey] -> GQLErrors +cannotSpreadWithinItself fragments = [GQLError {desc = text, posIndex = map location fragments}] + where + text = + T.concat + [ "Cannot spread fragment \"" + , uid $ head fragments + , "\" within itself via " + , T.intercalate "," (map uid fragments) + , "." + ] 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,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Input + ( inputErrorMessage + , InputError(..) + , Prop(..) + , InputValidation + ) where + +import Data.Aeson (encode) +import Data.ByteString.Lazy.Char8 (unpack) +import Data.Morpheus.Types.JSType (JSType) +import Data.Text (Text) +import qualified Data.Text as T (concat, intercalate, pack) + +type InputValidation a = Either InputError a + +data InputError + = UnexpectedType [Prop] + Text + JSType + | UndefinedField [Prop] + Text + | UnknownField [Prop] + Text + +data Prop = Prop + { propKey :: Text + , propType :: Text + } + +inputErrorMessage :: InputError -> Text +inputErrorMessage (UnexpectedType path type' jsType) = expectedTypeAFoundB path type' jsType +inputErrorMessage (UndefinedField path' field') = undefinedField path' field' +inputErrorMessage (UnknownField path' field') = unknownField path' field' + +pathToText :: [Prop] -> Text +pathToText [] = "" +pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path'] + +expectedTypeAFoundB :: [Prop] -> Text -> JSType -> Text +expectedTypeAFoundB path' expected found = + T.concat [pathToText path', " Expected type \"", expected, "\" found ", T.pack (unpack $ encode found), "."] + +undefinedField :: [Prop] -> Text -> Text +undefinedField path' field' = T.concat [pathToText path', " Undefined Field \"", field', "\"."] + +unknownField :: [Prop] -> Text -> Text +unknownField path' field' = T.concat [pathToText path', " Unknown Field \"", field', "\"."] 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,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Internal + ( internalTypeMismatch + , internalArgumentError + , internalUnknownTypeMessage + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Error (GQLErrors) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Text (Text) +import qualified Data.Text as T (concat, pack) + +-- GQL:: if no mutation defined -> "Schema is not configured for mutations." +-- all kind internal error in development +internalError :: Text -> Either GQLErrors b +internalError x = Left $ errorMessage 0 $ T.concat ["INTERNAL ERROR: ", x] + +-- if type did not not found, but was defined by Schema +internalUnknownTypeMessage :: Text -> GQLErrors +internalUnknownTypeMessage x = errorMessage 0 $ T.concat ["type did not not found, but was defined by Schema", x] + +-- if arguments is already validated but has not found required argument +internalArgumentError :: Text -> Either GQLErrors b +internalArgumentError x = internalError $ T.concat ["Argument ", x] + +-- if value is already validated but value has different type +internalTypeMismatch :: Text -> JSType -> Either GQLErrors b +internalTypeMismatch text jsType = internalError $ T.concat ["Type mismatch ", text, T.pack $ show jsType] diff --git a/src/Data/Morpheus/Error/Mutation.hs b/src/Data/Morpheus/Error/Mutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Mutation.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Mutation + ( mutationIsNotDefined + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Error (GQLErrors) +import Data.Morpheus.Types.MetaInfo (Position) + +mutationIsNotDefined :: Position -> GQLErrors +mutationIsNotDefined position' = errorMessage position' "Schema is not configured for mutations." 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,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Selection + ( cannotQueryField + , subfieldsNotSelected + , duplicateQuerySelections + , hasNoSubfields + , fieldNotResolved + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (GQLError (..), GQLErrors) +import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position) +import qualified Data.Text as T (Text, concat) + +fieldNotResolved :: Position -> T.Text -> T.Text -> GQLErrors +fieldNotResolved position' key' message' = errorMessage position' text + where + text = T.concat ["Failure on Resolving Field \"", key', "\": ", message'] + +-- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields." +hasNoSubfields :: MetaInfo -> GQLErrors +hasNoSubfields meta = errorMessage (position meta) text + where + text = + T.concat + ["Field \"", key meta, "\" must not have a selection since type \"", typeName meta, "\" has no subfields."] + +cannotQueryField :: MetaInfo -> GQLErrors +cannotQueryField meta = errorMessage (position meta) text + where + text = T.concat ["Cannot query field \"", key meta, "\" on type \"", typeName meta, "\"."] + +duplicateQuerySelections :: T.Text -> [EnhancedKey] -> GQLErrors +duplicateQuerySelections parentType = map keyToError + where + keyToError (EnhancedKey key' pos) = GQLError {desc = toMessage key', posIndex = [pos]} + toMessage key' = T.concat ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."] + +-- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"? +subfieldsNotSelected :: MetaInfo -> GQLErrors +subfieldsNotSelected meta = errorMessage (position meta) text + where + text = T.concat ["Field \"", key meta, "\" of type \"", typeName meta, "\" must have a selection of subfields"] diff --git a/src/Data/Morpheus/Error/Spread.hs b/src/Data/Morpheus/Error/Spread.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Spread.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Spread + ( unknownFragment + , cannotBeSpreadOnType + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Error (GQLErrors) +import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position) +import Data.Text (Text) +import qualified Data.Text as T + +-- {...H} -> "Unknown fragment \"H\"." +unknownFragment :: Text -> Position -> GQLErrors +unknownFragment key' position' = errorMessage position' text + where + text = T.concat ["Unknown Fragment \"", key', "\"."] + +-- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"." +cannotBeSpreadOnType :: MetaInfo -> T.Text -> GQLErrors +cannotBeSpreadOnType spread selectionType = errorMessage (position spread) text + where + text = + T.concat + [ "Fragment \"" + , key spread + , "\" cannot be spread here as objects of type \"" + , typeName spread + , "\" can never be of type \"" + , selectionType + , "\"." + ] diff --git a/src/Data/Morpheus/Error/Syntax.hs b/src/Data/Morpheus/Error/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Syntax.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Syntax + ( syntaxError + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Error (GQLErrors) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Text (Text) +import qualified Data.Text as T (concat) + + +syntaxError :: Text -> Position -> GQLErrors +syntaxError e pos = errorMessage pos $ T.concat ["Syntax Error: ", e] diff --git a/src/Data/Morpheus/Error/Utils.hs b/src/Data/Morpheus/Error/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Error/Utils.hs @@ -0,0 +1,30 @@ +module Data.Morpheus.Error.Utils + ( errorMessage + , renderErrors + ) where + +import Data.Morpheus.Types.Error (ErrorLocation (..), GQLError (..), GQLErrors, JSONError (..)) +import Data.Morpheus.Types.MetaInfo (LineBreaks, Position) +import Data.Text (Text) + +errorMessage :: Position -> Text -> GQLErrors +errorMessage pos text = [GQLError {desc = text, posIndex = [pos]}] + +renderErrors :: LineBreaks -> [GQLError] -> [JSONError] +renderErrors x = map (renderError x) + +renderError :: LineBreaks -> GQLError -> JSONError +renderError lineBreaks internError = + JSONError {message = desc internError, locations = map (errorLocation lineBreaks) $ posIndex internError} + +lineIndexAndNumber :: Position -> LineBreaks -> (Int, Int) +lineIndexAndNumber position lineBreaks = (length linesBefore + 1, linePos linesBefore) + where + linesBefore = filter (position >=) lineBreaks + linePos [] = 1 + linePos _ = maximum linesBefore + 1 + +errorLocation :: LineBreaks -> Position -> ErrorLocation +errorLocation lineBreaks pos = do + let (lineBreaks', position) = lineIndexAndNumber pos lineBreaks + ErrorLocation lineBreaks' (pos - position) 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,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Error.Variable + ( undefinedVariable + , unknownType + , variableGotInvalidValue + , uninitializedVariable + , unusedVariables + ) where + +import Data.Morpheus.Error.Utils (errorMessage) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (GQLError (..), GQLErrors) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Text (Text) +import qualified Data.Text as T (concat) + -- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".", + +{-| +VARIABLES: + +Variable -> Error (position Query Head) + data E = EN | DE + query M ( $v : E ){...} + + +query Q ($a: D) -> "Unknown type \"D\"." + +case String + - { "v" : "EN" } -> no error converts as enum + +case type mismatch + - { "v": { "a": "v1" ... } } -> "Variable \"$v\" got invalid value { "a": "v1" ... } ; Expected type LANGUAGE." + - { "v" : "v1" } -> "Variable \"$v\" got invalid value \"v1\"; Expected type LANGUAGE." + - { "v": 1 } "Variable \"$v\" got invalid value 1; Expected type LANGUAGE." + +TODO: variable does not match to argument type + - query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"." +|-} +unusedVariables :: [EnhancedKey] -> GQLErrors +unusedVariables = map keyToError + where + keyToError (EnhancedKey key' position') = GQLError {desc = text key', posIndex = [position']} + text key' = T.concat ["Variable \"$", key', "\" is never used in operation \"Query\"."] + +variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors +variableGotInvalidValue name' inputMessage' position' = errorMessage position' text + where + text = T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage'] + +unknownType :: Text -> Position -> GQLErrors +unknownType type' position' = errorMessage position' text + where + text = T.concat ["Unknown type \"", type', "\"."] + +undefinedVariable :: Text -> Position -> Text -> GQLErrors +undefinedVariable operation' position' key' = errorMessage position' text + where + text = T.concat ["Variable \"", key', "\" is not defined by operation \"", operation', "\"."] + +uninitializedVariable :: Position -> Text -> GQLErrors +uninitializedVariable position' key' = errorMessage position' text + where + text = T.concat ["Value for Variable \"$", key', "\" is not initialized in Query body."] diff --git a/src/Data/Morpheus/Generics/DeriveResolvers.hs b/src/Data/Morpheus/Generics/DeriveResolvers.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generics/DeriveResolvers.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Generics.DeriveResolvers + ( DeriveResolvers(..) + , resolveBySelection + ) where + +import Data.Maybe (fromMaybe) +import Data.Morpheus.Types.Error (ResolveIO) +import Data.Morpheus.Types.JSType (JSType (..)) +import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..)) +import Data.Morpheus.Types.Query.Selection (Selection) +import qualified Data.Text as T +import GHC.Generics + +-- type D1 = M1 D +-- type C1 = M1 C +-- type S1 = M1 S +-- M1 : Meta-information (constructor names, etc.) +-- D :Datatype : Class for dataTypes that represent dataTypes +-- C :Constructor : +-- S - Selector: Class for dataTypes that represent records +-- Rep = D1 (...) (C1 ...) (S1 (...) :+: D1 (...) (C1 ...) (S1 (...) +unwrapMonadTuple :: Monad m => (T.Text, m a) -> m (T.Text, a) +unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x) + +selectResolver :: + [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> (T.Text, Selection) -> ResolveIO (T.Text, JSType) +selectResolver x (key, gql) = unwrapMonadTuple (key, (fromMaybe (\_ -> pure JSNull) $ lookup key x) (key, gql)) + +resolveBySelection :: [(T.Text, Selection)] -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> ResolveIO JSType +resolveBySelection selection resolvers = JSObject <$> mapM (selectResolver resolvers) selection + +class DeriveResolvers f where + deriveResolvers :: Meta.MetaInfo -> f a -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] + +instance DeriveResolvers U1 where + deriveResolvers _ _ = [] + +instance (Selector s, DeriveResolvers f) => DeriveResolvers (M1 S s f) where + deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.key = T.pack $ selName m}) src + +instance (Datatype c, DeriveResolvers f) => DeriveResolvers (M1 D c f) where + deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.typeName = T.pack $ datatypeName m}) src + +instance (Constructor c, DeriveResolvers f) => DeriveResolvers (M1 C c f) where + deriveResolvers meta (M1 src) = deriveResolvers meta src + +instance (DeriveResolvers f, DeriveResolvers g) => DeriveResolvers (f :*: g) where + deriveResolvers meta (a :*: b) = deriveResolvers meta a ++ deriveResolvers meta b diff --git a/src/Data/Morpheus/Generics/GDecode.hs b/src/Data/Morpheus/Generics/GDecode.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generics/GDecode.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Generics.GDecode + ( GDecode(..) + ) where + +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.MetaInfo +import qualified Data.Text as T +import GHC.Generics + +fixProxy :: (a -> f a) -> f a +fixProxy f = f undefined + +class GDecode i f where + gDecode :: MetaInfo -> i -> Validation (f a) + +instance GDecode i U1 where + gDecode _ _ = pure U1 + +instance (Selector c, GDecode i f) => GDecode i (M1 S c f) where + gDecode meta gql = fixProxy (\x -> M1 <$> gDecode (meta {key = T.pack $ selName x}) gql) + +instance (Datatype c, GDecode i f) => GDecode i (M1 D c f) where + gDecode meta gql = fixProxy (\x -> M1 <$> gDecode (meta {typeName = T.pack $ datatypeName x}) gql) + +instance GDecode i f => GDecode i (M1 C c f) where + gDecode meta gql = M1 <$> gDecode meta gql + +instance (GDecode i f, GDecode i g) => GDecode i (f :*: g) where + gDecode meta gql = (:*:) <$> gDecode meta gql <*> gDecode meta gql diff --git a/src/Data/Morpheus/Generics/GDecodeEnum.hs b/src/Data/Morpheus/Generics/GDecodeEnum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generics/GDecodeEnum.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Generics.GDecodeEnum + ( GDecodeEnum(..) + ) where + +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import GHC.Generics + +class GDecodeEnum f where + gToEnum :: T.Text -> f a + tagName :: Proxy f -> T.Text + getTags :: Proxy f -> [T.Text] + +instance (Datatype c, GDecodeEnum f) => GDecodeEnum (M1 D c f) where + gToEnum = M1 . gToEnum + tagName _ = "" + getTags _ = getTags (Proxy :: Proxy f) + +instance (Constructor c) => GDecodeEnum (M1 C c U1) where + gToEnum _ = M1 U1 + tagName _ = T.pack $ conName (undefined :: (M1 C c U1 x)) + getTags proxy = [tagName proxy] + +instance (GDecodeEnum a, GDecodeEnum b) => GDecodeEnum (a :+: b) where + gToEnum name = + if tagName (Proxy @a) == name + then L1 $ gToEnum name + else R1 $ gToEnum name + tagName _ = "" + getTags _ = getTags (Proxy @a) ++ getTags (Proxy @b) diff --git a/src/Data/Morpheus/Generics/TypeRep.hs b/src/Data/Morpheus/Generics/TypeRep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generics/TypeRep.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Generics.TypeRep + ( Selectors(..) + , resolveTypes + ) where + +import Data.Morpheus.Schema.Internal.Types (TypeLib) +import Data.Proxy (Proxy (..)) +import GHC.Generics + +shift :: a -> (a -> b) -> b +shift x y = y x + +resolveTypes :: TypeLib -> [TypeLib -> TypeLib] -> TypeLib +resolveTypes = foldl shift + +class Selectors rep t where + getFields :: Proxy rep -> [(t, TypeLib -> TypeLib)] + +instance Selectors f t => Selectors (M1 D x f) t where + getFields _ = getFields (Proxy @f) + +instance Selectors f t => Selectors (M1 C x f) t where + getFields _ = getFields (Proxy @f) + +instance (Selectors a t, Selectors b t) => Selectors (a :*: b) t where + getFields _ = getFields (Proxy @a) ++ getFields (Proxy @b) + +instance Selectors U1 t where + getFields _ = [] diff --git a/src/Data/Morpheus/Generics/Utils.hs b/src/Data/Morpheus/Generics/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Generics/Utils.hs @@ -0,0 +1,17 @@ +module Data.Morpheus.Generics.Utils + ( typeOf + , SelOf + , RecSel + ) where + +import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon) +import Data.Proxy (Proxy) +import Data.Text (Text, pack) +import GHC.Generics + +typeOf :: Typeable a => Proxy a -> Text +typeOf = pack . tyConName . typeRepTyCon . typeRep + +type SelOf s = M1 S s (Rec0 ()) () + +type RecSel s a = M1 S s (Rec0 a) diff --git a/src/Data/Morpheus/Kind.hs b/src/Data/Morpheus/Kind.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind.hs @@ -0,0 +1,19 @@ +module Data.Morpheus.Kind + ( GQLObject + , GQLKind(description) + , GQLQuery + , GQLArgs + , GQLInput + , GQLEnum + , GQLMutation + , GQLScalar(..) + ) where + +import Data.Morpheus.Kind.GQLArgs (GQLArgs) +import Data.Morpheus.Kind.GQLEnum (GQLEnum) +import Data.Morpheus.Kind.GQLInput (GQLInput) +import Data.Morpheus.Kind.GQLKind (GQLKind (description)) +import Data.Morpheus.Kind.GQLMutation (GQLMutation (..)) +import Data.Morpheus.Kind.GQLObject (GQLObject) +import Data.Morpheus.Kind.GQLQuery (GQLQuery (..)) +import Data.Morpheus.Kind.GQLScalar (GQLScalar (parseValue, serialize)) diff --git a/src/Data/Morpheus/Kind/GQLArgs.hs b/src/Data/Morpheus/Kind/GQLArgs.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLArgs.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Morpheus.Kind.GQLArgs + ( GQLArgs(..) + ) where + +import Data.Morpheus.Error.Internal (internalArgumentError) +import Data.Morpheus.Generics.GDecode (GDecode (..)) +import Data.Morpheus.Generics.TypeRep (Selectors (..)) +import Data.Morpheus.Generics.Utils (RecSel, SelOf) +import qualified Data.Morpheus.Kind.GQLInput as I (GQLInput (..)) +import Data.Morpheus.Schema.Internal.Types (InputField, TypeLib) +import Data.Morpheus.Schema.Type (DeprecationArgs) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.MetaInfo (MetaInfo (..), initialMeta) +import Data.Morpheus.Types.Query.Selection (Argument (..), Arguments) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import GHC.Generics + +instance (Selector s, I.GQLInput a) => Selectors (RecSel s a) (Text, InputField) where + getFields _ = [((name, I.asArgument (Proxy @a) name), I.introInput (Proxy @a))] + where + name = pack $ selName (undefined :: SelOf s) + +instance I.GQLInput a => GDecode Arguments (K1 i a) where + gDecode meta args = + case lookup (key meta) args of + Nothing -> internalArgumentError "Required Argument Not Found" + Just (Argument x _pos) -> K1 <$> I.decode x + +class GQLArgs p where + decode :: Arguments -> Validation p + default decode :: (Generic p, GDecode Arguments (Rep p)) => + Arguments -> Validation p + decode args = to <$> gDecode initialMeta args + introspect :: Proxy p -> [((Text, InputField), TypeLib -> TypeLib)] + default introspect :: Selectors (Rep p) (Text, InputField) => + Proxy p -> [((Text, InputField), TypeLib -> TypeLib)] + introspect _ = getFields (Proxy @(Rep p)) + +instance GQLArgs () where + decode _ = pure () + introspect _ = [] + +instance GQLArgs DeprecationArgs diff --git a/src/Data/Morpheus/Kind/GQLEnum.hs b/src/Data/Morpheus/Kind/GQLEnum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLEnum.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Morpheus.Kind.GQLEnum + ( GQLEnum(..) + ) where + +import Data.Morpheus.Generics.GDecodeEnum (GDecodeEnum (..)) +import Data.Morpheus.Kind.GQLKind (GQLKind (..), enumTypeOf) +import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation) +import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics + +class GQLEnum a where + decode :: Text -> a + default decode :: (Generic a, GDecodeEnum (Rep a)) => + Text -> a + decode text = to $ gToEnum text + asInputField :: Proxy a -> Text -> InputField + default asInputField :: GQLKind a => + Proxy a -> Text -> InputField + asInputField proxy = InputField . asField proxy + asField :: Proxy a -> Text -> Field + default asField :: GQLKind a => + Proxy a -> Text -> Field + asField proxy name = Field {fieldName = name, notNull = True, kind = ENUM, fieldType = typeID proxy, asList = False} + introspect :: Proxy a -> TypeLib -> TypeLib + default introspect :: (GQLKind a, GDecodeEnum (Rep a)) => + Proxy a -> TypeLib -> TypeLib + introspect = updateLib (enumTypeOf $ getTags (Proxy @(Rep a))) [] + +instance GQLEnum TypeKind + +instance GQLEnum DirectiveLocation diff --git a/src/Data/Morpheus/Kind/GQLInput.hs b/src/Data/Morpheus/Kind/GQLInput.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLInput.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Morpheus.Kind.GQLInput + ( GQLInput(..) + ) where + +import Data.Morpheus.Error.Internal (internalArgumentError, internalTypeMismatch) +import Data.Morpheus.Generics.GDecode (GDecode (..)) +import Data.Morpheus.Generics.TypeRep (Selectors (..)) +import qualified Data.Morpheus.Kind.GQLEnum as E (GQLEnum (..)) +import Data.Morpheus.Kind.GQLKind (GQLKind (..), inputObjectOf, introspectScalar) +import qualified Data.Morpheus.Kind.GQLScalar as S (GQLScalar (..)) +import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Describer (EnumOf (..), ScalarOf (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..)) +import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..), initialMeta) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import GHC.Generics + +instance GQLInput a => GDecode JSType (K1 i a) where + gDecode meta (JSObject object) = + case lookup (Meta.key meta) object of + Nothing -> internalArgumentError "Missing Argument" + Just value -> K1 <$> decode value + gDecode _ isType = internalTypeMismatch "InputObject" isType + +class GQLInput a where + decode :: JSType -> Validation a + default decode :: (Generic a, GDecode JSType (Rep a)) => + JSType -> Validation a + decode (JSObject x) = to <$> gDecode Meta.initialMeta (JSObject x) + decode isType = internalTypeMismatch "InputObject" isType + asArgument :: Proxy a -> Text -> InputField + default asArgument :: GQLKind a => + Proxy a -> Text -> InputField + asArgument proxy name = + InputField $ Field {fieldName = name, notNull = True, asList = False, kind = INPUT_OBJECT, fieldType = typeID proxy} + introInput :: Proxy a -> TypeLib -> TypeLib + default introInput :: (GQLKind a, Selectors (Rep a) (Text, InputField)) => + Proxy a -> TypeLib -> TypeLib + introInput = updateLib (inputObjectOf fields) stack + where + fieldTypes = getFields (Proxy @(Rep a)) + stack = map snd fieldTypes + fields = map fst fieldTypes + +inputFieldOf :: GQLKind a => Proxy a -> Text -> InputField +inputFieldOf proxy name = + InputField $ Field {fieldName = name, asList = False, notNull = True, kind = SCALAR, fieldType = typeID proxy} + +instance GQLInput Text where + decode (Scalar (String x)) = pure x + decode isType = internalTypeMismatch "String" isType + asArgument = inputFieldOf + introInput = introspectScalar + +instance GQLInput Bool where + decode (Scalar (Boolean x)) = pure x + decode isType = internalTypeMismatch "Boolean" isType + asArgument = inputFieldOf + introInput = introspectScalar + +instance GQLInput Int where + decode (Scalar (Int x)) = pure x + decode isType = internalTypeMismatch "Int" isType + asArgument = inputFieldOf + introInput = introspectScalar + +instance GQLInput Float where + decode (Scalar (Float x)) = pure x + decode isType = internalTypeMismatch "Int" isType + asArgument = inputFieldOf + introInput = introspectScalar + +instance (GQLInput a, GQLKind a) => GQLInput (Maybe a) where + decode JSNull = pure Nothing + decode x = Just <$> decode x + asArgument _ name = InputField $ setNullable $ unpackInputField $ asArgument (Proxy @a) name + where + setNullable :: Field -> Field + setNullable x = x {notNull = False} + introInput _ typeLib = typeLib + +instance (E.GQLEnum a, GQLKind a) => GQLInput (EnumOf a) where + decode (JSEnum text) = pure $ EnumOf (E.decode text) + decode isType = internalTypeMismatch "Enum" isType + asArgument _ = E.asInputField (Proxy @a) + introInput _ = E.introspect (Proxy @a) + +instance (S.GQLScalar a, GQLKind a) => GQLInput (ScalarOf a) where + decode text = ScalarOf <$> S.decode text + asArgument _ = S.asInputField (Proxy @a) + introInput _ = S.introspect (Proxy @a) + +instance (GQLInput a, GQLKind a) => GQLInput [a] where + decode (JSList li) = mapM decode li + decode isType = internalTypeMismatch "List" isType + asArgument _ = asArgument (Proxy @a) + introInput _ = introInput (Proxy @a) -- TODO: wrap as List diff --git a/src/Data/Morpheus/Kind/GQLKind.hs b/src/Data/Morpheus/Kind/GQLKind.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLKind.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Data.Morpheus.Kind.GQLKind + ( GQLKind(..) + , scalarTypeOf + , asObjectType + , enumTypeOf + , inputObjectOf + , introspectScalar + ) where + +import Data.Morpheus.Generics.TypeRep (resolveTypes) +import Data.Morpheus.Generics.Utils (typeOf) +import Data.Morpheus.Schema.Directive (Directive) +import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation) +import Data.Morpheus.Schema.EnumValue (EnumValue) +import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), InputField, Leaf (..), LibType (..), + ObjectField (..), TypeLib, defineType, isTypeDefined) +import Data.Morpheus.Schema.Schema (Schema) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Schema.Utils.Utils (Field, InputValue, Type) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Typeable (Typeable) + +scalarTypeOf :: GQLKind a => Proxy a -> LibType +scalarTypeOf = Leaf . LScalar . buildType + +enumTypeOf :: GQLKind a => [Text] -> Proxy a -> LibType +enumTypeOf tags = Leaf . LEnum tags . buildType + +asObjectType :: GQLKind a => [(Text, ObjectField)] -> Proxy a -> LibType +asObjectType fields = OutputObject . GObject fields . buildType + +inputObjectOf :: GQLKind a => [(Text, InputField)] -> Proxy a -> LibType +inputObjectOf inputFields = InputObject . GObject inputFields . buildType + +introspectScalar :: GQLKind a => Proxy a -> TypeLib -> TypeLib +introspectScalar = updateLib scalarTypeOf [] + +class GQLKind a where + description :: Proxy a -> Text + description _ = "default selection Description" + typeID :: Proxy a -> Text + default typeID :: Typeable a => + Proxy a -> Text + typeID = typeOf + buildType :: Proxy a -> Core + buildType proxy = Core {name = typeID proxy, typeDescription = description proxy} + updateLib :: (Proxy a -> LibType) -> [TypeLib -> TypeLib] -> Proxy a -> TypeLib -> TypeLib + updateLib typeBuilder stack proxy lib' = + if isTypeDefined (typeID proxy) lib' + then lib' + else resolveTypes lib' (defineType (typeID proxy, typeBuilder proxy) : stack) + +instance GQLKind EnumValue where + typeID _ = "__EnumValue" + +instance GQLKind Type where + typeID _ = "__Type" + +instance GQLKind Field where + typeID _ = "__Field" + +instance GQLKind InputValue where + typeID _ = "__InputValue" + +instance GQLKind Schema where + typeID _ = "__Schema" + +instance GQLKind Directive where + typeID _ = "__Directive" + +instance GQLKind TypeKind where + typeID _ = "__TypeKind" + +instance GQLKind DirectiveLocation where + typeID _ = "__DirectiveLocation" + +instance GQLKind Int where + typeID _ = "Int" + +instance GQLKind Float where + typeID _ = "Int" + +instance GQLKind Text where + typeID _ = "String" + +instance GQLKind Bool where + typeID _ = "Boolean" + +instance GQLKind a => GQLKind (Maybe a) where + typeID _ = typeID (Proxy @a) diff --git a/src/Data/Morpheus/Kind/GQLMutation.hs b/src/Data/Morpheus/Kind/GQLMutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLMutation.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Kind.GQLMutation + ( GQLMutation(..) + ) where + +import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection) +import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes) +import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField, TypeLib (..)) +import Data.Morpheus.Types.Error (ResolveIO) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Morpheus.Types.MetaInfo (initialMeta) +import Data.Morpheus.Types.Query.Selection (SelectionSet) +import Data.Proxy +import Data.Text (Text) +import GHC.Generics + +class GQLMutation a where + encodeMutation :: a -> SelectionSet -> ResolveIO JSType + default encodeMutation :: (Generic a, DeriveResolvers (Rep a)) => + a -> SelectionSet -> ResolveIO JSType + encodeMutation rootResolver sel = resolveBySelection sel $ deriveResolvers initialMeta $ from rootResolver + mutationSchema :: a -> TypeLib -> TypeLib + default mutationSchema :: (Selectors (Rep a) (Text, ObjectField)) => + a -> TypeLib -> TypeLib + mutationSchema _ initialType = resolveTypes mutationType types + where + mutationType = initialType {mutation = Just ("Mutation", GObject fields $ Core "Mutation" "Description")} + fieldTypes = getFields (Proxy :: Proxy (Rep a)) + types = map snd fieldTypes + fields = map fst fieldTypes + +instance GQLMutation () where + encodeMutation _ _ = pure JSNull + mutationSchema _ = id diff --git a/src/Data/Morpheus/Kind/GQLObject.hs b/src/Data/Morpheus/Kind/GQLObject.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLObject.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Kind.GQLObject + ( GQLObject(..) + ) where + +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Except +import Data.Morpheus.Error.Selection (fieldNotResolved, subfieldsNotSelected) +import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection) +import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes) +import Data.Morpheus.Generics.Utils (RecSel, SelOf) +import qualified Data.Morpheus.Kind.GQLArgs as Args (GQLArgs (..)) +import qualified Data.Morpheus.Kind.GQLEnum as E (GQLEnum (..)) +import Data.Morpheus.Kind.GQLKind (GQLKind (..), asObjectType, introspectScalar) +import qualified Data.Morpheus.Kind.GQLScalar as S (GQLScalar (..)) +import Data.Morpheus.Schema.Directive (Directive) +import Data.Morpheus.Schema.EnumValue (EnumValue) +import Data.Morpheus.Schema.Internal.Types (ObjectField (..), TypeLib) +import qualified Data.Morpheus.Schema.Internal.Types as I (Field (..)) +import Data.Morpheus.Schema.Schema (Schema) +import Data.Morpheus.Schema.Type (DeprecationArgs) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Schema.Utils.Utils (Field, InputValue, Type) +import Data.Morpheus.Types.Describer ((::->) (..), EnumOf (..), ScalarOf (..), + WithDeprecationArgs (..)) +import Data.Morpheus.Types.Error (ResolveIO, failResolveIO) +import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..)) +import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..), initialMeta) +import Data.Morpheus.Types.Query.Selection (Selection (..)) +import Data.Proxy +import Data.Text (Text, pack) +import GHC.Generics + +instance GQLObject a => DeriveResolvers (K1 i a) where + deriveResolvers meta (K1 src) = [(Meta.key meta, (`encode` src))] + +instance (Selector s, GQLObject a) => Selectors (RecSel s a) (Text, ObjectField) where + getFields _ = [((name, fieldType (Proxy @a) name), introspect (Proxy @a))] + where + name = pack $ selName (undefined :: SelOf s) + +class GQLObject a where + encode :: (Text, Selection) -> a -> ResolveIO JSType + default encode :: (Generic a, DeriveResolvers (Rep a)) => + (Text, Selection) -> a -> ResolveIO JSType + encode (_, SelectionSet _ selection _pos) = resolveBySelection selection . deriveResolvers Meta.initialMeta . from + encode (_, Field _ key pos) = const $ failResolveIO $ subfieldsNotSelected meta -- TODO: must be internal Error + where + meta = Meta.MetaInfo {Meta.typeName = "", Meta.key = key, Meta.position = pos} + fieldType :: Proxy a -> Text -> ObjectField + default fieldType :: (Selectors (Rep a) (Text, ObjectField), GQLKind a) => + Proxy a -> Text -> ObjectField + fieldType proxy name = + ObjectField [] $ + I.Field {I.fieldName = name, I.notNull = True, I.asList = False, I.kind = OBJECT, I.fieldType = typeID proxy} + introspect :: Proxy a -> TypeLib -> TypeLib + default introspect :: (Selectors (Rep a) (Text, ObjectField), GQLKind a) => + Proxy a -> TypeLib -> TypeLib + introspect = updateLib (asObjectType fields) stack + where + fieldTypes = getFields (Proxy @(Rep a)) + fields = map fst fieldTypes + stack = map snd fieldTypes + +liftResolver :: Int -> Text -> IO (Either String a) -> ResolveIO a +liftResolver position' typeName' x = do + result <- lift x + case result of + Left message' -> failResolveIO $ fieldNotResolved position' typeName' (pack message') + Right value -> pure value + +instance (GQLObject a, Args.GQLArgs p) => GQLObject (p ::-> a) where + encode (key', SelectionSet gqlArgs body position') (Resolver resolver) = + (ExceptT $ pure $ Args.decode gqlArgs) >>= liftResolver position' key' . resolver >>= + encode (key', SelectionSet gqlArgs body position') + encode (key', Field gqlArgs field position') (Resolver resolver) = + (ExceptT $ pure $ Args.decode gqlArgs) >>= liftResolver position' key' . resolver >>= + encode (key', Field gqlArgs field position') + introspect _ typeLib = resolveTypes typeLib $ args' ++ fields + where + args' = map snd $ Args.introspect (Proxy @p) + fields = [introspect (Proxy @a)] + fieldType _ name = (fieldType (Proxy @a) name) {args = map fst $ Args.introspect (Proxy @p)} + +-- manual deriving of DeprecationArgs ::-> a +instance GQLObject a => GQLObject (WithDeprecationArgs a) where + encode sel (WithDeprecationArgs val) = encode sel val + introspect _ typeLib = resolveTypes typeLib $ args' ++ fields + where + args' = map snd $ Args.introspect (Proxy @DeprecationArgs) + fields = [introspect (Proxy @a)] + fieldType _ name = (fieldType (Proxy @a) name) {args = map fst $ Args.introspect (Proxy @DeprecationArgs)} + +instance GQLObject a => GQLObject (Maybe a) where + encode _ Nothing = pure JSNull + encode query (Just value) = encode query value + introspect _ = introspect (Proxy @a) + fieldType _ name = (fType name) {fieldContent = (fieldContent $ fType name) {I.notNull = False}} + where + fType = fieldType (Proxy @a) + +scalarField :: GQLKind a => Proxy a -> Text -> ObjectField +scalarField proxy name = + ObjectField + [] + I.Field {I.fieldName = name, I.notNull = True, I.asList = False, I.kind = SCALAR, I.fieldType = typeID proxy} + +instance GQLObject Int where + encode _ = pure . Scalar . Int + introspect = introspectScalar + fieldType = scalarField + +instance GQLObject Float where + encode _ = pure . Scalar . Float + introspect = introspectScalar + fieldType = scalarField + +instance GQLObject Text where + encode _ = pure . Scalar . String + introspect = introspectScalar + fieldType = scalarField + +instance GQLObject Bool where + encode _ = pure . Scalar . Boolean + introspect = introspectScalar + fieldType = scalarField + +instance GQLObject a => GQLObject [a] where + encode (_, Field {}) _ = pure $ JSList [] + encode query list = JSList <$> mapM (encode query) list + introspect _ = introspect (Proxy @a) + fieldType _ name = fType {fieldContent = (fieldContent fType) {I.asList = True}} + where + fType = fieldType (Proxy @a) name + +instance (Show a, GQLKind a, E.GQLEnum a) => GQLObject (EnumOf a) where + encode _ = pure . Scalar . String . pack . show . unpackEnum + fieldType _ = ObjectField [] . E.asField (Proxy @a) + introspect _ = E.introspect (Proxy @a) + +instance S.GQLScalar a => GQLObject (ScalarOf a) where + encode _ (ScalarOf x) = pure $ Scalar $ S.serialize x + fieldType _ = ObjectField [] . S.asField (Proxy @a) + introspect _ = S.introspect (Proxy @a) + +instance GQLObject EnumValue + +instance GQLObject Type + +instance GQLObject Field + +instance GQLObject InputValue + +instance GQLObject Schema + +instance GQLObject Directive diff --git a/src/Data/Morpheus/Kind/GQLQuery.hs b/src/Data/Morpheus/Kind/GQLQuery.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLQuery.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Kind.GQLQuery + ( GQLQuery(..) + ) where + +import Data.Morpheus.Generics.DeriveResolvers (DeriveResolvers (..), resolveBySelection) +import Data.Morpheus.Generics.TypeRep (Selectors (..), resolveTypes) +import Data.Morpheus.Kind.GQLObject (GQLObject (..)) +import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField, TypeLib, initTypeLib) +import Data.Morpheus.Schema.Schema (Schema, initSchema) +import Data.Morpheus.Types.Error (ResolveIO) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Morpheus.Types.MetaInfo (initialMeta) +import Data.Morpheus.Types.Query.Selection (SelectionSet) +import Data.Proxy +import Data.Text (Text) +import GHC.Generics + +class GQLQuery a where + encodeQuery :: a -> TypeLib -> SelectionSet -> ResolveIO JSType + default encodeQuery :: (Generic a, DeriveResolvers (Rep a)) => + a -> TypeLib -> SelectionSet -> ResolveIO JSType + encodeQuery rootResolver types sel = resolveBySelection sel (schemaResolver ++ resolvers) + where + schemaResolver = [("__schema", (`encode` initSchema types))] + resolvers = deriveResolvers initialMeta $ from rootResolver + querySchema :: a -> TypeLib + default querySchema :: (Selectors (Rep a) (Text, ObjectField)) => + a -> TypeLib + querySchema _ = resolveTypes typeLib stack + where + typeLib = introspect (Proxy @Schema) queryType + queryType = initTypeLib ("Query", GObject fields (Core "Query" "Description")) + fieldTypes = getFields (Proxy @(Rep a)) + stack = map snd fieldTypes + fields = map fst fieldTypes diff --git a/src/Data/Morpheus/Kind/GQLScalar.hs b/src/Data/Morpheus/Kind/GQLScalar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Kind/GQLScalar.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Kind.GQLScalar where + +import Control.Monad ((>=>)) +import Data.Morpheus.Error.Internal (internalTypeMismatch) +import Data.Morpheus.Kind.GQLKind (GQLKind (..), scalarTypeOf) +import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), TypeLib) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Core (Key) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..)) +import Data.Proxy (Proxy (..)) + +toScalar :: JSType -> Validation ScalarValue +toScalar (Scalar x) = pure x +toScalar jsType = internalTypeMismatch "Scalar" jsType + +class GQLScalar a where + parseValue :: ScalarValue -> Validation a + decode :: JSType -> Validation a + decode = toScalar >=> parseValue + serialize :: a -> ScalarValue + encode :: a -> JSType + encode = Scalar . serialize + asInputField :: GQLKind a => Proxy a -> Key -> InputField + asInputField proxy = InputField . asField proxy + asField :: Proxy a -> Key -> Field + default asField :: GQLKind a => + Proxy a -> Key -> Field + asField proxy name = Field {fieldName = name, notNull = True, asList = False, kind = SCALAR, fieldType = typeID proxy} + introspect :: Proxy a -> TypeLib -> TypeLib + default introspect :: GQLKind a => + Proxy a -> TypeLib -> TypeLib + introspect = updateLib scalarTypeOf [] diff --git a/src/Data/Morpheus/Parser/Arguments.hs b/src/Data/Morpheus/Parser/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Arguments.hs @@ -0,0 +1,48 @@ +module Data.Morpheus.Parser.Arguments + ( arguments + ) where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, char, sepBy, skipSpace) +import Data.Morpheus.Parser.Primitive (getPosition, jsBool, jsNumber, jsString, token, variable) +import Data.Morpheus.Types.JSType (JSType (JSEnum)) +import Data.Morpheus.Types.Query.RawSelection (RawArgument (..), RawArguments) +import Data.Text (Text) + +enum :: Parser JSType +enum = JSEnum <$> token + +argumentType :: Parser RawArgument +argumentType = do + pos <- getPosition + arg <- jsString <|> jsNumber <|> jsBool <|> enum + pure $ Argument arg pos + +variableType :: Parser RawArgument +variableType = do + pos <- getPosition + val <- variable + pure $ VariableReference val pos + +inputValue :: Parser RawArgument +inputValue = skipSpace *> argumentType <|> variableType + +parameter :: Parser (Text, RawArgument) +parameter = do + skipSpace + key <- token + skipSpace + _ <- char ':' + skipSpace + value <- inputValue + pure (key, value) + +arguments :: Parser RawArguments +arguments = do + skipSpace + _ <- char '(' + skipSpace + parameters <- parameter `sepBy` (skipSpace *> char ',') + skipSpace + _ <- char ')' + pure parameters diff --git a/src/Data/Morpheus/Parser/Body.hs b/src/Data/Morpheus/Parser/Body.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Body.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parser.Body + ( body + , entries + ) where + +import Control.Applicative (some, (<|>)) +import Data.Attoparsec.Text (Parser, char, letter, sepBy, skipSpace, + string, try) +import Data.Morpheus.Parser.Arguments (arguments) +import Data.Morpheus.Parser.Primitive (getPosition, separator, token) +import Data.Morpheus.Types.Query.RawSelection (RawArguments, RawSelection (..), + RawSelectionSet) +import Data.Text (Text, pack) + +spread :: Parser (Text, RawSelection) +spread = do + skipSpace + index <- getPosition + _ <- string "..." + key <- some (letter <|> char '_') + return (pack key, Spread (pack key) index) + +entry :: Parser (Text, RawSelection) +entry = do + skipSpace + index <- getPosition + key <- token + args <- try arguments <|> pure [] + value <- try (body args) <|> pure (RawField args key index) + return (key, value) + +separated :: Parser a -> Parser [a] +separated x = x `sepBy` separator + +entries :: Parser RawSelectionSet +entries = do + _ <- char '{' + skipSpace + entries' <- separated $ entry <|> spread + skipSpace + _ <- char '}' + return entries' + +body :: RawArguments -> Parser RawSelection +body args = do + skipSpace + index <- getPosition + entries' <- entries + return (RawSelectionSet args entries' index) diff --git a/src/Data/Morpheus/Parser/Fragment.hs b/src/Data/Morpheus/Parser/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Fragment.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parser.Fragment + ( fragment + ) where + +import Data.Attoparsec.Text (Parser, skipSpace, string) +import Data.Morpheus.Parser.Body (entries) +import Data.Morpheus.Parser.Primitive (getPosition, token) +import Data.Morpheus.Types.Query.Fragment (Fragment (..)) +import Data.Text (Text) + +fragment :: Parser (Text, Fragment) +fragment = do + skipSpace + index <- getPosition + _ <- string "fragment" + skipSpace + name <- token + skipSpace + _ <- string "on" + skipSpace + targetName <- token + skipSpace + fragmentBody <- entries + pure (name, Fragment {key = name, target = targetName, content = fragmentBody, position = index}) diff --git a/src/Data/Morpheus/Parser/Mutation.hs b/src/Data/Morpheus/Parser/Mutation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Mutation.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parser.Mutation + ( mutation + ) where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, skipSpace, string, try) +import Data.Morpheus.Parser.Body (entries) +import Data.Morpheus.Parser.Primitive (getPosition, token) +import Data.Morpheus.Parser.RootHead (rootHeadArguments) +import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator) + +mutation :: Parser RawOperator +mutation = do + pos <- getPosition + _ <- string "mutation " + skipSpace + name <- token + variables <- try (skipSpace *> rootHeadArguments) <|> pure [] + skipSpace + sel <- entries + pure $ Mutation name variables sel pos diff --git a/src/Data/Morpheus/Parser/Parser.hs b/src/Data/Morpheus/Parser/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Parser.hs @@ -0,0 +1,45 @@ +module Data.Morpheus.Parser.Parser + ( parseGQL + , parseLineBreaks + ) where + +import Control.Applicative (many, (<|>)) +import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, skipSpace) +import Data.Map (fromList, toList) +import Data.Maybe (fromMaybe) +import Data.Morpheus.Error.Syntax (syntaxError) +import Data.Morpheus.Parser.Fragment (fragment) +import qualified Data.Morpheus.Parser.Mutation as M +import Data.Morpheus.Parser.Primitive (getLines) +import qualified Data.Morpheus.Parser.Query as Q +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Morpheus.Types.Request (GQLRequest (..)) +import Data.Morpheus.Types.Types (GQLQueryRoot (..)) +import Data.Text (Text, pack) + +request :: Parser GQLQueryRoot +request = do + queryValue <- Q.query <|> M.mutation + fragmentLib <- fromList <$> many fragment + skipSpace + endOfInput + pure GQLQueryRoot {queryBody = queryValue, fragments = fragmentLib, inputVariables = []} + +getVariables :: GQLRequest -> [(Text, JSType)] +getVariables request' = fromMaybe [] (toList <$> variables request') + +parseReq :: GQLRequest -> Either String GQLQueryRoot +parseReq requestBody = parseOnly request $ query requestBody + +parseLineBreaks :: GQLRequest -> [Int] +parseLineBreaks requestBody = + case parseOnly getLines $ query requestBody of + Right x -> x + Left _ -> [] + +parseGQL :: GQLRequest -> Validation GQLQueryRoot +parseGQL requestBody = + case parseReq requestBody of + Right root -> Right $ root {inputVariables = getVariables requestBody} + Left parseError -> Left $ syntaxError (pack $ show parseError) 0 diff --git a/src/Data/Morpheus/Parser/Primitive.hs b/src/Data/Morpheus/Parser/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Primitive.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parser.Primitive where + +import Control.Applicative +import Data.Attoparsec.Text +import Data.Functor +import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..), decodeScientific) +import qualified Data.Text as T (Text, pack) + +import qualified Data.Attoparsec.Internal.Types as AT + +replaceType :: T.Text -> T.Text +replaceType "type" = "_type" +replaceType x = x + +boolTrue :: Parser JSType +boolTrue = string "true" $> Scalar (Boolean True) + +boolFalse :: Parser JSType +boolFalse = string "false" $> Scalar (Boolean False) + +jsBool :: Parser JSType +jsBool = boolTrue <|> boolFalse + +jsNumber :: Parser JSType +jsNumber = Scalar . decodeScientific <$> scientific + +codes :: String +codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/'] + +replacements :: String +replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/'] + +escaped :: Parser Char +escaped = do + x <- notChar '\"' + if x == '\\' + then choice (zipWith escapeChar codes replacements) + else pure x + where + escapeChar code replacement = char code >> return replacement + +jsString :: Parser JSType +jsString = do + _ <- char '"' + value <- many escaped + _ <- char '"' + pure $ Scalar $ String $ T.pack value + +token :: Parser T.Text +token = replaceType . T.pack <$> some (letter <|> char '_') + +variable :: Parser T.Text +variable = skipSpace *> char '$' *> token + +separator :: Parser Char +separator = char ',' <|> char ' ' <|> char '\n' <|> char '\t' + +getPosition :: Parser Int +getPosition = AT.Parser internFunc + where + internFunc t pos more _ success = success t pos more (AT.fromPos pos) + +getNextLine :: Parser Int +getNextLine = do + _ <- many (notChar '\n') + index <- getPosition + _ <- char '\n' + pure index + +getLines :: Parser [Int] +getLines = many getNextLine diff --git a/src/Data/Morpheus/Parser/Query.hs b/src/Data/Morpheus/Parser/Query.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/Query.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parser.Query + ( query + ) where + +import Control.Applicative ((<|>)) +import Data.Attoparsec.Text (Parser, skipSpace, string, try) +import Data.Morpheus.Parser.Body (entries) +import Data.Morpheus.Parser.Primitive (getPosition, token) +import Data.Morpheus.Parser.RootHead (rootHeadArguments) +import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator, VariableDefinitions) +import Data.Text (Text) + +queryHead :: Parser (Text, VariableDefinitions) +queryHead = do + _ <- string "query " + skipSpace + queryName <- token + variables <- try (skipSpace *> rootHeadArguments) <|> pure [] + pure (queryName, variables) + +query :: Parser RawOperator +query = do + pos <- getPosition + (queryName, args) <- try (skipSpace *> queryHead) <|> pure ("", []) + skipSpace + selection <- entries + pure $ Query queryName args selection pos diff --git a/src/Data/Morpheus/Parser/RootHead.hs b/src/Data/Morpheus/Parser/RootHead.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parser/RootHead.hs @@ -0,0 +1,29 @@ +module Data.Morpheus.Parser.RootHead + ( rootHeadArguments + ) where + +import Data.Attoparsec.Text (Parser, char, sepBy, skipSpace) +import Data.Morpheus.Parser.Primitive (getPosition, token, variable) +import Data.Morpheus.Types.Query.Operator (Variable (..), VariableDefinitions) +import Data.Text (Text) + +rootHeadVariable :: Parser (Text, Variable) +rootHeadVariable = do + skipSpace + pos <- getPosition + variableName <- variable + skipSpace + _ <- char ':' + skipSpace + variableType <- token + pure (variableName, Variable variableType pos) + +rootHeadArguments :: Parser VariableDefinitions +rootHeadArguments = do + skipSpace + _ <- char '(' + skipSpace + parameters <- rootHeadVariable `sepBy` (skipSpace *> char ',') + skipSpace + _ <- char ')' + pure parameters diff --git a/src/Data/Morpheus/PreProcess/Fragment.hs b/src/Data/Morpheus/PreProcess/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Fragment.hs @@ -0,0 +1,51 @@ +module Data.Morpheus.PreProcess.Fragment + ( validateFragments + ) where + +import qualified Data.Map as M (toList) +import Data.Morpheus.Error.Fragment (cannotSpreadWithinItself) +import Data.Morpheus.PreProcess.Utils (existsObjectType) +import Data.Morpheus.Schema.Internal.Types (TypeLib) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.Query.Fragment (Fragment (..)) +import Data.Morpheus.Types.Query.RawSelection (RawSelection (..)) +import Data.Morpheus.Types.Types (GQLQueryRoot (..)) +import Data.Text (Text) + +type Node = EnhancedKey + +type NodeEdges = (Node, [Node]) + +type Graph = [NodeEdges] + +scanForSpread :: TypeLib -> GQLQueryRoot -> (Text, RawSelection) -> [Node] +scanForSpread lib' root (_', RawSelectionSet _ selectors _) = concatMap (scanForSpread lib' root) selectors +scanForSpread _ _ (_, RawField {}) = [] +scanForSpread _ _ (_, Spread value pos) = [EnhancedKey value pos] + +validateFragment :: TypeLib -> GQLQueryRoot -> (Text, Fragment) -> Validation NodeEdges +validateFragment lib' root (fName, Fragment {content = selection, target = target', position = position'}) = + existsObjectType position' target' lib' >> + pure (EnhancedKey fName position', concatMap (scanForSpread lib' root) selection) + +validateFragments :: TypeLib -> GQLQueryRoot -> Validation () +validateFragments lib root = mapM (validateFragment lib root) (M.toList $ fragments root) >>= detectLoopOnFragments + +detectLoopOnFragments :: Graph -> Validation () +detectLoopOnFragments lib = mapM_ checkFragment lib + where + checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID] + +checkForCycle :: Graph -> Node -> [Node] -> Validation Graph +checkForCycle lib parentNode history = + case lookup parentNode lib of + Just node -> concat <$> mapM checkNode node + Nothing -> pure [] + where + checkNode x = + if x `elem` history + then cycleError x + else recurse x + recurse node = checkForCycle lib node $ history ++ [node] + cycleError n = Left $ cannotSpreadWithinItself $ history ++ [n] diff --git a/src/Data/Morpheus/PreProcess/Input/Enum.hs b/src/Data/Morpheus/PreProcess/Input/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Input/Enum.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.PreProcess.Input.Enum + ( validateEnum + ) where + +import Data.List (elem) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Text (Text) + +validateEnum :: error -> [Text] -> JSType -> Either error JSType +validateEnum error' tags' (JSEnum enumValue) = + if enumValue `elem` tags' + then pure (JSEnum enumValue) + else Left error' +validateEnum error' _ _ = Left error' diff --git a/src/Data/Morpheus/PreProcess/Input/Object.hs b/src/Data/Morpheus/PreProcess/Input/Object.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Input/Object.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.PreProcess.Input.Object + ( validateInputObject + , validateInput + ) where + +import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..)) +import Data.Morpheus.PreProcess.Input.Enum (validateEnum) +import Data.Morpheus.PreProcess.Utils (lookupField, lookupType) +import Data.Morpheus.Schema.Internal.Types (Core (..), Field (..), GObject (..), InputField (..), InputObject, + InputType, Leaf (..), TypeLib (..)) +import qualified Data.Morpheus.Schema.Internal.Types as T (InternalType (..)) +import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..)) +import Data.Text (Text) + +generateError :: JSType -> Text -> [Prop] -> InputError +generateError jsType expected' path' = UnexpectedType path' expected' jsType + +existsInputObjectType :: InputError -> TypeLib -> Text -> InputValidation InputObject +existsInputObjectType error' lib' = lookupType error' (inputObject lib') + +existsLeafType :: InputError -> TypeLib -> Text -> InputValidation Leaf +existsLeafType error' lib' = lookupType error' (leaf lib') + +validateScalarTypes :: Text -> ScalarValue -> [Prop] -> InputValidation ScalarValue +validateScalarTypes "String" (String x) = pure . const (String x) +validateScalarTypes "String" scalar = Left . generateError (Scalar scalar) "String" +validateScalarTypes "Int" (Int x) = pure . const (Int x) +validateScalarTypes "Int" scalar = Left . generateError (Scalar scalar) "Int" +validateScalarTypes "Boolean" (Boolean x) = pure . const (Boolean x) +validateScalarTypes "Boolean" scalar = Left . generateError (Scalar scalar) "Boolean" +validateScalarTypes _ scalar = pure . const scalar + +validateEnumType :: Text -> [Text] -> JSType -> [Prop] -> InputValidation JSType +validateEnumType expected' tags jsType props = validateEnum (UnexpectedType props expected' jsType) tags jsType + +validateLeaf :: Leaf -> JSType -> [Prop] -> InputValidation JSType +validateLeaf (LEnum tags core) jsType props = validateEnumType (name core) tags jsType props +validateLeaf (LScalar core) (Scalar found) props = Scalar <$> validateScalarTypes (name core) found props +validateLeaf (LScalar core) jsType props = Left $ generateError jsType (name core) props + +validateInputObject :: [Prop] -> TypeLib -> GObject InputField-> (Text, JSType) -> InputValidation (Text, JSType) +validateInputObject prop' lib' (GObject parentFields _) (_name, JSObject fields) = do + fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name) + let currentProp = prop' ++ [Prop _name fieldTypeName'] + let error' = generateError (JSObject fields) fieldTypeName' currentProp + inputObject' <- existsInputObjectType error' lib' fieldTypeName' + mapM (validateInputObject currentProp lib' inputObject') fields >>= \x -> pure (_name, JSObject x) +validateInputObject prop' lib' (GObject parentFields _) (_name, jsType) = do + fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name) + let currentProp = prop' ++ [Prop _name fieldTypeName'] + let error' = generateError jsType fieldTypeName' currentProp + fieldType' <- existsLeafType error' lib' fieldTypeName' + validateLeaf fieldType' jsType currentProp >> pure (_name, jsType) + +validateInput :: TypeLib -> InputType -> (Text, JSType) -> InputValidation JSType +validateInput typeLib (T.Object oType) (_, JSObject fields) = + JSObject <$> mapM (validateInputObject [] typeLib oType) fields +validateInput _ (T.Object (GObject _ core)) (_, jsType) = Left $ generateError jsType (name core) [] +validateInput _ (T.Scalar core) (_, jsValue) = validateLeaf (LScalar core) jsValue [] +validateInput _ (T.Enum tags core) (_, jsValue) = validateLeaf (LEnum tags core) jsValue [] diff --git a/src/Data/Morpheus/PreProcess/PreProcess.hs b/src/Data/Morpheus/PreProcess/PreProcess.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/PreProcess.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.PreProcess.PreProcess + ( preProcessQuery + ) where + +import Data.Map (fromList) +import Data.Morpheus.Error.Mutation (mutationIsNotDefined) +import Data.Morpheus.PreProcess.Fragment (validateFragments) +import Data.Morpheus.PreProcess.Resolve.ResolveRawQuery (resolveRawQuery) +import Data.Morpheus.PreProcess.Validate.Validate (mapSelectorValidation) +import Data.Morpheus.PreProcess.Variable (allVariableReferences, resolveOperationVariables) +import Data.Morpheus.Schema.Internal.Types (GObject (..), ObjectField (..), OutputObject, + TypeLib (..)) +import qualified Data.Morpheus.Schema.Internal.Types as SC (Field (..)) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.Query.Operator (Operator (..), RawOperator, ValidOperator, + VariableDefinitions) +import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet) +import Data.Morpheus.Types.Query.Selection (SelectionSet) +import Data.Morpheus.Types.Types (GQLQueryRoot (..)) +import Data.Text (Text) + +updateQuery :: RawOperator -> SelectionSet -> ValidOperator +updateQuery (Query name' _ _ pos) sel = Query name' [] sel pos +updateQuery (Mutation name' _ _ pos) sel = Mutation name' [] sel pos + +fieldSchema :: [(Text, ObjectField)] +fieldSchema = + [ ( "__schema" + , ObjectField + { args = [] + , fieldContent = + SC.Field + { SC.fieldName = "__schema" + , SC.notNull = True + , SC.asList = False + , SC.kind = OBJECT + , SC.fieldType = "__Schema" + } + }) + ] + +setFieldSchema :: GObject ObjectField -> GObject ObjectField +setFieldSchema (GObject fields core) = GObject (fields ++ fieldSchema) core + +getOperator :: RawOperator -> TypeLib -> Validation (OutputObject, VariableDefinitions, RawSelectionSet) +getOperator (Query _ args' sel _) lib' = pure (snd $ query lib', args', sel) +getOperator (Mutation _ args' sel position') lib' = + case mutation lib' of + Just (_, mutation') -> pure (mutation', args', sel) + Nothing -> Left $ mutationIsNotDefined position' + +resolveValues :: TypeLib -> GQLQueryRoot -> Validation (OutputObject, SelectionSet) +resolveValues typesLib root = do + (query', args', rawSel) <- getOperator (queryBody root) typesLib + variables' <- + resolveOperationVariables typesLib (fromList $ inputVariables root) (allVariableReferences [rawSel]) args' + validateFragments typesLib root + let operator' = setFieldSchema query' + selection' <- resolveRawQuery typesLib (fragments root) variables' rawSel operator' + pure (operator', selection') + +preProcessQuery :: TypeLib -> GQLQueryRoot -> Validation ValidOperator +preProcessQuery lib' root' = do + (operatorType', selection') <- resolveValues lib' root' + selectors <- mapSelectorValidation lib' operatorType' selection' + pure $ updateQuery (queryBody root') selectors diff --git a/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs b/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Resolve/Arguments.hs @@ -0,0 +1,12 @@ +module Data.Morpheus.PreProcess.Resolve.Arguments + ( resolveArguments + ) where + +import Data.Morpheus.PreProcess.Variable (resolveArgumentValue) +import Data.Morpheus.Types.Error (Validation) +import qualified Data.Morpheus.Types.Query.RawSelection as Raw (RawArguments) +import Data.Morpheus.Types.Query.Selection (Arguments) +import Data.Morpheus.Types.Types (Variables) + +resolveArguments :: Variables -> Raw.RawArguments -> Validation Arguments +resolveArguments variables' = mapM (resolveArgumentValue variables') diff --git a/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs b/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Resolve/ResolveRawQuery.hs @@ -0,0 +1,33 @@ +module Data.Morpheus.PreProcess.Resolve.ResolveRawQuery + ( resolveRawQuery + ) where + +import Data.Morpheus.PreProcess.Resolve.Arguments (resolveArguments) +import Data.Morpheus.PreProcess.Resolve.Spread (resolveSpread) +import Data.Morpheus.PreProcess.Selection (lookupSelectionObjectFieldType) +import Data.Morpheus.Schema.Internal.Types (GObject (..), ObjectField (..), OutputObject, TypeLib (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.Query.Fragment (FragmentLib) +import Data.Morpheus.Types.Query.RawSelection (RawSelection (..), RawSelectionSet) +import Data.Morpheus.Types.Query.Selection (Selection (..), SelectionSet) +import Data.Morpheus.Types.Types (Variables) +import Data.Text (Text) + +resolveVariableAndSpread :: + TypeLib -> FragmentLib -> Variables -> GObject ObjectField -> (Text, RawSelection) -> Validation SelectionSet +resolveVariableAndSpread lib' fragments' variables' parent' (key', RawSelectionSet rawArgs rawSelectors position') = do + fieldType' <- lookupSelectionObjectFieldType position' key' lib' parent' + args' <- resolveArguments variables' rawArgs + sel <- concat <$> mapM (resolveVariableAndSpread lib' fragments' variables' fieldType') rawSelectors + pure [(key', SelectionSet args' sel position')] +resolveVariableAndSpread _ _ variables' _ (sKey, RawField rawArgs field sPos) = do + args' <- resolveArguments variables' rawArgs + pure [(sKey, Field args' field sPos)] +resolveVariableAndSpread lib' fragments' variables' parent' (spreadID, Spread _ sPos) = + concat <$> (resolveSpread fragments' parent' sPos spreadID >>= recursiveResolve) + where + recursiveResolve = mapM (resolveVariableAndSpread lib' fragments' variables' parent') + +resolveRawQuery :: TypeLib -> FragmentLib -> Variables -> RawSelectionSet -> OutputObject -> Validation SelectionSet +resolveRawQuery lib' fragments' variables' sel query' = + concat <$> mapM (resolveVariableAndSpread lib' fragments' variables' query') sel diff --git a/src/Data/Morpheus/PreProcess/Resolve/Spread.hs b/src/Data/Morpheus/PreProcess/Resolve/Spread.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Resolve/Spread.hs @@ -0,0 +1,36 @@ +module Data.Morpheus.PreProcess.Resolve.Spread + ( getFragment + , castFragmentType + , resolveSpread + ) where + +import qualified Data.Map as M (lookup) +import Data.Morpheus.Error.Spread (cannotBeSpreadOnType, unknownFragment) +import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position) +import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..)) +import Data.Morpheus.Types.Query.Fragment (Fragment (..), FragmentLib) +import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet) +import Data.Text (Text) + +getFragment :: Position -> Text -> FragmentLib -> Validation Fragment +getFragment position' id' lib = + case M.lookup id' lib of + Nothing -> Left $ unknownFragment id' position' + Just fragment -> pure fragment + +castFragmentType :: MetaInfo -> GObject ObjectField -> Fragment -> Validation Fragment +castFragmentType spreadMeta (GObject _ core) fragment = + if name core == target fragment + then pure fragment + else Left $ cannotBeSpreadOnType (spreadMeta {typeName = target fragment}) (name core) + +resolveSpread :: FragmentLib -> GObject ObjectField -> Position -> Text -> Validation RawSelectionSet +resolveSpread fragments' parentType' position' id' = content <$> (getFragment position' id' fragments' >>= cast) + where + cast fragment' = + castFragmentType + (MetaInfo {Meta.position = position', Meta.key = id', Meta.typeName = target fragment'}) + parentType' + fragment' diff --git a/src/Data/Morpheus/PreProcess/Selection.hs b/src/Data/Morpheus/PreProcess/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Selection.hs @@ -0,0 +1,51 @@ +module Data.Morpheus.PreProcess.Selection + ( lookupFieldAsSelectionSet + , lookupSelectionObjectFieldType + , mustBeObject + , notObject + , lookupSelectionField + ) where + +import Data.Morpheus.Error.Selection (cannotQueryField, hasNoSubfields, subfieldsNotSelected) +import Data.Morpheus.PreProcess.Utils (lookupField, lookupType) +import Data.Morpheus.Schema.Internal.Types (Core (..), Field (..), GObject (..), ObjectField (..), + OutputObject, TypeLib (..)) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.MetaInfo (MetaInfo (..), Position) +import Data.Text (Text) + +isObjectKind :: ObjectField -> Bool +isObjectKind (ObjectField _ field') = OBJECT == kind field' + +mustBeObject :: (Text, Position) -> ObjectField -> Validation ObjectField +mustBeObject (key', position') field' = + if isObjectKind field' + then pure field' + else Left $ hasNoSubfields meta + where + meta = MetaInfo {position = position', key = key', typeName = fieldType $ fieldContent field'} + +notObject :: (Text, Position) -> ObjectField -> Validation ObjectField +notObject (key', position') field' = + if isObjectKind field' + then Left $ subfieldsNotSelected meta + else pure field' + where + meta = MetaInfo {position = position', key = key', typeName = fieldType $ fieldContent field'} + +lookupFieldAsSelectionSet :: Position -> Text -> TypeLib -> ObjectField -> Validation OutputObject +lookupFieldAsSelectionSet position' key' lib' field' = lookupType error' (object lib') type' + where + error' = hasNoSubfields $ MetaInfo {position = position', key = key', typeName = type'} + type' = fieldType $ fieldContent field' + +lookupSelectionField :: Position -> Text -> GObject ObjectField -> Validation ObjectField +lookupSelectionField position' key' (GObject fields' core') = lookupField key' fields' error' + where + error' = cannotQueryField $ MetaInfo {position = position', key = key', typeName = name core'} + +lookupSelectionObjectFieldType :: Position -> Text -> TypeLib -> GObject ObjectField -> Validation OutputObject +lookupSelectionObjectFieldType position' key' lib' object' = + lookupSelectionField position' key' object' >>= mustBeObject (key', position') >>= + lookupFieldAsSelectionSet position' key' lib' diff --git a/src/Data/Morpheus/PreProcess/Utils.hs b/src/Data/Morpheus/PreProcess/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Utils.hs @@ -0,0 +1,69 @@ +module Data.Morpheus.PreProcess.Utils + ( differKeys + , existsObjectType + , lookupType + , getInputType + , lookupField + , checkNameCollision + , checkForUnknownKeys + ) where + +import Data.List ((\\)) +import Data.Morpheus.Error.Variable (unknownType) +import Data.Morpheus.Schema.Internal.Types (InputType, InternalType (..), Leaf (..), OutputObject, + TypeLib (..)) +import Data.Morpheus.Types.Core (EnhancedKey (..), Key, enhanceKeyWithNull) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.MetaInfo (Position) +import qualified Data.Set as S +import Data.Text (Text) + +type GenError error a = error -> Either error a + +lookupType :: error -> [(Text, a)] -> Text -> Either error a +lookupType error' lib' typeName' = + case lookup typeName' lib' of + Nothing -> Left error' + Just x -> pure x + +lookupField :: Text -> [(Text, fType)] -> GenError error fType +lookupField id' lib' error' = + case lookup id' lib' of + Nothing -> Left error' + Just field -> pure field + +getInputType :: Text -> TypeLib -> GenError error InputType +getInputType typeName' lib error' = + case lookup typeName' (inputObject lib) of + Just x -> pure (Object x) + Nothing -> + case lookup typeName' (leaf lib) of + Nothing -> Left error' + Just (LScalar x) -> pure (Scalar x) + Just (LEnum x y) -> pure (Enum x y) + +existsObjectType :: Position -> Text -> TypeLib -> Validation OutputObject +existsObjectType position' typeName' lib = lookupType error' (object lib) typeName' + where + error' = unknownType typeName' position' + +differKeys :: [EnhancedKey] -> [Key] -> [EnhancedKey] +differKeys enhanced keys = enhanced \\ map enhanceKeyWithNull keys + +removeDuplicates :: Ord a => [a] -> [a] +removeDuplicates = S.toList . S.fromList + +elementOfKeys :: [Text] -> EnhancedKey -> Bool +elementOfKeys keys' EnhancedKey {uid = id'} = id' `elem` keys' + +checkNameCollision :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey] +checkNameCollision enhancedKeys' keys' errorGenerator' = + case differKeys enhancedKeys' (removeDuplicates keys') of + [] -> pure enhancedKeys' + duplicates' -> Left $ errorGenerator' duplicates' + +checkForUnknownKeys :: [EnhancedKey] -> [Text] -> ([EnhancedKey] -> error) -> Either error [EnhancedKey] +checkForUnknownKeys enhancedKeys' keys' errorGenerator' = + case filter (not . elementOfKeys keys') enhancedKeys' of + [] -> pure enhancedKeys' + unknownKeys' -> Left $ errorGenerator' unknownKeys' diff --git a/src/Data/Morpheus/PreProcess/Validate/Arguments.hs b/src/Data/Morpheus/PreProcess/Validate/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Validate/Arguments.hs @@ -0,0 +1,50 @@ +module Data.Morpheus.PreProcess.Validate.Arguments + ( validateArguments + ) where + +import Data.Morpheus.Error.Arguments (argumentGotInvalidValue, argumentNameCollision, + undefinedArgument, unknownArguments) +import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage) +import Data.Morpheus.Error.Internal (internalUnknownTypeMessage) +import Data.Morpheus.PreProcess.Input.Object (validateInput) +import Data.Morpheus.PreProcess.Utils (checkForUnknownKeys, checkNameCollision, getInputType) +import Data.Morpheus.Schema.Internal.Types (Field (..), InputField (..), ObjectField (..), TypeLib) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.JSType (JSType (JSNull)) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Morpheus.Types.Query.Selection (Argument (..), Arguments) +import Data.Text (Text) + +handleInputError :: Text -> Int -> InputValidation a -> Validation () +handleInputError key' position' (Left error') = Left $ argumentGotInvalidValue key' (inputErrorMessage error') position' +handleInputError _ _ _ = pure () + +validateArgumentValue :: TypeLib -> Text -> (Text, Argument) -> Validation (Text, Argument) +validateArgumentValue lib' typeID' (key', Argument value' position') = + getInputType typeID' lib' (internalUnknownTypeMessage typeID') >>= checkType >> pure (key', Argument value' position') + where + checkType type' = handleInputError key' position' (validateInput lib' type' (key', value')) + +validateArgument :: TypeLib -> Position -> Arguments -> (Text, InputField) -> Validation (Text, Argument) +validateArgument types position' requestArgs (key', InputField arg) = + case lookup key' requestArgs of + Nothing -> + if notNull arg + then Left $ undefinedArgument (EnhancedKey key' position') + else pure (key', Argument JSNull position') + Just (Argument value pos) -> validateArgumentValue types (fieldType arg) (key', Argument value pos) + +checkForUnknownArguments :: (Text, ObjectField) -> Arguments -> Validation [(Text, InputField)] +checkForUnknownArguments (fieldKey', ObjectField fieldArgs _) args' = + checkForUnknownKeys enhancedKeys' fieldKeys error' >> checkNameCollision enhancedKeys' fieldKeys argumentNameCollision >> + pure fieldArgs + where + error' = unknownArguments fieldKey' + enhancedKeys' = map argToKey args' + argToKey (key', Argument _ pos) = EnhancedKey key' pos + fieldKeys = map fst fieldArgs + +validateArguments :: TypeLib -> (Text, ObjectField) -> Position -> Arguments -> Validation Arguments +validateArguments typeLib inputs pos args' = + checkForUnknownArguments inputs args' >>= mapM (validateArgument typeLib pos args') diff --git a/src/Data/Morpheus/PreProcess/Validate/Validate.hs b/src/Data/Morpheus/PreProcess/Validate/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Validate/Validate.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.PreProcess.Validate.Validate + ( mapSelectorValidation + ) where + +import Data.Morpheus.Error.Selection (duplicateQuerySelections) +import Data.Morpheus.PreProcess.Selection (lookupFieldAsSelectionSet, lookupSelectionField, + mustBeObject, notObject) +import Data.Morpheus.PreProcess.Utils (checkNameCollision) +import Data.Morpheus.PreProcess.Validate.Arguments (validateArguments) +import Data.Morpheus.Schema.Internal.Types (Core (..), GObject (..), ObjectField (..), TypeLib (..)) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.Query.Selection (Selection (..), SelectionSet) +import Data.Text (Text) + +selToKey :: (Text, Selection) -> EnhancedKey +selToKey (sName, Field _ _ pos) = EnhancedKey sName pos +selToKey (sName, SelectionSet _ _ pos) = EnhancedKey sName pos + +checkDuplicatesOn :: GObject ObjectField -> SelectionSet -> Validation SelectionSet +checkDuplicatesOn (GObject _ core) keys = checkNameCollision enhancedKeys (map fst keys) error' >> pure keys + where + error' = duplicateQuerySelections (name core) + enhancedKeys = map selToKey keys + +validateBySchema :: TypeLib -> GObject ObjectField -> (Text, Selection) -> Validation (Text, Selection) +validateBySchema lib' parent' (key', SelectionSet args' selectors position') = do + field' <- lookupSelectionField position' key' parent' >>= mustBeObject (key', position') + fieldType' <- lookupFieldAsSelectionSet position' key' lib' field' + arguments' <- validateArguments lib' (key', field') position' args' + selectorsQS <- mapSelectorValidation lib' fieldType' selectors + pure (key', SelectionSet arguments' selectorsQS position') +validateBySchema lib' parent' (key', Field args' field position') = do + field' <- lookupSelectionField position' key' parent' >>= notObject (key', position') + arguments' <- validateArguments lib' (key', field') position' args' + pure (key', Field arguments' field position') + +mapSelectorValidation :: TypeLib -> GObject ObjectField -> SelectionSet -> Validation SelectionSet +mapSelectorValidation typeLib type' selectors = + checkDuplicatesOn type' selectors >>= mapM (validateBySchema typeLib type') diff --git a/src/Data/Morpheus/PreProcess/Variable.hs b/src/Data/Morpheus/PreProcess/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/PreProcess/Variable.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.PreProcess.Variable + ( resolveOperationVariables + , resolveArgumentValue + , allVariableReferences + ) where + +import Data.List ((\\)) +import qualified Data.Map as M (fromList, lookup) +import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage) +import Data.Morpheus.Error.Variable (undefinedVariable, uninitializedVariable, unknownType, + unusedVariables, variableGotInvalidValue) +import Data.Morpheus.PreProcess.Input.Object (validateInput) +import Data.Morpheus.PreProcess.Utils (getInputType) +import Data.Morpheus.Schema.Internal.Types (InputType, TypeLib) +import Data.Morpheus.Types.Core (EnhancedKey (..)) +import Data.Morpheus.Types.Error (Validation) +import Data.Morpheus.Types.JSType (JSType (..)) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Morpheus.Types.Query.Operator (Variable (..)) +import Data.Morpheus.Types.Query.RawSelection (RawArgument (..), RawSelection (..), RawSelectionSet) +import qualified Data.Morpheus.Types.Query.Selection as Valid (Argument (..)) +import Data.Morpheus.Types.Types (Variables) +import Data.Text (Text) + +getVariableType :: Text -> Position -> TypeLib -> Validation InputType +getVariableType type' position' lib' = getInputType type' lib' error' + where + error' = unknownType type' position' + +lookupVariable :: Variables -> Text -> (Text -> error) -> Either error JSType +lookupVariable variables' key' error' = + case M.lookup key' variables' of + Nothing -> Left $ error' key' + Just value -> pure value + +getVariable :: Position -> Variables -> Text -> Validation JSType +getVariable position' variables' key' = lookupVariable variables' key' (undefinedVariable "Query" position') + +lookupBodyValue :: Position -> Variables -> Text -> Validation JSType +lookupBodyValue position' variables' key' = lookupVariable variables' key' (uninitializedVariable position') + +handleInputError :: Text -> Int -> InputValidation JSType -> Validation (Text, JSType) +handleInputError key' position' (Left error') = Left $ variableGotInvalidValue key' (inputErrorMessage error') position' +handleInputError key' _ (Right value') = pure (key', value') + +lookupAndValidateValueOnBody :: TypeLib -> Variables -> (Text, Variable) -> Validation (Text, JSType) +lookupAndValidateValueOnBody typeLib root (key', Variable type' pos) = getVariableType type' pos typeLib >>= checkType + where + checkType _type = do + variableValue <- lookupBodyValue pos root key' + handleInputError key' pos $ validateInput typeLib _type (key', variableValue) + +resolveOperationVariables :: TypeLib -> Variables -> [EnhancedKey] -> [(Text, Variable)] -> Validation Variables +resolveOperationVariables typeLib root references' variables' = do + checkUnusedVariable references' variables' + M.fromList <$> mapM (lookupAndValidateValueOnBody typeLib root) variables' + +varToKey :: (Text, Variable) -> EnhancedKey +varToKey (key', Variable _ position') = EnhancedKey key' position' + +checkUnusedVariable :: [EnhancedKey] -> [(Text, Variable)] -> Validation () +checkUnusedVariable references' variables' = + case map varToKey variables' \\ references' of + [] -> pure () + unused' -> Left $ unusedVariables unused' + +allVariableReferences :: [RawSelectionSet] -> [EnhancedKey] +allVariableReferences = concatMap (concatMap searchReferencesIn) + +referencesFromArgument :: (Text, RawArgument) -> [EnhancedKey] +referencesFromArgument (_, Argument _ _) = [] +referencesFromArgument (_, VariableReference value' position') = [EnhancedKey value' position'] + +searchReferencesIn :: (Text, RawSelection) -> [EnhancedKey] +searchReferencesIn (_, RawSelectionSet rawArgs rawSelectors _) = + concatMap referencesFromArgument rawArgs ++ concatMap searchReferencesIn rawSelectors +searchReferencesIn (_, RawField rawArgs _ _) = concatMap referencesFromArgument rawArgs +searchReferencesIn (_, Spread _ _) = [] + +resolveArgumentValue :: Variables -> (Text, RawArgument) -> Validation (Text, Valid.Argument) +resolveArgumentValue root (key', VariableReference variableID pos) = do + value <- getVariable pos root variableID + pure (key', Valid.Argument value pos) +resolveArgumentValue _ (key', Argument value pos) = pure (key', Valid.Argument value pos) diff --git a/src/Data/Morpheus/Schema/Directive.hs b/src/Data/Morpheus/Schema/Directive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Directive.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Schema.Directive + ( Directive(..) + ) where + +import Data.Data (Data) +import Data.Morpheus.Schema.DirectiveLocation (DirectiveLocation) +import Data.Morpheus.Schema.Utils.Utils (InputValue) +import Data.Morpheus.Types.Describer (EnumOf (..)) +import Data.Text (Text) +import GHC.Generics + +data Directive = Directive + { name :: Text + , description :: Maybe Text + , locations :: [EnumOf DirectiveLocation] + , args :: [InputValue] + } deriving (Show, Data, Generic) diff --git a/src/Data/Morpheus/Schema/DirectiveLocation.hs b/src/Data/Morpheus/Schema/DirectiveLocation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/DirectiveLocation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Schema.DirectiveLocation + ( DirectiveLocation(..) + ) where + +import Data.Data (Data) +import GHC.Generics + +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, Data, Generic) diff --git a/src/Data/Morpheus/Schema/EnumValue.hs b/src/Data/Morpheus/Schema/EnumValue.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/EnumValue.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Schema.EnumValue + ( EnumValue(..) + , createEnumValue + , isEnumOf + ) where + +import Data.Data (Data) +import Data.Text (Text) +import GHC.Generics + +data EnumValue = EnumValue + { name :: Text + , description :: Maybe Text + , isDeprecated :: Bool + , deprecationReason :: Maybe Text + } deriving (Show, Data, Generic) + +createEnumValue :: Text -> EnumValue +createEnumValue enumName = + EnumValue {name = enumName, description = Nothing, isDeprecated = False, deprecationReason = Nothing} + +isEnumValue :: Text -> EnumValue -> Bool +isEnumValue inpName enum = inpName == name enum + +isEnumOf :: Text -> [EnumValue] -> Bool +isEnumOf enumName enumValues = + case filter (isEnumValue enumName) enumValues of + [] -> False + _ -> True diff --git a/src/Data/Morpheus/Schema/Field.hs b/src/Data/Morpheus/Schema/Field.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Field.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Schema.Field where + +import Data.Data (Data) +import Data.Morpheus.Schema.InputValue (InputValue) +import Data.Text (Text) +import GHC.Generics + +data Field t = Field + { name :: Text + , description :: Maybe Text + , args :: [InputValue t] + , _type :: t + , isDeprecated :: Bool + , deprecationReason :: Maybe Text + } deriving (Show, Data, Generic) + +createFieldWith :: Text -> a -> [InputValue a] -> Field a +createFieldWith _name fieldType fieldArgs = + Field + { name = _name + , description = Nothing + , args = fieldArgs + , _type = fieldType + , isDeprecated = False + , deprecationReason = Nothing + } diff --git a/src/Data/Morpheus/Schema/InputValue.hs b/src/Data/Morpheus/Schema/InputValue.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/InputValue.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Schema.InputValue + ( InputValue(..) + , createInputValueWith + ) where + +import Data.Data (Data) +import Data.Text (Text) +import GHC.Generics + +data InputValue t = InputValue + { name :: Text + , description :: Maybe Text + , _type :: t + , defaultValue :: Maybe Text + } deriving (Show, Data, Generic) + +createInputValueWith :: Text -> a -> InputValue a +createInputValueWith _name ofType = + InputValue {name = _name, description = Nothing, _type = ofType, defaultValue = Nothing} diff --git a/src/Data/Morpheus/Schema/Internal/Types.hs b/src/Data/Morpheus/Schema/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Internal/Types.hs @@ -0,0 +1,100 @@ +module Data.Morpheus.Schema.Internal.Types + ( OutputType + , InternalType(..) + , Core(..) + , Field(..) + , ObjectField(..) + , InputType + , InputField(..) + , TypeLib(..) + , GObject(..) + , Leaf(..) + , InputObject + , OutputObject + , isTypeDefined + , initTypeLib + , defineType + , LibType(..) + ) where + +import Data.Morpheus.Schema.TypeKind (TypeKind) +import Data.Text (Text) + +type EnumValue = Text + +newtype InputField = InputField + { unpackInputField :: Field + } + +data Core = Core + { name :: Text + , typeDescription :: Text + } + +data Field = Field + { fieldName :: Text + , notNull :: Bool + , kind :: TypeKind + , fieldType :: Text + , asList :: Bool + } + +data ObjectField = ObjectField + { args :: [(Text, InputField)] + , fieldContent :: Field + } + +data GObject a = + GObject [(Text, a)] + Core + +data InternalType a + = Scalar Core + | Enum [EnumValue] + Core + | Object (GObject a) + +type OutputType = InternalType ObjectField + +type InputType = InternalType InputField + +type InputObject = GObject InputField + +type OutputObject = GObject ObjectField + +data Leaf + = LScalar Core + | LEnum [EnumValue] + Core + +data TypeLib = TypeLib + { leaf :: [(Text, Leaf)] + , inputObject :: [(Text, InputObject)] + , object :: [(Text, OutputObject)] + , query :: (Text, OutputObject) + , mutation :: Maybe (Text, OutputObject) + } + +initTypeLib :: (Text, OutputObject) -> TypeLib +initTypeLib query' = TypeLib {leaf = [], inputObject = [], query = query', object = [], mutation = Nothing} + +data LibType + = Leaf Leaf + | InputObject InputObject + | OutputObject OutputObject + +mutationName :: Maybe (Text, OutputObject) -> [Text] +mutationName (Just (key', _)) = [key'] +mutationName Nothing = [] + +getAllTypeKeys :: TypeLib -> [Text] +getAllTypeKeys (TypeLib leaf' inputObject' object' (queryName, _) mutation') = + [queryName] ++ map fst leaf' ++ map fst inputObject' ++ map fst object' ++ mutationName mutation' + +isTypeDefined :: Text -> TypeLib -> Bool +isTypeDefined name' lib' = name' `elem` getAllTypeKeys lib' + +defineType :: (Text, LibType) -> TypeLib -> TypeLib +defineType (key', Leaf type') lib = lib {leaf = (key', type') : leaf lib} +defineType (key', InputObject type') lib = lib {inputObject = (key', type') : inputObject lib} +defineType (key', OutputObject type') lib = lib {object = (key', type') : object lib} diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Schema.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Schema.Schema where + +import Data.Data (Data) +import Data.Morpheus.Schema.Directive (Directive) +import Data.Morpheus.Schema.Internal.Types (OutputObject, TypeLib (..)) +import Data.Morpheus.Schema.Utils.Utils (Type, createObjectType, typeFromInputObject, typeFromLeaf, + typeFromObject) +import Data.Text (Text) +import GHC.Generics (Generic) + +data Schema = Schema + { types :: [Type] + , queryType :: Type + , mutationType :: Maybe Type + , subscriptionType :: Maybe Type + , directives :: [Directive] + } deriving (Show, Data, Generic) + +convertTypes :: TypeLib -> [Type] +convertTypes lib' = + [typeFromObject $ query lib'] ++ + typeFromMutation (mutation lib') ++ + map typeFromObject (object lib') ++ map typeFromInputObject (inputObject lib') ++ map typeFromLeaf (leaf lib') + +typeFromMutation :: Maybe (Text, OutputObject) -> [Type] +typeFromMutation (Just x) = [typeFromObject x] +typeFromMutation Nothing = [] + +buildSchemaLinkType :: (Text, OutputObject) -> Type +buildSchemaLinkType (key', _) = createObjectType key' "Query Description" [] + +initSchema :: TypeLib -> Schema +initSchema types' = + Schema + { types = convertTypes types' + , queryType = buildSchemaLinkType $ query types' + , mutationType = buildSchemaLinkType <$> mutation types' + , subscriptionType = Nothing + , directives = [] + } diff --git a/src/Data/Morpheus/Schema/Type.hs b/src/Data/Morpheus/Schema/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Type.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Schema.Type + ( Type(..) + , DeprecationArgs(..) + ) where + +import Data.Data (Data) +import Data.Morpheus.Schema.EnumValue (EnumValue) +import qualified Data.Morpheus.Schema.Field as F (Field (..)) +import qualified Data.Morpheus.Schema.InputValue as I (InputValue (..)) +import Data.Morpheus.Schema.TypeKind (TypeKind) +import Data.Morpheus.Types.Describer (EnumOf, WithDeprecationArgs (..)) +import Data.Text (Text) +import GHC.Generics (Generic) + +data Type = Type + { kind :: EnumOf TypeKind + , name :: Maybe Text + , description :: Maybe Text + , fields :: Maybe (WithDeprecationArgs [F.Field Type]) + , ofType :: Maybe Type + , interfaces :: Maybe [Type] + , possibleTypes :: Maybe [Type] + , enumValues :: Maybe (WithDeprecationArgs [EnumValue]) + , inputFields :: Maybe [I.InputValue Type] + } deriving (Show, Data, Generic) + +newtype DeprecationArgs = DeprecationArgs + { includeDeprecated :: Maybe Bool + } deriving (Show, Data, Generic) 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,20 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Schema.TypeKind + ( TypeKind(..) + ) where + +import Data.Data (Data) +import GHC.Generics + +data TypeKind + = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving (Show, Eq, Data, Generic) diff --git a/src/Data/Morpheus/Schema/Utils/Utils.hs b/src/Data/Morpheus/Schema/Utils/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Schema/Utils/Utils.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Schema.Utils.Utils + ( Type + , Field + , InputValue + , createObjectType + , typeFromObject + , typeFromInputObject + , typeFromLeaf + ) where + +import Data.Morpheus.Schema.EnumValue (EnumValue, createEnumValue) +import qualified Data.Morpheus.Schema.Field as F (Field (..), createFieldWith) +import qualified Data.Morpheus.Schema.InputValue as IN (InputValue (..), createInputValueWith) +import qualified Data.Morpheus.Schema.Internal.Types as I (Core (..), Field (..), GObject (..), InputField (..), + InputObject, Leaf (..), ObjectField (..), OutputObject) +import Data.Morpheus.Schema.Type (Type (..)) +import Data.Morpheus.Schema.TypeKind (TypeKind (..)) +import Data.Morpheus.Types.Describer (EnumOf (..), WithDeprecationArgs (..)) +import Data.Text (Text) + +type InputValue = IN.InputValue Type + +type Field = F.Field Type + +inputValueFromArg :: (Text, I.InputField) -> InputValue +inputValueFromArg (key', input') = IN.createInputValueWith key' (createInputObjectType input') + +createInputObjectType :: I.InputField -> Type +createInputObjectType (I.InputField field') = createType (I.kind field') (I.fieldType field') "" [] + +wrapNotNull :: I.ObjectField -> Type -> Type +wrapNotNull field' type' = + if I.notNull $ I.fieldContent field' + then wrapAs NON_NULL type' + else type' + +wrapList :: I.ObjectField -> Type -> Type +wrapList field' type' = + if I.asList $ I.fieldContent field' + then wrapAs LIST type' + else type' + +fieldFromObjectField :: (Text, I.ObjectField) -> Field +fieldFromObjectField (key', field') = + F.createFieldWith key' (wrapNotNull field' $ wrapList field' $ createObjectType getType "" []) args' + where + getType = I.fieldType $ I.fieldContent field' + args' = map inputValueFromArg $ I.args field' + +typeFromLeaf :: (Text, I.Leaf) -> Type +typeFromLeaf (key', I.LScalar (I.Core _ desc')) = createLeafType SCALAR key' desc' [] +typeFromLeaf (key', I.LEnum tags' (I.Core _ desc')) = createLeafType ENUM key' desc' (map createEnumValue tags') + +createLeafType :: TypeKind -> Text -> Text -> [EnumValue] -> Type +createLeafType kind' name' desc' enums' = + Type + { kind = EnumOf kind' + , name = Just name' + , description = Just desc' + , fields = Nothing + , ofType = Nothing + , interfaces = Nothing + , possibleTypes = Nothing + , enumValues = Just $ WithDeprecationArgs enums' + , inputFields = Nothing + } + +typeFromObject :: (Text, I.OutputObject) -> Type +typeFromObject (key', I.GObject fields' (I.Core _ description')) = + createObjectType key' description' (map fieldFromObjectField fields') + +typeFromInputObject :: (Text, I.InputObject) -> Type +typeFromInputObject (key', I.GObject fields' (I.Core _ description')) = + createInputObject key' description' (map inputValueFromArg fields') + +createObjectType :: Text -> Text -> [Field] -> Type +createObjectType = createType OBJECT + +createInputObject :: Text -> Text -> [InputValue] -> Type +createInputObject name' desc' fields' = + Type + { kind = EnumOf INPUT_OBJECT + , name = Just name' + , description = Just desc' + , fields = Just $ WithDeprecationArgs [] + , ofType = Nothing + , interfaces = Nothing + , possibleTypes = Nothing + , enumValues = Nothing + , inputFields = Just fields' + } + +createType :: TypeKind -> Text -> Text -> [Field] -> Type +createType kind' name' desc' fields' = + Type + { kind = EnumOf kind' + , name = Just name' + , description = Just desc' + , fields = Just $ WithDeprecationArgs fields' + , ofType = Nothing + , interfaces = Just [] + , possibleTypes = Just [] + , enumValues = Just $ WithDeprecationArgs [] + , inputFields = Just [] + } + +wrapAs :: TypeKind -> Type -> Type +wrapAs kind' contentType = + Type + { kind = EnumOf kind' + , name = Nothing + , description = Nothing + , fields = Nothing + , ofType = Just contentType + , interfaces = Nothing + , possibleTypes = Nothing + , enumValues = Nothing + , inputFields = Nothing + } diff --git a/src/Data/Morpheus/Types/Core.hs b/src/Data/Morpheus/Types/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Core.hs @@ -0,0 +1,24 @@ +module Data.Morpheus.Types.Core + ( Key + , Collection + , EnhancedKey(..) + , enhanceKeyWithNull + ) where + +import Data.Text (Text) + +type Key = Text + +type Collection a = [(Key, a)] + +-- Text value that includes position for debugging, where EnhancedKey "a" 1 === EnhancedKey "a" 3 +data EnhancedKey = EnhancedKey + { uid :: Text + , location :: Int + } + +instance Eq EnhancedKey where + (EnhancedKey id1 _) == (EnhancedKey id2 _) = id1 == id2 + +enhanceKeyWithNull :: Key -> EnhancedKey +enhanceKeyWithNull text = EnhancedKey {uid = text, location = 0} diff --git a/src/Data/Morpheus/Types/Describer.hs b/src/Data/Morpheus/Types/Describer.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Describer.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Types.Describer + ( (::->)(..) + , WithDeprecationArgs(..) + , EnumOf(..) + , ScalarOf(..) + ) where + +import Data.Data (Constr, Data, DataType, Fixity (Prefix), dataTypeOf, gfoldl, gunfold, mkConstr, + mkDataType, toConstr) +import GHC.Generics (Generic) + +newtype EnumOf a = EnumOf + { unpackEnum :: a + } deriving (Show, Generic, Data) + +instance Functor EnumOf where + fmap f (EnumOf x) = EnumOf (f x) + +instance Applicative EnumOf where + pure = EnumOf + (<*>) (EnumOf x) y = x <$> y + +newtype ScalarOf a = ScalarOf + { unpackScalar :: a + } deriving (Show, Generic, Data) + +newtype WithDeprecationArgs a = WithDeprecationArgs + { unpackDeprecationArgs :: a + } deriving (Show, Generic, Data) + +newtype a ::-> b = + Resolver (a -> IO (Either String b)) + deriving (Generic) + +instance Show (a ::-> b) where + show _ = "Resolver" + +instance (Data a, Data b) => Data (a ::-> b) where + gfoldl _ z (Resolver _) = z (Resolver $ const undefined) + gunfold _ z _ = z (Resolver $ const undefined) + toConstr _ = conResolved + dataTypeOf _ = tyResolver + +conResolved :: Constr +conResolved = mkConstr tyResolver "Resolved" [] Prefix + +tyResolver :: DataType +tyResolver = mkDataType "Module.Resolver" [conResolved] diff --git a/src/Data/Morpheus/Types/Error.hs b/src/Data/Morpheus/Types/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Error.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Types.Error + ( GQLError(..) + , ErrorLocation(..) + , GQLErrors + , JSONError(..) + , Validation + , ResolveIO + , failResolveIO + ) where + +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Aeson (ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) + +data GQLError = GQLError + { desc :: Text + , posIndex :: [Int] + } deriving (Show) + +type GQLErrors = [GQLError] + +data ErrorLocation = ErrorLocation + { line :: Int + , column :: Int + } deriving (Show, Generic, ToJSON) + +data JSONError = JSONError + { message :: Text + , locations :: [ErrorLocation] + } deriving (Show, Generic, ToJSON) + +type Validation a = Either GQLErrors a + +type ResolveIO = ExceptT GQLErrors IO + +failResolveIO :: GQLErrors -> ResolveIO a +failResolveIO = ExceptT . pure . Left diff --git a/src/Data/Morpheus/Types/JSType.hs b/src/Data/Morpheus/Types/JSType.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/JSType.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.JSType + ( JSType(..) + , ScalarValue(..) + , decodeScientific + ) where + +import qualified Data.Aeson as A (FromJSON (..), ToJSON (..), Value (..), pairs, (.=)) +import qualified Data.HashMap.Strict as M (toList) +import Data.Scientific (Scientific, floatingOrInteger) +import Data.Text (Text) +import qualified Data.Vector as V (toList) +import GHC.Generics (Generic) + +replaceType :: Text -> Text +replaceType "_type" = "type" +replaceType x = x + +data ScalarValue + = Int Int + | Float Float + | String Text + | Boolean Bool + deriving (Show, Generic) + +instance A.ToJSON ScalarValue where + toEncoding (Float x) = A.toEncoding x + toEncoding (Int x) = A.toEncoding x + toEncoding (Boolean x) = A.toEncoding x + toEncoding (String x) = A.toEncoding x + +data JSType + = JSObject [(Text, JSType)] + | JSList [JSType] + | JSEnum Text + | Scalar ScalarValue + | JSNull + deriving (Show, Generic) + +instance A.ToJSON JSType where + toEncoding JSNull = A.toEncoding A.Null + toEncoding (JSEnum x) = A.toEncoding x + toEncoding (JSList x) = A.toEncoding x + toEncoding (Scalar x) = A.toEncoding x + toEncoding (JSObject x) = A.pairs $ foldl1 (<>) $ map encodeField x + where + encodeField (key, value) = replaceType key A..= value + +replace :: (a, A.Value) -> (a, JSType) +replace (key, val) = (key, replaceValue val) + +decodeScientific :: Scientific -> ScalarValue +decodeScientific v = + case floatingOrInteger v of + Left float -> Float float + Right int -> Int int + +replaceValue :: A.Value -> JSType +replaceValue (A.Bool v) = Scalar $ Boolean v +replaceValue (A.Number v) = Scalar $ decodeScientific v +replaceValue (A.String v) = Scalar $ String v +replaceValue (A.Object v) = JSObject $ map replace (M.toList v) +replaceValue (A.Array li) = JSList (map replaceValue (V.toList li)) +replaceValue A.Null = JSNull + +instance A.FromJSON JSType where + parseJSON = pure . replaceValue diff --git a/src/Data/Morpheus/Types/MetaInfo.hs b/src/Data/Morpheus/Types/MetaInfo.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/MetaInfo.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.MetaInfo + ( MetaInfo(..) + , initialMeta + , Position + , LineBreaks + ) where + +import Data.Text (Text) + +initialMeta :: MetaInfo +initialMeta = MetaInfo {position = 0, typeName = "", key = ""} + +type LineBreaks = [Position] + +type Position = Int + +data MetaInfo = MetaInfo + { position :: Position + , typeName :: Text + , key :: Text + } diff --git a/src/Data/Morpheus/Types/Query/Fragment.hs b/src/Data/Morpheus/Types/Query/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Query/Fragment.hs @@ -0,0 +1,18 @@ +module Data.Morpheus.Types.Query.Fragment + ( Fragment(..) + , FragmentLib + ) where + +import Data.Map (Map) +import Data.Morpheus.Types.Core (Key) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet) + +data Fragment = Fragment + { key :: Key + , target :: Key + , position :: Position + , content :: RawSelectionSet + } deriving (Show) + +type FragmentLib = Map Key Fragment diff --git a/src/Data/Morpheus/Types/Query/Operator.hs b/src/Data/Morpheus/Types/Query/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Query/Operator.hs @@ -0,0 +1,32 @@ +module Data.Morpheus.Types.Query.Operator + ( Operator(..) + , ValidOperator + , RawOperator + , Variable(..) + , VariableDefinitions + ) where + +import Data.Morpheus.Types.Core (Collection, Key) +import Data.Morpheus.Types.MetaInfo (Position) +import Data.Morpheus.Types.Query.RawSelection (RawSelectionSet) +import Data.Morpheus.Types.Query.Selection (Arguments, SelectionSet) + +type ValidOperator = Operator Arguments SelectionSet + +data Variable = + Variable Key + Position + +type VariableDefinitions = Collection Variable + +type RawOperator = Operator VariableDefinitions RawSelectionSet + +data Operator args sel + = Query Key + args + sel + Position + | Mutation Key + args + sel + Position diff --git a/src/Data/Morpheus/Types/Query/RawSelection.hs b/src/Data/Morpheus/Types/Query/RawSelection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Query/RawSelection.hs @@ -0,0 +1,32 @@ +module Data.Morpheus.Types.Query.RawSelection + ( RawArgument(..) + , RawArguments + , RawSelectionSet + , RawSelection(..) + ) where + +import Data.Morpheus.Types.Core (Collection, Key) +import Data.Morpheus.Types.JSType (JSType) +import Data.Morpheus.Types.MetaInfo (Position) + +data RawArgument + = VariableReference Key + Position + | Argument JSType + Position + deriving (Show) + +type RawArguments = Collection RawArgument + +type RawSelectionSet = Collection RawSelection + +data RawSelection + = RawSelectionSet RawArguments + RawSelectionSet + Position + | RawField RawArguments + Key + Position + | Spread Key + Position + deriving (Show) diff --git a/src/Data/Morpheus/Types/Query/Selection.hs b/src/Data/Morpheus/Types/Query/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Query/Selection.hs @@ -0,0 +1,28 @@ +module Data.Morpheus.Types.Query.Selection + ( Argument(..) + , Arguments + , SelectionSet + , Selection(..) + ) where + +import Data.Morpheus.Types.Core (Collection, Key) +import Data.Morpheus.Types.JSType (JSType) +import Data.Morpheus.Types.MetaInfo (Position) + +data Argument = + Argument JSType + Position + deriving (Show) + +type Arguments = Collection Argument + +type SelectionSet = Collection Selection + +data Selection + = SelectionSet Arguments + SelectionSet + Position + | Field Arguments + Key + Position + deriving (Show) diff --git a/src/Data/Morpheus/Types/Request.hs b/src/Data/Morpheus/Types/Request.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Request.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Data.Morpheus.Types.Request where + +import Data.Aeson (FromJSON (..)) +import Data.Map (Map) +import Data.Morpheus.Types.Core (Key) +import Data.Morpheus.Types.JSType (JSType) +import GHC.Generics (Generic) + +data GQLRequest = GQLRequest + { query :: Key + , operationName :: Maybe Key + , variables :: Maybe (Map Key JSType) + } deriving (Show, Generic, FromJSON) diff --git a/src/Data/Morpheus/Types/Response.hs b/src/Data/Morpheus/Types/Response.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Response.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Types.Response where + +import Data.Aeson (ToJSON (..), pairs, (.=)) +import Data.Morpheus.Types.Error (JSONError (..)) +import Data.Morpheus.Types.JSType (JSType) +import GHC.Generics (Generic) + +data GQLResponse + = Data JSType + | Errors [JSONError] + deriving (Show, Generic) + +instance ToJSON GQLResponse where + toEncoding (Data _data) = pairs $ "data" .= _data + toEncoding (Errors _errors) = pairs $ "errors" .= _errors diff --git a/src/Data/Morpheus/Types/Types.hs b/src/Data/Morpheus/Types/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Types.hs @@ -0,0 +1,24 @@ +module Data.Morpheus.Types.Types + ( GQLQueryRoot(..) + , Variables + , GQLRoot(..) + ) where + +import Data.Map (Map) +import Data.Morpheus.Types.Core (Key) +import Data.Morpheus.Types.JSType (JSType) +import Data.Morpheus.Types.Query.Fragment (FragmentLib) +import Data.Morpheus.Types.Query.Operator (RawOperator) + +type Variables = Map Key JSType + +data GQLQueryRoot = GQLQueryRoot + { fragments :: FragmentLib + , queryBody :: RawOperator + , inputVariables :: [(Key, JSType)] + } + +data GQLRoot a b = GQLRoot + { query :: a + , mutation :: b + } diff --git a/src/Data/Morpheus/Wrapper.hs b/src/Data/Morpheus/Wrapper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Wrapper.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Data.Morpheus.Wrapper + ( GQLRoot(..) + , EnumOf + , ScalarOf + , (::->)(..) + , wrap + , unwrap + ) where + +import Data.Morpheus.Types.Describer ((::->) (Resolver), EnumOf (..), ScalarOf (..)) +import Data.Morpheus.Types.Types (GQLRoot (..)) + +class Wrapper m where + wrap :: a -> m a + unwrap :: m a -> a + +instance Wrapper EnumOf where + wrap = EnumOf + unwrap (EnumOf x) = x + +instance Wrapper ScalarOf where + wrap = ScalarOf + unwrap (ScalarOf x) = x