morpheus-graphql 0.3.1 → 0.4.0
raw patch · 63 files changed
+999/−590 lines, 63 filesdep −lens
Dependencies removed: lens
Files
- README.md +53/−16
- assets/simple.gql +5/−3
- changelog.md +96/−0
- examples/Client/Client.hs +32/−9
- examples/Sophisticated/api.gql +2/−1
- morpheus-graphql.cabal +17/−13
- src/Data/Morpheus/Execution/Client/Aeson.hs +51/−18
- src/Data/Morpheus/Execution/Client/Build.hs +40/−31
- src/Data/Morpheus/Execution/Client/Compile.hs +2/−2
- src/Data/Morpheus/Execution/Client/Selection.hs +191/−117
- src/Data/Morpheus/Execution/Document/Convert.hs +15/−9
- src/Data/Morpheus/Execution/Document/Declare.hs +3/−3
- src/Data/Morpheus/Execution/Document/Encode.hs +2/−2
- src/Data/Morpheus/Execution/Document/GQLType.hs +4/−6
- src/Data/Morpheus/Execution/Internal/Declare.hs +7/−10
- src/Data/Morpheus/Execution/Internal/GraphScanner.hs +14/−0
- src/Data/Morpheus/Execution/Internal/Utils.hs +10/−0
- src/Data/Morpheus/Execution/Server/Introspect.hs +4/−13
- src/Data/Morpheus/Execution/Server/Resolve.hs +7/−11
- src/Data/Morpheus/Parsing/Client/ParseMeta.hs +0/−22
- src/Data/Morpheus/Parsing/Client/Parser.hs +0/−28
- src/Data/Morpheus/Parsing/Document/DataType.hs +3/−0
- src/Data/Morpheus/Parsing/Internal/Create.hs +1/−2
- src/Data/Morpheus/Parsing/Internal/Terms.hs +4/−0
- src/Data/Morpheus/Parsing/Internal/Value.hs +81/−0
- src/Data/Morpheus/Parsing/Request/Arguments.hs +1/−1
- src/Data/Morpheus/Parsing/Request/Operation.hs +5/−3
- src/Data/Morpheus/Parsing/Request/Value.hs +0/−73
- src/Data/Morpheus/Rendering/RenderGQL.hs +16/−14
- src/Data/Morpheus/Rendering/RenderIntrospection.hs +2/−2
- src/Data/Morpheus/Schema/Schema.hs +8/−7
- src/Data/Morpheus/Schema/SchemaAPI.hs +12/−11
- src/Data/Morpheus/Schema/TypeKind.hs +1/−2
- src/Data/Morpheus/Types/GQLType.hs +0/−6
- src/Data/Morpheus/Types/ID.hs +1/−2
- src/Data/Morpheus/Types/Internal/AST/Operation.hs +5/−2
- src/Data/Morpheus/Types/Internal/Data.hs +17/−5
- src/Data/Morpheus/Types/Internal/DataD.hs +9/−8
- src/Data/Morpheus/Types/Internal/TH.hs +4/−0
- src/Data/Morpheus/Types/Internal/Validation.hs +0/−3
- src/Data/Morpheus/Validation/Internal/Value.hs +77/−0
- src/Data/Morpheus/Validation/Query/Arguments.hs +1/−1
- src/Data/Morpheus/Validation/Query/Input/Enum.hs +0/−16
- src/Data/Morpheus/Validation/Query/Input/Object.hs +0/−68
- src/Data/Morpheus/Validation/Query/Variable.hs +21/−23
- test/Feature/Holistic/API.hs +1/−0
- test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json +0/−5
- test/Feature/InputType/cases.json +13/−1
- test/Feature/InputType/variables/invalidValue/invalidDefaultValue/query.gql +5/−0
- test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json +13/−0
- test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql +5/−0
- test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json +13/−0
- test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/variables.json +3/−0
- test/Feature/InputType/variables/nullableVariable/query.gql +0/−5
- test/Feature/InputType/variables/nullableVariable/response.json +0/−7
- test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql +5/−0
- test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/response.json +7/−0
- test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql +5/−0
- test/Feature/InputType/variables/valueNotProvided/nullableVariable/response.json +7/−0
- test/Rendering/Schema.hs +39/−0
- test/Rendering/TestSchemaRendering.hs +19/−0
- test/Rendering/schema.gql +27/−0
- test/Spec.hs +13/−9
README.md view
@@ -29,13 +29,14 @@ resolver: lts-13.30 extra-deps:+ - morpheus-graphql-0.4.0 - aeson-1.4.4.0 - time-compat-1.9.2.2 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack update` -### Building your first GrqphQL API+### Building your first GraphQL API ### with GraphQL syntax @@ -350,48 +351,84 @@ ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes -```haskell+```hs defineByDocumentFile "./schema.gql" [gql|- query GetHero ($byRealm: Realm)+ query GetHero ($character: Character) {- deity (realm:$byRealm) {+ deity (fatherOf:$character) {+ name power- fullName+ worships {+ deity2Name: name+ } } } |] ``` +with schema:++```gql+input Character {+ name: String!+}++type Deity {+ name: String!+ worships: Deity+}+```+ will validate query and Generate: -- response type `GetHero`, `Deity` with `Lens` Instances-- input types: `GetHeroArgs` , `Realm`+- namespaced response and variable types - instance for `Fetch` typeClass -so that+```hs+data GetHero = GetHero {+ deity: DeityDeity+} +-- from: {user+data DeityDeity = DeityDeity {+ name: Text,+ worships: Maybe DeityWorshipsDeity+}++-- from: {deity{worships+data DeityWorshipsDeity = DeityWorshipsDeity {+ name: Text,+}++data GetHeroArgs = GetHeroArgs {+ getHeroArgsCharacter: Character+}++data Character = Character {+ characterName: Person+}+```++as you see, response type field name collision can be handled with GraphQL `alias`.++with `fetch` you can fetch well typed response `GetHero`.+ ```haskell fetchHero :: Args GetHero -> m (Either String GetHero) fetchHero = fetch jsonRes args where- args = GetHeroArgs {byRealm = Just Realm {owner = "Zeus", surface = Just 10}}+ args = GetHeroArgs {getHeroArgsCharacter = Person {characterName = "Zeus"}} jsonRes :: ByteString -> m ByteString jsonRes = <GraphQL APi> ``` -resolves well typed response `GetHero`.--except: `defineByDocumentFile` you can use:+types can be generatet from `introspection` too: ```haskell defineByIntrospectionFile "./introspection.json" ```--or--`defineByIntrospection` where you can directly connect it to server ## Morpheus CLI for Code Generating
assets/simple.gql view
@@ -9,8 +9,8 @@ } type Mutation {- createDeity (deityName: [[[[[String!]]!]]], deityMythology: String): Deity!- createCharacter (charRealm: Realm! , charMutID: String! ): Character!+ createDeity (name: [[[[[String!]]!]]], mythology: String): Deity!+ createCharacter (realm: Realm! , id: String! ): Character! } union Character = Creature | Deity | Human@@ -39,7 +39,9 @@ input Realm { owner: String!- surface: Int+ age: Int+ realm: Realm+ profession: Profession } enum City {
changelog.md view
@@ -1,3 +1,99 @@+## [0.4.0] - 09.10.2019++## Changed++- support of Default Value:++ - on query: Parsing Validating and resolving+ - on Document: only Parsing++- 'lens' is removed from Library, client field collision can be handled with GraphQL `alias`:+ ```gql+ {+ user {+ name+ friend {+ friendName: name+ }+ }+ }+ ```++### Fixed:++- `Data.Morpheus.Document.toGraphQLDocument` generates only my user defined types. #259+- Morpheus Client Namespaces Input Type Fields, they don't collide anymore:+ example:+ schema:++ ```gql+ input Person {+ name: String!+ }+ ```++ query:++ ```gql+ query GetUser (parent: Person!) {+ ....+ }+ ```++ wil generate:++ ```hs+ data GetUserArgs = GetUserArgs {+ getUserArgsParent: Person+ } deriving ...++ data Person = Person {+ personName: Person+ } deriving ...+ ```++- Morpheus Client Generated Output Object And Union Types don't collide:++ ```gql+ type Person {+ name: String!+ parent: Person!+ friend: Person!+ }+ ```++ And we select++ ```gql+ {+ user {+ name+ friend {+ name+ }+ parent {+ name+ }+ bestFriend: friend {+ name+ parent {+ name+ }+ }+ }+ }+ ```++ client will Generate:++ - `UserPerson` from `{user`+ - `UserFriendPerson`: from `{user{freind`+ - `UserParentPerson`: from `{user{parent`+ - `UserBestFriendPerson`: from `{user{bestFrend`+ - `UserBestFriendParentPerson`: from `{user{bestFrend{parent`++- GraphQL Client Defines enums and Input Types only once per query and they don't collide+ ## [0.3.1] - 05.10.2019 ### Changed
examples/Client/Client.hs view
@@ -21,15 +21,21 @@ "./assets/introspection.json" [gql| # Query Hero with Compile time Validation- query GetUser ($userCoordinates: Coordinates!)+ query GetUser ($coordinates: Coordinates!) { myUser: user { boo3: name- email- address (coordinates: $userCoordinates ){- city+ myUserEmail: email+ address (coordinates: $coordinates ){+ city }+ customAdress: address (coordinates: $coordinates ){+ customCity: city+ } }+ user {+ email+ } } |] @@ -37,13 +43,13 @@ "./assets/simple.gql" [gql| # Query Hero with Compile time Validation- query GetHero ($god: Realm, $charID: String!)+ query GetHero ($god: Realm, $id: String!) { deity (mythology:$god) { power fullName }- character(characterID: $charID ) {+ character(characterID: $id ) { ...on Creature { creatureName }@@ -52,6 +58,15 @@ profession } }+ char2: character(characterID: $id ) {+ ...on Creature {+ cName: creatureName+ }+ ...on Human {+ lTime: lifetime+ prof: profession+ }+ } } |] @@ -59,13 +74,21 @@ ioRes req = do print req return- "{\"data\":{\"deity\":{ \"fullName\": \"name\" }, \"character\":{ \"__typename\":\"Human\", \"lifetime\": \"Lifetime\", \"profession\": \"Artist\" } }}"+ "{\"data\":{\"deity\":{ \"fullName\": \"name\" }, \"character\":{ \"__typename\":\"Human\", \"lifetime\": \"Lifetime\", \"profession\": \"Artist\" } , \"char2\":{ \"__typename\":\"Human\", \"lTime\": \"time\", \"prof\": \"Artist\" } }}" fetchHero :: IO (Either String GetHero)-fetchHero = fetch ioRes GetHeroArgs {god = Just Realm {owner = "Zeus", surface = Just 10}, charID = "Hercules"}+fetchHero =+ fetch+ ioRes+ GetHeroArgs+ { getHeroArgsGod =+ Just Realm {realmOwner = "Zeus", realmAge = Just 10, realmRealm = Nothing, realmProfession = Just Artist}+ , getHeroArgsId = "Hercules"+ } fetUser :: (ByteString -> IO ByteString) -> IO (Either String GetUser) fetUser api = fetch api userArgs where userArgs :: Args GetUser- userArgs = GetUserArgs {userCoordinates = Coordinates {longitude = [], latitude = String "1"}}+ userArgs =+ GetUserArgs {getUserArgsCoordinates = Coordinates {coordinatesLongitude = [], coordinatesLatitude = String "1"}}
examples/Sophisticated/api.gql view
@@ -26,6 +26,7 @@ } input UniqueID {+ type: String, id: String! } @@ -49,7 +50,7 @@ type Query { user: User! animal(animal: Animal): String!- wrapped1: AIntText!+ wrapped1(type: UniqueID): AIntText! wrapped2: AText! set: SetInt! map: MapTextInt!
morpheus-graphql.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 67b09c4ab9487b3b733622bc074185fee7c90c8828efc81188d85dd4b7507df8+-- hash: 7a85b066c745ff71fcf1c0be19c670fc75e393b6919cecc737943b70b5451977 name: morpheus-graphql-version: 0.3.1+version: 0.4.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -158,6 +158,11 @@ test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql test/Feature/InputType/variables/incompatibleType/weakerType3/response.json test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json+ test/Feature/InputType/variables/invalidValue/invalidDefaultValue/query.gql+ test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/variables.json test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json@@ -167,8 +172,6 @@ test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json- test/Feature/InputType/variables/nullableVariable/query.gql- test/Feature/InputType/variables/nullableVariable/response.json test/Feature/InputType/variables/undefinedVariable/query.gql test/Feature/InputType/variables/undefinedVariable/response.json test/Feature/InputType/variables/unknownType/query.gql@@ -189,6 +192,10 @@ test/Feature/InputType/variables/validListVariable/variables.json test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json+ test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql+ test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/response.json+ test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql+ test/Feature/InputType/variables/valueNotProvided/nullableVariable/response.json test/Feature/Schema/cases.json test/Feature/Schema/nameCollision/query.gql test/Feature/Schema/nameCollision/response.json@@ -214,6 +221,7 @@ test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json test/Feature/WrappedTypeName/validWrappedTypes/query.gql test/Feature/WrappedTypeName/validWrappedTypes/response.json+ test/Rendering/schema.gql source-repository head type: git@@ -254,6 +262,7 @@ Data.Morpheus.Execution.Document.Introspect Data.Morpheus.Execution.Internal.Declare Data.Morpheus.Execution.Internal.Decode+ Data.Morpheus.Execution.Internal.GraphScanner Data.Morpheus.Execution.Internal.Utils Data.Morpheus.Execution.Server.Decode Data.Morpheus.Execution.Server.Encode@@ -263,13 +272,12 @@ Data.Morpheus.Execution.Server.Resolve Data.Morpheus.Execution.Subscription.Apollo Data.Morpheus.Execution.Subscription.ClientRegister- Data.Morpheus.Parsing.Client.ParseMeta- Data.Morpheus.Parsing.Client.Parser Data.Morpheus.Parsing.Document.DataType Data.Morpheus.Parsing.Document.Parser Data.Morpheus.Parsing.Internal.Create Data.Morpheus.Parsing.Internal.Internal Data.Morpheus.Parsing.Internal.Terms+ Data.Morpheus.Parsing.Internal.Value Data.Morpheus.Parsing.JSONSchema.Parse Data.Morpheus.Parsing.JSONSchema.Types Data.Morpheus.Parsing.Request.Arguments@@ -277,7 +285,6 @@ Data.Morpheus.Parsing.Request.Fragment Data.Morpheus.Parsing.Request.Operation Data.Morpheus.Parsing.Request.Parser- Data.Morpheus.Parsing.Request.Value Data.Morpheus.Rendering.Haskell.Render Data.Morpheus.Rendering.Haskell.RenderHS Data.Morpheus.Rendering.Haskell.Terms@@ -308,10 +315,9 @@ Data.Morpheus.Types.Types Data.Morpheus.Validation.Document.Validation Data.Morpheus.Validation.Internal.Utils+ Data.Morpheus.Validation.Internal.Value Data.Morpheus.Validation.Query.Arguments Data.Morpheus.Validation.Query.Fragment- Data.Morpheus.Validation.Query.Input.Enum- Data.Morpheus.Validation.Query.Input.Object Data.Morpheus.Validation.Query.Selection Data.Morpheus.Validation.Query.Utils.Selection Data.Morpheus.Validation.Query.Validation@@ -325,7 +331,6 @@ , base >=4.7 && <5 , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7- , lens , megaparsec >=7.0.0 && <8.0 , mtl >=2.0 && <=2.2.2 , scientific >=0.3.6.2 && <0.4@@ -360,7 +365,6 @@ , base >=4.7 && <5 , bytestring , containers >=0.4.2.1 && <0.7- , lens , megaparsec >=7.0.0 && <8.0 , morpheus-graphql , mtl@@ -391,7 +395,6 @@ , bytestring , containers >=0.4.2.1 && <0.7 , filepath >=1.1 && <1.5- , lens , megaparsec >=7.0.0 && <8.0 , morpheus-graphql , mtl@@ -418,6 +421,8 @@ Feature.UnionType.API Feature.WrappedTypeName.API Lib+ Rendering.Schema+ Rendering.TestSchemaRendering TestFeature Paths_morpheus_graphql hs-source-dirs:@@ -428,7 +433,6 @@ , base >=4.7 && <5 , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7- , lens , megaparsec >=7.0.0 && <8.0 , morpheus-graphql , mtl >=2.0 && <=2.2.2
src/Data/Morpheus/Execution/Client/Aeson.hs view
@@ -10,36 +10,47 @@ module Data.Morpheus.Execution.Client.Aeson ( deriveFromJSON+ , deriveToJSON , takeValueType ) where import Data.Aeson import Data.Aeson.Types-import qualified Data.HashMap.Lazy as H (lookup)-import Data.Semigroup ((<>))-import Data.Text (unpack)+import qualified Data.HashMap.Lazy as H (lookup)+import Data.Semigroup ((<>))+import Data.Text (unpack) import Language.Haskell.TH +import Data.Morpheus.Execution.Internal.Utils (nameSpaceTypeString)+ -- -- MORPHEUS-import Data.Morpheus.Types.Internal.Data (DataField (..), isFieldNullable)-import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..))-import Data.Morpheus.Types.Internal.TH (instanceFunD, instanceHeadT)+import Data.Morpheus.Types.Internal.Data (DataField (..), isFieldNullable)+import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..))+import Data.Morpheus.Types.Internal.TH (destructRecord, instanceFunD, instanceHeadT) +-- FromJSON deriveFromJSON :: TypeD -> Q Dec deriveFromJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"-deriveFromJSON TypeD {tName, tCons = [cons]} = defineFromJSON tName aesonObject cons-deriveFromJSON typeD@TypeD {tName, tCons}- | isEnum tCons = defineFromJSON tName aesonEnum tCons- | otherwise = defineFromJSON tName aesonUnionObject typeD+deriveFromJSON TypeD {tName, tNamespace, tCons = [cons]} = defineFromJSON name (aesonObject tNamespace) cons+ where+ name = nameSpaceTypeString tNamespace tName+deriveFromJSON typeD@TypeD {tName, tCons, tNamespace}+ | isEnum tCons = defineFromJSON name aesonEnum tCons+ | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD+ where+ name = nameSpaceTypeString tNamespace tName -aesonObject :: ConsD -> ExpQ-aesonObject con@ConsD {cName} = appE [|withObject cName|] (lamE [varP (mkName "o")] (aesonObjectBody con))+aesonObject :: [String] -> ConsD -> ExpQ+aesonObject tNamespace con@ConsD {cName} =+ appE [|withObject name|] (lamE [varP (mkName "o")] ((aesonObjectBody tNamespace) con))+ where+ name = nameSpaceTypeString tNamespace cName -aesonObjectBody :: ConsD -> ExpQ-aesonObjectBody ConsD {cName, cFields} = handleFields cFields+aesonObjectBody :: [String] -> ConsD -> ExpQ+aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields where- consName = mkName cName+ consName = mkName $ nameSpaceTypeString namespace cName ------------------------------------------ handleFields [] = fail $ "No Empty Object" handleFields fields = startExp fields@@ -58,13 +69,14 @@ applyFields [x] = defField x applyFields (x:xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs) -aesonUnionObject :: TypeD -> ExpQ-aesonUnionObject TypeD {tCons} = appE (varE $ 'takeValueType) (lamCaseE ((map buildMatch tCons) <> [elseCaseEXP]))+aesonUnionObject :: [String] -> TypeD -> ExpQ+aesonUnionObject namespace TypeD {tCons} =+ appE (varE $ 'takeValueType) (lamCaseE ((map buildMatch tCons) <> [elseCaseEXP])) where buildMatch cons@ConsD {cName} = match pattern body [] where pattern = tupP [litP (stringL cName), varP $ mkName "o"]- body = normalB (aesonObjectBody cons)+ body = normalB $ aesonObjectBody namespace cons takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a takeValueType f (Object hMap) =@@ -105,3 +117,24 @@ appE (varE $ mkName "fail") (uInfixE (appE (varE 'show) (varE varName)) (varE '(<>)) (stringE $ " is Not Valid Union Constructor"))++-- ToJSON+deriveToJSON :: TypeD -> Q [Dec]+deriveToJSON TypeD {tCons = []} = fail "Type Should Have at least one Constructor"+deriveToJSON TypeD {tName, tCons = [ConsD {cFields}]} = pure <$> instanceD (cxt []) appHead methods+ where+ appHead = instanceHeadT ''ToJSON tName []+ ------------------------------------------------------------------+ -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]+ methods = [funD 'toJSON [clause argsE (normalB body) []]]+ where+ argsE = [destructRecord tName varNames]+ body = appE (varE 'object) (listE $ map decodeVar varNames)+ decodeVar name = [|name .= $(varName)|]+ where+ varName = varE $ mkName name+ varNames = map (unpack . fieldName) cFields+deriveToJSON TypeD {tName, tCons}+ | isEnum tCons = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) []+ -- enum: uses default aeson instance derivation methods+ | otherwise = fail "Input Unions are not yet supported"
src/Data/Morpheus/Execution/Client/Build.hs view
@@ -8,52 +8,61 @@ ( defineQuery ) where -import Control.Lens (declareLenses)-import Data.Aeson (ToJSON) import Data.Semigroup ((<>)) import Language.Haskell.TH -- -- MORPHEUS import Data.Morpheus.Error.Client.Client (renderGQLErrors)-import Data.Morpheus.Execution.Client.Aeson (deriveFromJSON)+import Data.Morpheus.Execution.Client.Aeson (deriveFromJSON, deriveToJSON) import Data.Morpheus.Execution.Client.Compile (validateWith) import Data.Morpheus.Execution.Client.Fetch (deriveFetch) import Data.Morpheus.Execution.Internal.Declare (declareType)-import Data.Morpheus.Types.Internal.Data (DataTypeLib)-import Data.Morpheus.Types.Internal.DataD (QueryD (..), TypeD (..))+import Data.Morpheus.Types.Internal.Data (DataTypeKind (..), DataTypeLib, isOutputObject)+import Data.Morpheus.Types.Internal.DataD (GQLTypeD (..), QueryD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Types (GQLQueryRoot (..)) -queryArgumentType :: [TypeD] -> (Type, Q [Dec])-queryArgumentType [] = (ConT $ mkName "()", pure [])-queryArgumentType (rootType@TypeD {tName}:xs) = (ConT $ mkName tName, types)- where- types = pure $ map (declareType [''Show, ''ToJSON]) (rootType : xs)--defineJSONType :: TypeD -> Q [Dec]-defineJSONType datatype = do- record <- declareLenses (pure [declareType [''Show] datatype])- toJson <- pure <$> deriveFromJSON datatype- pure $ record <> toJson--defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec]-defineOperationType (argType, argumentTypes) query datatype = do- rootType <- defineJSONType datatype- typeClassFetch <- deriveFetch argType (tName datatype) query- args <- argumentTypes- pure $ rootType <> typeClassFetch <> args--defineQueryD :: QueryD -> Q [Dec]-defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgTypes} = do- rootDecs <- defineOperationType (queryArgumentType queryArgTypes) queryText rootType- subTypeDecs <- concat <$> mapM defineJSONType subTypes- return $ rootDecs ++ subTypeDecs-defineQueryD QueryD {queryTypes = []} = return []- defineQuery :: IO (Validation DataTypeLib) -> (GQLQueryRoot, String) -> Q [Dec] defineQuery ioSchema queryRoot = do schema <- runIO ioSchema case schema >>= (`validateWith` queryRoot) of Left errors -> fail (renderGQLErrors errors) Right queryD -> defineQueryD queryD++defineQueryD :: QueryD -> Q [Dec]+defineQueryD QueryD {queryTypes = rootType:subTypes, queryText, queryArgsType} = do+ rootDecs <- defineOperationType (queryArgumentType queryArgsType) queryText rootType+ subTypeDecs <- concat <$> traverse declareT subTypes+ return $ rootDecs ++ subTypeDecs+ where+ declareT GQLTypeD {typeD, typeKindD}+ | isOutputObject typeKindD || typeKindD == KindUnion = withToJSON declareOutputType typeD+ | typeKindD == KindEnum = withToJSON declareInputType typeD+ | otherwise = declareInputType typeD+defineQueryD QueryD {queryTypes = []} = return []++declareOutputType :: TypeD -> Q [Dec]+declareOutputType typeD = pure [declareType False Nothing [''Show] typeD]++declareInputType :: TypeD -> Q [Dec]+declareInputType typeD = do+ toJSONDec <- deriveToJSON typeD+ pure $ declareType True Nothing [''Show] typeD : toJSONDec++withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec]+withToJSON f datatype = do+ toJson <- deriveFromJSON datatype+ dec <- f datatype+ pure (toJson : dec)++queryArgumentType :: Maybe TypeD -> (Type, Q [Dec])+queryArgumentType Nothing = (ConT $ mkName "()", pure [])+queryArgumentType (Just rootType@TypeD {tName}) = (ConT $ mkName tName, declareInputType rootType)++defineOperationType :: (Type, Q [Dec]) -> String -> GQLTypeD -> Q [Dec]+defineOperationType (argType, argumentTypes) query GQLTypeD {typeD} = do+ rootType <- withToJSON declareOutputType typeD+ typeClassFetch <- deriveFetch argType (tName typeD) query+ argsT <- argumentTypes+ pure $ rootType <> typeClassFetch <> argsT
src/Data/Morpheus/Execution/Client/Compile.hs view
@@ -37,5 +37,5 @@ validateWith :: DataTypeLib -> (GQLQueryRoot, String) -> Validation QueryD validateWith schema (rawRequest@GQLQueryRoot {operation}, queryText) = do validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest- (queryArgTypes, queryTypes) <- operationTypes schema (O.operationArgs operation) validOperation- return QueryD {queryText, queryTypes, queryArgTypes}+ (queryArgsType, queryTypes) <- operationTypes schema (O.operationArgs operation) validOperation+ return QueryD {queryText, queryTypes, queryArgsType}
src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -8,134 +8,208 @@ ( operationTypes ) where -import Data.Semigroup ((<>))-import Data.Text (Text, unpack)+import Data.Semigroup ((<>))+import Data.Text (Text, pack, unpack) -- -- MORPHEUS-import Data.Morpheus.Error.Utils (globalErrorMessage)-import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation, Variable (..),- VariableDefinitions)-import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..))-import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..),- DataTyCon (..), DataTypeLib (..), TypeAlias (..),- allDataTypes)-import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..))-import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation)-import Data.Morpheus.Validation.Internal.Utils (lookupType)+import Data.Morpheus.Error.Utils (globalErrorMessage)+import Data.Morpheus.Execution.Internal.GraphScanner (LibUpdater, resolveUpdates)+import Data.Morpheus.Execution.Internal.Utils (nameSpaceType)+import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), ValidOperation,+ Variable (..), VariableDefinitions)+import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)+import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..),+ DataTyCon (..), DataTypeKind (..), DataTypeLib (..),+ Key, TypeAlias (..), allDataTypes)+import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..))+import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation)+import Data.Morpheus.Validation.Internal.Utils (lookupType)+import Data.Set (fromList, toList) +removeDuplicates :: [Text] -> [Text]+removeDuplicates = toList . fromList+ compileError :: Text -> GQLErrors compileError x = globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" -operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation ([TypeD], [TypeD])+operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation (Maybe TypeD, [GQLTypeD]) operationTypes lib variables = genOperation where- queryDataType = OutputObject $ snd $ query lib- ------------------------------------------------------ typeByField :: Text -> DataFullType -> Validation DataFullType- typeByField key datatype = fst <$> lookupFieldType datatype key- ------------------------------------------------------- lookupFieldType :: DataFullType -> Text -> Validation (DataFullType, TypeAlias)- lookupFieldType (OutputObject DataTyCon {typeData}) key =- case lookup key typeData of- Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon- where trans x = (x, alias {aliasTyCon = typeFrom x, aliasArgs = Nothing})- Nothing -> Left (compileError key)- lookupFieldType _ key = Left (compileError key)- ----------------------------------------------------- genOperation Operation {operationName, operationSelection} = do- argTypes <- rootArguments (operationName <> "Args")- queryTypes <- genRecordType operationName queryDataType operationSelection- pure (argTypes, queryTypes)- -------------------------------------------{--}- genInputType :: Text -> Validation [TypeD]- genInputType name = getType lib name >>= subTypes+ (queryTypes, enums) <- genRecordType [] operationName queryDataType operationSelection+ inputTypeRequests <- resolveUpdates [] $ map (scanInputTypes lib . variableType . snd) variables+ inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)+ pure (rootArguments (operationName <> "Args"), queryTypes <> inputTypesAndEnums) where- subTypes (InputObject DataTyCon {typeName, typeData}) = do- types <- concat <$> mapM toInputTypeD typeData- fields <- traverse toFieldD typeData- pure $ typeD fields : types- where- typeD fields = TypeD {tName = unpack typeName, tCons = [ConsD {cName = unpack typeName, cFields = fields}]}- ---------------------------------------------------------------- toInputTypeD :: (Text, DataField) -> Validation [TypeD]- toInputTypeD (_, DataField {fieldType}) = genInputType $ aliasTyCon fieldType- ----------------------------------------------------------------- toFieldD :: (Text, DataField) -> Validation DataField- toFieldD (_, field@DataField {fieldType}) = do- aliasTyCon <- typeFrom <$> getType lib (aliasTyCon fieldType)- pure $ field {fieldType = fieldType {aliasTyCon}}- subTypes (Leaf x) = buildLeaf x- subTypes _ = pure []- -------------------------------------------- rootArguments :: Text -> Validation [TypeD]- rootArguments name = do- types <- concat <$> mapM (genInputType . variableType . snd) variables- pure $ typeD : types+ queryDataType = OutputObject $ snd $ query lib+ -------------------------------------------------------------------------+ buildListedTypes = fmap concat . traverse (buildInputType lib) . removeDuplicates+ -------------------------------------------------------------------------+ -- generates argument types for Operation Head+ rootArguments :: Text -> Maybe TypeD+ rootArguments argsName+ | null variables = Nothing+ | otherwise = Just rootArgumentsType+ ------------------------------------------ where- typeD :: TypeD- typeD = TypeD {tName = unpack name, tCons = [ConsD {cName = unpack name, cFields = map fieldD variables}]}- ---------------------------------------- fieldD :: (Text, Variable ()) -> DataField- fieldD (key, Variable {variableType, variableTypeWrappers}) =- DataField- { fieldName = key- , fieldArgs = []- , fieldArgsType = Nothing- , fieldType =- TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}- , fieldHidden = False+ rootArgumentsType :: TypeD+ rootArgumentsType =+ TypeD+ { tName = unpack argsName+ , tNamespace = []+ , tCons = [ConsD {cName = unpack argsName, cFields = map fieldD variables}] }- -------------------------------------------- getCon name dataType selectionSet = do- cFields <- genFields dataType selectionSet- subTypes <- newFieldTypes dataType selectionSet- pure (ConsD {cName = unpack name, cFields}, subTypes)- ---------------------------------------------------------------------------------------------- where- genFields datatype = mapM typeNameFromField where- typeNameFromField :: (Text, Selection) -> Validation DataField- typeNameFromField (fieldName, Selection {selectionRec = SelectionAlias {aliasFieldName}}) = do- fieldType <- snd <$> lookupFieldType datatype aliasFieldName- pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}- typeNameFromField (fieldName, _) = do- fieldType <- snd <$> lookupFieldType datatype fieldName- pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}- --------------------------------------------- genRecordType name dataType selectionSet = do- (con, subTypes) <- getCon name dataType selectionSet- pure $ TypeD {tName = unpack name, tCons = [con]} : subTypes- ------------------------------------------------------------------------------------------------------------- newFieldTypes parentType = fmap concat <$> mapM validateSelection+ fieldD :: (Text, Variable DefaultValue) -> DataField+ fieldD (key, Variable {variableType, variableTypeWrappers}) =+ DataField+ { fieldName = key+ , fieldArgs = []+ , fieldArgsType = Nothing+ , fieldType =+ TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}+ , fieldHidden = False+ }+ ---------------------------------------------------------+ -- generates selection Object Types+ genRecordType :: [Key] -> Key -> DataFullType -> SelectionSet -> Validation ([GQLTypeD], [Text])+ genRecordType path name dataType recordSelSet = do+ (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet+ pure+ ( GQLTypeD+ { typeD = TypeD {tName, tNamespace = map unpack path, tCons = [con]}+ , typeKindD = KindObject Nothing+ , typeArgD = []+ } :+ subTypes+ , requests) where- validateSelection :: (Text, Selection) -> Validation [TypeD]- validateSelection (key, Selection {selectionRec = SelectionField}) =- key `typeByField` parentType >>= buildSelField- where- buildSelField (Leaf x) = buildLeaf x- buildSelField _ = Left $ compileError "Invalid schema Expected scalar"- validateSelection (key, Selection {selectionRec = SelectionSet selectionSet}) = do- datatype <- key `typeByField` parentType- genRecordType (typeFrom datatype) datatype selectionSet- validateSelection (_, selection@Selection {selectionRec = SelectionAlias {aliasFieldName, aliasSelection}}) =- validateSelection (aliasFieldName, selection {selectionRec = aliasSelection})- validateSelection (key, Selection {selectionRec = UnionSelection unionSelections}) = do- unionTypeName <- typeFrom <$> key `typeByField` parentType- (tCons, subTypes) <- unzip <$> mapM getUnionType unionSelections- pure $ TypeD {tName = unpack unionTypeName, tCons} : concat subTypes+ tName = unpack name+ genConsD :: String -> DataFullType -> SelectionSet -> Validation (ConsD, [GQLTypeD], [Text])+ genConsD cName datatype selSet = do+ cFields <- traverse genField selSet+ (subTypes, requests) <- newFieldTypes datatype selSet+ pure (ConsD {cName, cFields}, concat subTypes, concat requests)+ --------------------------------------------------------------------------------------------- where- getUnionType (typeKey, selSet) = do- conDatatype <- getType lib typeKey- getCon typeKey conDatatype selSet+ genField :: (Text, Selection) -> Validation DataField+ genField (fieldName, sel) = genFieldD sel+ where+ fieldPath = path <> [fieldName]+ -------------------------------+ genFieldD Selection {selectionRec = SelectionAlias {aliasFieldName}} = do+ fieldType <- snd <$> lookupFieldType lib fieldPath datatype aliasFieldName+ pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}+ genFieldD _ = do+ fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName+ pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}+ ------------------------------------------------------------------------------------------------------------+ newFieldTypes :: DataFullType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]])+ newFieldTypes parentType seSet = unzip <$> mapM valSelection seSet+ where+ valSelection selection@(selKey, _) = do+ let (key, sel) = getSelectionFieldKey selection+ fieldDatatype <- fst <$> lookupFieldType lib fieldPath parentType key+ validateSelection fieldDatatype sel+ --------------------------------------------------------------------+ where+ fieldPath = path <> [selKey]+ --------------------------------------------------------------------+ validateSelection :: DataFullType -> Selection -> Validation ([GQLTypeD], [Text])+ validateSelection dType Selection {selectionRec = SelectionField} = do+ lName <- withLeaf (pure . leafName) dType+ pure ([], lName)+ --withLeaf buildLeaf dType+ validateSelection dType Selection {selectionRec = SelectionSet selectionSet} =+ genRecordType fieldPath (typeFrom [] dType) dType selectionSet+ validateSelection dType aliasSel@Selection {selectionRec = SelectionAlias {aliasSelection}} =+ validateSelection dType aliasSel {selectionRec = aliasSelection}+ ---- UNION+ validateSelection dType Selection {selectionRec = UnionSelection unionSelections} = do+ (tCons, subTypes, requests) <- unzip3 <$> mapM getUnionType unionSelections+ pure+ ( GQLTypeD+ { typeD =+ TypeD {tNamespace = map unpack fieldPath, tName = unpack $ typeFrom [] dType, tCons}+ , typeKindD = KindUnion+ , typeArgD = []+ } :+ concat subTypes+ , concat requests)+ where+ getUnionType (selectedTyName, selectionVariant) = do+ conDatatype <- getType lib selectedTyName+ genConsD (unpack selectedTyName) conDatatype selectionVariant -buildLeaf :: DataLeaf -> Validation [TypeD]-buildLeaf (LeafEnum DataTyCon {typeName, typeData}) =- pure [TypeD {tName = unpack typeName, tCons = map enumOption typeData}]+scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key]+scanInputTypes lib name collected+ | name `elem` collected = pure collected+ | otherwise = getType lib name >>= scanType where- enumOption name = ConsD {cName = unpack name, cFields = []}-buildLeaf _ = pure []+ scanType (InputObject DataTyCon {typeData}) = resolveUpdates (name : collected) (map toInputTypeD typeData)+ where+ toInputTypeD :: (Text, DataField) -> LibUpdater [Key]+ toInputTypeD (_, DataField {fieldType = TypeAlias {aliasTyCon}}) = scanInputTypes lib aliasTyCon+ scanType (Leaf leaf) = pure (collected <> leafName leaf)+ scanType _ = pure collected +buildInputType :: DataTypeLib -> Text -> Validation [GQLTypeD]+buildInputType lib name = getType lib name >>= subTypes+ where+ subTypes (InputObject DataTyCon {typeName, typeData}) = do+ fields <- traverse toFieldD typeData+ pure+ [ GQLTypeD+ { typeD =+ TypeD+ { tName = unpack typeName+ , tNamespace = []+ , tCons = [ConsD {cName = unpack typeName, cFields = fields}]+ }+ , typeArgD = []+ , typeKindD = KindInputObject+ }+ ]+ ----------------------------------------------------------------+ where+ toFieldD :: (Text, DataField) -> Validation DataField+ toFieldD (_, field@DataField {fieldType}) = do+ aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType)+ pure $ field {fieldType = fieldType {aliasTyCon}}+ subTypes (Leaf (LeafEnum DataTyCon {typeName, typeData})) =+ pure+ [ GQLTypeD+ { typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons = map enumOption typeData}+ , typeArgD = []+ , typeKindD = KindEnum+ }+ ]+ where+ enumOption eName = ConsD {cName = unpack eName, cFields = []}+ subTypes _ = pure []++lookupFieldType :: DataTypeLib -> [Key] -> DataFullType -> Text -> Validation (DataFullType, TypeAlias)+lookupFieldType lib path (OutputObject DataTyCon {typeData}) key =+ case lookup key typeData of+ Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon+ where trans x = (x, alias {aliasTyCon = typeFrom path x, aliasArgs = Nothing})+ Nothing -> Left (compileError key)+lookupFieldType _ _ _ key = Left (compileError key)++getSelectionFieldKey :: (Key, Selection) -> (Key, Selection)+getSelectionFieldKey (_, selection@Selection {selectionRec = SelectionAlias {aliasFieldName, aliasSelection}}) =+ (aliasFieldName, selection {selectionRec = aliasSelection})+getSelectionFieldKey sel = sel++withLeaf :: (DataLeaf -> Validation b) -> DataFullType -> Validation b+withLeaf f (Leaf x) = f x+withLeaf _ _ = Left $ compileError "Invalid schema Expected scalar"++leafName :: DataLeaf -> [Text]+leafName (LeafEnum DataTyCon {typeName}) = [typeName]+leafName _ = []+ getType :: DataTypeLib -> Text -> Validation DataFullType getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename @@ -147,13 +221,13 @@ isPrimitive "ID" = True isPrimitive _ = False -typeFrom :: DataFullType -> Text-typeFrom (Leaf (BaseScalar x)) = typeName x-typeFrom (Leaf (CustomScalar DataTyCon {typeName}))+typeFrom :: [Key] -> DataFullType -> Text+typeFrom _ (Leaf (BaseScalar x)) = typeName x+typeFrom _ (Leaf (CustomScalar DataTyCon {typeName})) | isPrimitive typeName = typeName | otherwise = "ScalarValue"-typeFrom (Leaf (LeafEnum x)) = typeName x-typeFrom (InputObject x) = typeName x-typeFrom (OutputObject x) = typeName x-typeFrom (Union x) = typeName x-typeFrom (InputUnion x) = typeName x+typeFrom _ (Leaf (LeafEnum x)) = typeName x+typeFrom _ (InputObject x) = typeName x+typeFrom path (OutputObject x) = pack $ nameSpaceType path $ typeName x+typeFrom path (Union x) = pack $ nameSpaceType path $ typeName x+typeFrom _ (InputUnion x) = typeName x
src/Data/Morpheus/Execution/Document/Convert.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE TypeOperators #-} module Data.Morpheus.Execution.Document.Convert- ( renderTHTypes , sysTypes+ ( renderTHTypes ) where import Data.Semigroup ((<>))@@ -18,14 +18,10 @@ import Data.Morpheus.Types.Internal.Data (ArgsType (..), DataField (..), DataField, DataFullType (..), DataLeaf (..), DataTyCon (..), DataTypeKind (..), DataTypeKind (..), OperationKind (..), ResolverKind (..),- TypeAlias (..))+ TypeAlias (..), sysTypes) import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Validation (Validation) -sysTypes :: [Text]-sysTypes =- ["__Schema", "__Type", "__Directive", "__TypeKind", "__Field", "__DirectiveLocation", "__InputValue", "__EnumValue"]- renderTHTypes :: Bool -> [(Text, DataFullType)] -> Validation [GQLTypeD] renderTHTypes namespace lib = traverse renderTHType lib where@@ -40,7 +36,13 @@ genArgumentType :: (Text, DataField) -> Validation [TypeD] genArgumentType (_, DataField {fieldArgs = []}) = pure [] genArgumentType (fieldName, DataField {fieldArgs}) =- pure [TypeD {tName, tCons = [ConsD {cName = sysName $ pack tName, cFields = map genField fieldArgs}]}]+ pure+ [ TypeD+ { tName+ , tNamespace = []+ , tCons = [ConsD {cName = sysName $ pack tName, cFields = map genField fieldArgs}]+ }+ ] where tName = genArgsTypeName $ sysName fieldName -------------------------------------------@@ -87,7 +89,7 @@ genType (Leaf (LeafEnum DataTyCon {typeName, typeData})) = pure GQLTypeD- { typeD = TypeD {tName = sysName typeName, tCons = map enumOption typeData}+ { typeD = TypeD {tName = sysName typeName, tNamespace = [], tCons = map enumOption typeData} , typeKindD = KindEnum , typeArgD = [] }@@ -101,6 +103,7 @@ { typeD = TypeD { tName = sysName typeName+ , tNamespace = [] , tCons = [ConsD {cName = sysName typeName, cFields = map genField typeData}] } , typeKindD = KindInputObject@@ -113,6 +116,7 @@ { typeD = TypeD { tName = sysName typeName+ , tNamespace = [] , tCons = [ConsD {cName = sysName typeName, cFields = map genResField typeData}] } , typeKindD =@@ -123,7 +127,9 @@ } genType (Union DataTyCon {typeName, typeData}) = do let tCons = map unionCon typeData- pure GQLTypeD {typeD = TypeD {tName = unpack typeName, tCons}, typeKindD = KindUnion, typeArgD = []}+ pure+ GQLTypeD+ {typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons}, typeKindD = KindUnion, typeArgD = []} where unionCon field@DataField {fieldType} = ConsD
src/Data/Morpheus/Execution/Document/Declare.hs view
@@ -15,7 +15,7 @@ import Data.Morpheus.Execution.Document.Encode (deriveEncode) import Data.Morpheus.Execution.Document.GQLType (deriveGQLType) import Data.Morpheus.Execution.Document.Introspect (deriveObjectRep)-import Data.Morpheus.Execution.Internal.Declare (declareGQLT)+import Data.Morpheus.Execution.Internal.Declare (declareType) import Data.Morpheus.Types.Internal.Data (isInput, isObject) import Data.Morpheus.Types.Internal.DataD (GQLTypeD (..)) @@ -44,11 +44,11 @@ where deriveArgsRep args = deriveObjectRep (args, Nothing) ----------------------------------------------------- argsTypeDecs = map (declareGQLT namespace Nothing []) typeArgD+ argsTypeDecs = map (declareType namespace Nothing []) typeArgD -------------------------------------------------- declareMainType = declareT where- declareT = pure [declareGQLT namespace (Just typeKindD) derivingClasses typeD]+ declareT = pure [declareType namespace (Just typeKindD) derivingClasses typeD] derivingClasses | isInput typeKindD = [''Show] | otherwise = []
src/Data/Morpheus/Execution/Document/Encode.hs view
@@ -17,7 +17,7 @@ import Data.Morpheus.Types.GQLType (TRUE) import Data.Morpheus.Types.Internal.Data (DataField (..), isSubscription) import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..))-import Data.Morpheus.Types.Internal.TH (applyT, instanceHeadMultiT, typeT)+import Data.Morpheus.Types.Internal.TH (applyT, destructRecord, instanceHeadMultiT, typeT) import Data.Morpheus.Types.Internal.Validation (ResolveT) import Data.Morpheus.Types.Internal.Value (Value) import Data.Morpheus.Types.Resolver@@ -57,7 +57,7 @@ -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...] methods = [funD 'objectResolvers [clause argsE (normalB body) []]] where- argsE = [varP (mkName "_"), conP (mkName tName) (map (varP . mkName) varNames)]+ argsE = [varP (mkName "_"), destructRecord tName varNames] body = listE $ map decodeVar varNames decodeVar name = [|(name, encode $(varName))|] where
src/Data/Morpheus/Execution/Document/GQLType.hs view
@@ -11,22 +11,20 @@ import Data.Text (pack) import Language.Haskell.TH -import Data.Morpheus.Execution.Document.Convert (sysTypes)- -- -- MORPHEUS import Data.Morpheus.Execution.Internal.Declare (tyConArgs) import Data.Morpheus.Kind (ENUM, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION, WRAPPER) import Data.Morpheus.Types.GQLType (GQLType (..), TRUE)-import Data.Morpheus.Types.Internal.Data (DataTypeKind (..), isObject)+import Data.Morpheus.Types.Internal.Data (DataTypeKind (..), isObject, isSchemaTypeName) import Data.Morpheus.Types.Internal.DataD (GQLTypeD (..), TypeD (..)) import Data.Morpheus.Types.Internal.TH (instanceHeadT, typeT) import Data.Typeable (Typeable) genTypeName :: String -> String genTypeName ('S':name)- | pack name `elem` sysTypes = name+ | isSchemaTypeName (pack name) = name genTypeName name = name deriveGQLType :: GQLTypeD -> Q [Dec]@@ -34,12 +32,12 @@ pure <$> instanceD (cxt constrains) iHead (def__typeName : typeFamilies) where def__typeName = funD '__typeName [clause argsE (normalB body) []]- -- defines method: __typeName _ = tName where- argsE = map (varP . mkName) ["_"] body = [|pack name|] where name = genTypeName tName+ -- defines method: __typeName _ = tName+ argsE = map (varP . mkName) ["_"] typeArgs = tyConArgs typeKindD ---------------------------------------------- iHead = instanceHeadT ''GQLType tName typeArgs
src/Data/Morpheus/Execution/Internal/Declare.hs view
@@ -9,17 +9,16 @@ module Data.Morpheus.Execution.Internal.Declare ( declareType- , declareGQLT , tyConArgs ) where import Data.Maybe (maybe)-import Data.Text (unpack)+import Data.Text (pack, unpack) import GHC.Generics (Generic) import Language.Haskell.TH -- MORPHEUS-import Data.Morpheus.Execution.Internal.Utils (nameSpaceWith)+import Data.Morpheus.Execution.Internal.Utils (nameSpaceType, nameSpaceWith) import Data.Morpheus.Types.Internal.Data (ArgsType (..), DataField (..), DataTypeKind (..), DataTypeKind (..), TypeAlias (..), WrapperD (..), isOutputObject, isSubscription)@@ -28,9 +27,6 @@ type FUNC = (->) -declareType :: [Name] -> TypeD -> Dec-declareType = declareGQLT False Nothing- declareTypeAlias :: Bool -> TypeAlias -> Type declareTypeAlias isSub TypeAlias {aliasTyCon, aliasWrappers, aliasArgs} = wrappedT aliasWrappers where@@ -52,16 +48,17 @@ | otherwise = [] -- declareType-declareGQLT :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec-declareGQLT namespace kindD derivingList TypeD {tName, tCons} =- DataD [] (mkName tName) tVars Nothing (map cons tCons) $ map derive (''Generic : derivingList)+declareType :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec+declareType namespace kindD derivingList TypeD {tName, tCons, tNamespace} =+ DataD [] (genName tName) tVars Nothing (map cons tCons) $ map derive (''Generic : derivingList) where+ genName = mkName . nameSpaceType (map pack tNamespace) . pack tVars = maybe [] (declareTyVar . tyConArgs) kindD where declareTyVar = map (PlainTV . mkName) defBang = Bang NoSourceUnpackedness NoSourceStrictness derive className = DerivClause Nothing [ConT className]- cons ConsD {cName, cFields} = RecC (mkName cName) (map declareField cFields)+ cons ConsD {cName, cFields} = RecC (genName cName) (map declareField cFields) where declareField DataField {fieldName, fieldArgsType, fieldType} = (fName, defBang, fiType) where
+ src/Data/Morpheus/Execution/Internal/GraphScanner.hs view
@@ -0,0 +1,14 @@+module Data.Morpheus.Execution.Internal.GraphScanner+ ( LibUpdater+ , resolveUpdates+ ) where++import Control.Monad (foldM)+import Data.Function ((&))+import Data.Morpheus.Types.Internal.Validation (Validation)++type LibUpdater lib = lib -> Validation lib++-- Helper Functions+resolveUpdates :: lib -> [LibUpdater lib] -> Validation lib+resolveUpdates = foldM (&)
src/Data/Morpheus/Execution/Internal/Utils.hs view
@@ -2,10 +2,20 @@ ( capital , nonCapital , nameSpaceWith+ , nameSpaceType+ , nameSpaceTypeString ) where import Data.Char (toLower, toUpper) import Data.Semigroup ((<>))+import Data.Text (Text, unpack)+++nameSpaceTypeString :: [String] -> String -> String+nameSpaceTypeString list name = concatMap capital (list <> [name])++nameSpaceType :: [Text] -> Text -> String+nameSpaceType list name = concatMap (capital . unpack) (list <> [name]) nameSpaceWith :: String -> String -> String nameSpaceWith nSpace name = nonCapital nSpace <> capital name
src/Data/Morpheus/Execution/Server/Introspect.hs view
@@ -19,13 +19,10 @@ , Introspect(..) , ObjectFields(..) , IntroCon- , resolveTypes , updateLib , buildType ) where -import Control.Monad (foldM)-import Data.Function ((&)) import Data.Map (Map) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>))@@ -35,6 +32,7 @@ -- MORPHEUS import Data.Morpheus.Error.Schema (nameCollisionError)+import Data.Morpheus.Execution.Internal.GraphScanner (LibUpdater, resolveUpdates) import Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..)) import Data.Morpheus.Kind (Context (..), ENUM, GQL_KIND, INPUT_OBJECT, INPUT_UNION, OBJECT, SCALAR, UNION)@@ -45,7 +43,6 @@ DataLeaf (..), DataTyCon (..), DataTypeLib, TypeAlias (..), defineType, isTypeDefined, toListField, toNullableField)-import Data.Morpheus.Types.Internal.Validation (SchemaValidation) type IntroCon a = (GQLType a, ObjectFields (CUSTOM a) a) @@ -89,7 +86,7 @@ -- Resolver : a -> Resolver b instance (ObjectFields 'False a, Introspect b) => Introspect (a -> m b) where field _ name = (field (Proxy @b) name) {fieldArgs = fst $ objectFields (Proxy :: Proxy 'False) (Proxy @a)}- introspect _ typeLib = resolveTypes typeLib (introspect (Proxy @b) : argTypes)+ introspect _ typeLib = resolveUpdates typeLib (introspect (Proxy @b) : argTypes) where argTypes :: [TypeUpdater] argTypes = snd $ objectFields (Proxy :: Proxy 'False) (Proxy @a)@@ -152,7 +149,6 @@ { typeName -- has same fingerprint as object because it depends on it , typeFingerprint = __typeFingerprint (Proxy @a)- , typeVisibility = __typeVisibility (Proxy @a) , typeDescription = Nothing , typeData = map fieldName inputUnions }@@ -167,7 +163,7 @@ } -- Types-type TypeUpdater = DataTypeLib -> SchemaValidation DataTypeLib+type TypeUpdater = LibUpdater DataTypeLib type GQL_TYPE a = (Generic a, GQLType a) @@ -216,10 +212,6 @@ buildAlias :: Text -> TypeAlias buildAlias aliasTyCon = TypeAlias {aliasTyCon, aliasWrappers = [], aliasArgs = Nothing} --- Helper Functions-resolveTypes :: DataTypeLib -> [TypeUpdater] -> SchemaValidation DataTypeLib-resolveTypes = foldM (&)- buildField :: GQLType a => Proxy a -> DataArguments -> Text -> DataField buildField proxy fieldArgs fieldName = DataField@@ -231,14 +223,13 @@ { typeName = __typeName proxy , typeFingerprint = __typeFingerprint proxy , typeDescription = description proxy- , typeVisibility = __typeVisibility proxy , typeData } updateLib :: GQLType a => (Proxy a -> DataFullType) -> [TypeUpdater] -> Proxy a -> TypeUpdater updateLib typeBuilder stack proxy lib' = case isTypeDefined (__typeName proxy) lib' of- Nothing -> resolveTypes (defineType (__typeName proxy, typeBuilder proxy) lib') stack+ Nothing -> resolveUpdates (defineType (__typeName proxy, typeBuilder proxy) lib') stack Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib' -- throw error if 2 different types has same name
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -26,9 +26,10 @@ -- MORPHEUS import Data.Morpheus.Error.Utils (badRequestError, renderErrors)+import Data.Morpheus.Execution.Internal.GraphScanner (resolveUpdates) import Data.Morpheus.Execution.Server.Encode (EncodeCon, EncodeMutCon, EncodeSubCon, OBJ_RES, encodeOperation, encodeQuery)-import Data.Morpheus.Execution.Server.Introspect (IntroCon, ObjectFields (..), resolveTypes)+import Data.Morpheus.Execution.Server.Introspect (IntroCon, ObjectFields (..)) import Data.Morpheus.Execution.Subscription.ClientRegister (GQLState, publishUpdates) import Data.Morpheus.Parsing.Request.Parser (parseGQL) import Data.Morpheus.Schema.Schema (Root)@@ -138,15 +139,16 @@ -> Validation DataTypeLib fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema where- querySchema = resolveTypes (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types)+ querySchema =+ resolveUpdates (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types) where (fields, types) = objectFields (Proxy @(CUSTOM query)) (Proxy @query) ------------------------------- mutationSchema lib = resolveTypes (lib {mutation = maybeOperator fields "Mutation"}) types+ mutationSchema lib = resolveUpdates (lib {mutation = maybeOperator fields "Mutation"}) types where (fields, types) = objectFields (Proxy @(CUSTOM mutation)) (Proxy @mutation) ------------------------------- subscriptionSchema lib = resolveTypes (lib {subscription = maybeOperator fields "Subscription"}) types+ subscriptionSchema lib = resolveUpdates (lib {subscription = maybeOperator fields "Subscription"}) types where (fields, types) = objectFields (Proxy @(CUSTOM subscription)) (Proxy @subscription) -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a])@@ -155,10 +157,4 @@ -- operatorType :: [a] -> Text -> (Text, DataTyCon[a]) operatorType typeData typeName = ( typeName- , DataTyCon- { typeData- , typeVisibility = True- , typeName- , typeFingerprint = SystemFingerprint typeName- , typeDescription = Nothing- })+ , DataTyCon {typeData, typeName, typeFingerprint = SystemFingerprint typeName, typeDescription = Nothing})
− src/Data/Morpheus/Parsing/Client/ParseMeta.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Parsing.Client.ParseMeta- ( parseMeta- ) where--import Data.Morpheus.Parsing.Internal.Internal (Parser)-import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, token)-import Data.Text (Text)-import Text.Megaparsec (between, label)-import Text.Megaparsec.Char (char, space)--parseMeta :: Parser (Text, Text)-parseMeta =- label "MetaData" $ do- space- _ <- char '#'- between- (char '{' *> space)- (char '}' *> space)- (parseAssignment token token)
− src/Data/Morpheus/Parsing/Client/Parser.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parsing.Client.Parser- ( lookupGQLConfig- ) where--import Data.Text (Text)-import Text.Megaparsec (label, runParser)-import Text.Megaparsec.Char (space)------- MORPHEUS-import Data.Morpheus.Parsing.Client.ParseMeta (parseMeta)-import Data.Morpheus.Parsing.Internal.Internal (Parser, processErrorBundle)-import Data.Morpheus.Types.Internal.Validation (Validation)--lookupGQLConfig :: Text -> Validation (Text, Text)-lookupGQLConfig text =- case runParser request "<input>" text of- Left x -> Left $ processErrorBundle x- Right x -> Right x- where- request :: Parser (Text, Text)- request =- label "GQLConfig" $ do- space- parseMeta
src/Data/Morpheus/Parsing/Document/DataType.hs view
@@ -11,6 +11,7 @@ import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, parseMaybeTuple, parseNonNull, parseWrappedType, pipeLiteral, qualifier, setOf, spaceAndComments, token)+import Data.Morpheus.Parsing.Internal.Value (parseDefaultValue) import Data.Morpheus.Types.Internal.Data (DataArgument, DataField, DataFullType (..), Key, RawDataType (..), toHSWrappers) import Data.Text (Text)@@ -22,6 +23,8 @@ label "Argument" $ do ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType nonNull <- parseNonNull+ -- TODO: handle default value+ defaultValue <- parseDefaultValue pure $ createArgument fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType) typeDef :: Text -> Parser Text
src/Data/Morpheus/Parsing/Internal/Create.hs view
@@ -32,8 +32,7 @@ createType :: Text -> a -> DataTyCon a createType typeName typeData =- DataTyCon- {typeName, typeDescription = Nothing, typeFingerprint = SystemFingerprint "", typeVisibility = True, typeData}+ DataTyCon {typeName, typeDescription = Nothing, typeFingerprint = SystemFingerprint "", typeData} createScalarType :: Text -> (Text, DataFullType) createScalarType typeName = (typeName, Leaf $ CustomScalar $ createType typeName (DataValidator pure))
src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -16,6 +16,7 @@ , parseMaybeTuple , parseAssignment , parseWrappedType+ , litEquals ) where import Data.Functor (($>))@@ -34,6 +35,9 @@ pipeLiteral :: Parser () pipeLiteral = char '|' *> spaceAndComments++litEquals :: Parser ()+litEquals = char '=' *> spaceAndComments -- PRIMITIVE ------------------------------------
+ src/Data/Morpheus/Parsing/Internal/Value.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Parsing.Internal.Value+ ( parseValue+ , enumValue+ , parseDefaultValue+ ) where++import Data.Functor (($>))+import Data.Text (pack)+import Text.Megaparsec (anySingleBut, between, choice, label, many, optional, sepBy,+ (<|>))+import Text.Megaparsec.Char (char, string)+import Text.Megaparsec.Char.Lexer (scientific)++--+-- MORPHEUS+import Data.Morpheus.Parsing.Internal.Internal (Parser)+import Data.Morpheus.Parsing.Internal.Terms (litEquals, parseAssignment, setOf, spaceAndComments, token)+import Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..), decodeScientific)++parseDefaultValue :: Parser (Maybe Value)+parseDefaultValue =+ optional $ do+ litEquals+ parseValue++parseValue :: Parser Value+parseValue =+ label "value" $ do+ value <- valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|> objectValue <|> listValue+ spaceAndComments+ return value++valueNull :: Parser Value+valueNull = string "null" $> Null++booleanValue :: Parser Value+booleanValue = boolTrue <|> boolFalse+ where+ boolTrue = string "true" $> Scalar (Boolean True)+ boolFalse = string "false" $> Scalar (Boolean False)++valueNumber :: Parser Value+valueNumber = Scalar . decodeScientific <$> scientific++enumValue :: Parser Value+enumValue = do+ enum <- Enum <$> token+ spaceAndComments+ return enum++escaped :: Parser Char+escaped =+ label "escaped" $ do+ x <- anySingleBut '\"'+ if x == '\\'+ then choice (zipWith escapeChar codes replacements)+ else pure x+ where+ replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']+ codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']+ escapeChar code replacement = char code >> return replacement++stringValue :: Parser Value+stringValue = label "stringValue" $ Scalar . String . pack <$> between (char '"') (char '"') (many escaped)++listValue :: Parser Value+listValue =+ label "listValue" $+ List <$>+ between+ (char '[' *> spaceAndComments)+ (char ']' *> spaceAndComments)+ (parseValue `sepBy` (char ',' *> spaceAndComments))++objectValue :: Parser Value+objectValue = label "objectValue" $ Object <$> setOf entry+ where+ entry = parseAssignment token parseValue
src/Data/Morpheus/Parsing/Request/Arguments.hs view
@@ -6,7 +6,7 @@ import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, parseMaybeTuple, token, variable)-import Data.Morpheus.Parsing.Request.Value (enumValue, parseValue)+import Data.Morpheus.Parsing.Internal.Value (enumValue, parseValue) import Data.Morpheus.Types.Internal.AST.RawSelection (Argument (..), RawArgument (..), RawArguments, Reference (..)) import Data.Morpheus.Types.Internal.AST.Selection (ArgumentOrigin (..))
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -16,15 +16,17 @@ import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, parseMaybeTuple, parseNonNull, parseWrappedType, spaceAndComments1, token, variable)+import Data.Morpheus.Parsing.Internal.Value (parseDefaultValue) import Data.Morpheus.Parsing.Request.Body (entries)-import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, Variable (..))+import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), RawOperation, Variable (..)) import Data.Morpheus.Types.Internal.Data (OperationKind (..), toHSWrappers) -operationArgument :: Parser (Text, Variable ())+operationArgument :: Parser (Text, Variable DefaultValue) operationArgument = label "operatorArgument" $ do ((name, variablePosition), (wrappers, variableType)) <- parseAssignment variable parseWrappedType nonNull <- parseNonNull+ defaultValue <- parseDefaultValue pure ( name , Variable@@ -32,7 +34,7 @@ , isVariableRequired = 0 < length nonNull , variableTypeWrappers = toHSWrappers $ nonNull ++ wrappers , variablePosition- , variableValue = ()+ , variableValue = defaultValue }) parseOperation :: Parser RawOperation
− src/Data/Morpheus/Parsing/Request/Value.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Parsing.Request.Value- ( parseValue- , enumValue- ) where--import Data.Functor (($>))-import Data.Text (pack)-import Text.Megaparsec (anySingleBut, between, choice, label, many, sepBy, (<|>))-import Text.Megaparsec.Char (char, string)-import Text.Megaparsec.Char.Lexer (scientific)------- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal (Parser)-import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, setOf, spaceAndComments, token)-import Data.Morpheus.Types.Internal.Value (ScalarValue (..), Value (..), decodeScientific)--parseValue :: Parser Value-parseValue =- label "value" $ do- value <- valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|> objectValue <|> listValue- spaceAndComments- return value--valueNull :: Parser Value-valueNull = string "null" $> Null--booleanValue :: Parser Value-booleanValue = boolTrue <|> boolFalse- where- boolTrue = string "true" $> Scalar (Boolean True)- boolFalse = string "false" $> Scalar (Boolean False)--valueNumber :: Parser Value-valueNumber = Scalar . decodeScientific <$> scientific--enumValue :: Parser Value-enumValue = do- enum <- Enum <$> token- spaceAndComments- return enum--escaped :: Parser Char-escaped =- label "escaped" $ do- x <- anySingleBut '\"'- if x == '\\'- then choice (zipWith escapeChar codes replacements)- else pure x- where- replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']- codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']- escapeChar code replacement = char code >> return replacement--stringValue :: Parser Value-stringValue = label "stringValue" $ Scalar . String . pack <$> between (char '"') (char '"') (many escaped)--listValue :: Parser Value-listValue =- label "listValue" $- List <$>- between- (char '[' *> spaceAndComments)- (char ']' *> spaceAndComments)- (parseValue `sepBy` (char ',' *> spaceAndComments))--objectValue :: Parser Value-objectValue = label "objectValue" $ Object <$> setOf entry- where- entry = parseAssignment token parseValue
src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -9,22 +9,23 @@ , renderGraphQLDocument ) where -import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Semigroup ((<>))-import Data.Text (Text, intercalate)-import qualified Data.Text.Lazy as LT (fromStrict)-import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Semigroup ((<>))+import Data.Text (Text, intercalate)+import qualified Data.Text.Lazy as LT (fromStrict)+import Data.Text.Lazy.Encoding (encodeUtf8) -- MORPHEUS-import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataKind (..), DataLeaf (..),- DataTyCon (..), DataTypeLib, DataTypeWrapper (..), Key,- TypeAlias (..), WrapperD (..), allDataTypes, isVisible,- toGQLWrapper)+import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataKind (..), DataLeaf (..),+ DataTyCon (..), DataTypeLib, DataTypeWrapper (..), Key,+ TypeAlias (..), WrapperD (..), allDataTypes, isDefaultTypeName,+ toGQLWrapper)+import Data.Morpheus.Types.Internal.Value (convertToJSONName) renderGraphQLDocument :: DataTypeLib -> ByteString renderGraphQLDocument lib = encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map render visibleTypes where- visibleTypes = filter (isVisible . snd) (allDataTypes lib)+ visibleTypes = filter (not . isDefaultTypeName . fst) (allDataTypes lib) class RenderGQL a where render :: a -> Key@@ -58,12 +59,16 @@ render (name, InputUnion DataTyCon {typeData}) = "input " <> name <> render (mapKeys typeData) render (name, OutputObject DataTyCon {typeData}) = "type " <> name <> render typeData +mapKeys :: [DataField] -> [(Text, DataField)]+mapKeys = map (\x -> (fieldName x, x))+ -- OBJECT instance RenderGQL [(Text, DataField)] where render = renderObject renderField . ignoreHidden where renderField :: (Text, DataField) -> Text- renderField (key, DataField {fieldType, fieldArgs}) = key <> renderArgs fieldArgs <> ": " <> render fieldType+ renderField (key, DataField {fieldType, fieldArgs}) =+ convertToJSONName key <> renderArgs fieldArgs <> ": " <> render fieldType where renderArgs [] = "" renderArgs list = "(" <> intercalate ", " (map renderField list) <> ")"@@ -73,9 +78,6 @@ renderIndent :: Text renderIndent = " "--mapKeys :: [DataField] -> [(Text, DataField)]-mapKeys = map (\x -> (fieldName x, x)) renderObject :: (a -> Text) -> [a] -> Text renderObject f list = " { \n " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"
src/Data/Morpheus/Rendering/RenderIntrospection.hs view
@@ -182,7 +182,7 @@ createFieldWith :: Monad m => Text -> S__Type m -> [S__InputValue m] -> S__Field m createFieldWith _name fieldType fieldArgs = S__Field- { s__FieldName = constRes $ convertToJSONName _name+ { s__FieldName = constRes (convertToJSONName _name) , s__FieldDescription = constRes Nothing , s__FieldArgs = constRes fieldArgs , s__FieldType' = constRes fieldType@@ -193,7 +193,7 @@ createInputValueWith :: Monad m => Text -> S__Type m -> S__InputValue m createInputValueWith name ivType = S__InputValue- { s__InputValueName = constRes name+ { s__InputValueName = constRes (convertToJSONName name) , s__InputValueDescription = constRes Nothing , s__InputValueType' = constRes ivType , s__InputValueDefaultValue = constRes Nothing
src/Data/Morpheus/Schema/Schema.hs view
@@ -29,6 +29,7 @@ type S__TypeKind = TypeKind [gqlDocumentNamespace|+ type __Schema { types: [__Type!]! queryType: __Type!@@ -43,7 +44,7 @@ description: String # OBJECT and INTERFACE only- fields(includeDeprecated: Boolean ): [__Field!]+ fields(includeDeprecated: Boolean = false): [__Field!] # OBJECT only interfaces: [__Type!]@@ -52,7 +53,7 @@ possibleTypes: [__Type!] # ENUM only- enumValues(includeDeprecated: Boolean): [__EnumValue!]+ enumValues(includeDeprecated: Boolean = false): [__EnumValue!] # INPUT_OBJECT only inputFields: [__InputValue!]@@ -99,7 +100,6 @@ FRAGMENT_DEFINITION FRAGMENT_SPREAD INLINE_FRAGMENT- VARIABLE_DEFINITION SCHEMA SCALAR OBJECT@@ -113,8 +113,9 @@ INPUT_FIELD_DEFINITION } - type Root {- __type(name: String!): __Type- __schema : __Schema!- }+type Root {+ __type(name: String!): __Type+ __schema : __Schema!+}+ |]
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -11,18 +11,19 @@ ) where import Data.Proxy-import Data.Text (Text)+import Data.Text (Text) -- MORPHEUS-import Data.Morpheus.Execution.Server.Introspect (ObjectFields (..), TypeUpdater, introspect, resolveTypes)-import Data.Morpheus.Rendering.RenderIntrospection (createObjectType, render)-import Data.Morpheus.Schema.Schema (Root (..), Root__typeArgs (..), S__Schema (..), S__Type)-import Data.Morpheus.Types (constRes)-import Data.Morpheus.Types.GQLType (CUSTOM)-import Data.Morpheus.Types.ID (ID)-import Data.Morpheus.Types.Internal.Data (DataField (..), DataObject, DataTypeLib (..),- allDataTypes)-import Data.Morpheus.Types.Resolver (GQLFail (..), ResolveT, Resolver)+import Data.Morpheus.Execution.Internal.GraphScanner (resolveUpdates)+import Data.Morpheus.Execution.Server.Introspect (ObjectFields (..), TypeUpdater, introspect)+import Data.Morpheus.Rendering.RenderIntrospection (createObjectType, render)+import Data.Morpheus.Schema.Schema (Root (..), Root__typeArgs (..), S__Schema (..), S__Type)+import Data.Morpheus.Types (constRes)+import Data.Morpheus.Types.GQLType (CUSTOM)+import Data.Morpheus.Types.ID (ID)+import Data.Morpheus.Types.Internal.Data (DataField (..), DataObject, DataTypeLib (..),+ allDataTypes)+import Data.Morpheus.Types.Resolver (GQLFail (..), ResolveT, Resolver) convertTypes :: Monad m => DataTypeLib -> (Resolver m) [S__Type (Resolver m)] convertTypes lib = traverse (`render` lib) (allDataTypes lib)@@ -58,7 +59,7 @@ defaultTypes :: TypeUpdater defaultTypes = flip- resolveTypes+ resolveUpdates [ introspect (Proxy @Bool) , introspect (Proxy @Int) , introspect (Proxy @Float)
src/Data/Morpheus/Schema/TypeKind.hs view
@@ -9,13 +9,12 @@ import Data.Aeson (FromJSON (..)) import Data.Morpheus.Kind (ENUM)-import Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName, __typeVisibility))+import Data.Morpheus.Types.GQLType (GQLType (KIND, __typeName)) import GHC.Generics instance GQLType TypeKind where type KIND TypeKind = ENUM __typeName = const "__TypeKind"- __typeVisibility = const False data TypeKind = SCALAR
src/Data/Morpheus/Types/GQLType.hs view
@@ -75,8 +75,6 @@ type CUSTOM a = FALSE description :: Proxy a -> Maybe Text description _ = Nothing- __typeVisibility :: Proxy a -> Bool- __typeVisibility = const True __typeName :: Proxy a -> Text default __typeName :: (Typeable a) => Proxy a -> Text@@ -96,21 +94,17 @@ instance GQLType Int where type KIND Int = SCALAR- __typeVisibility = const False instance GQLType Float where type KIND Float = SCALAR- __typeVisibility = const False instance GQLType Text where type KIND Text = SCALAR __typeName = const "String"- __typeVisibility = const False instance GQLType Bool where type KIND Bool = SCALAR __typeName = const "Boolean"- __typeVisibility = const False instance GQLType a => GQLType (Maybe a) where type KIND (Maybe a) = WRAPPER
src/Data/Morpheus/Types/ID.hs view
@@ -8,7 +8,7 @@ import Data.Morpheus.Kind (SCALAR) import Data.Morpheus.Types.GQLScalar (GQLScalar (..))-import Data.Morpheus.Types.GQLType (GQLType (KIND, __typeVisibility))+import Data.Morpheus.Types.GQLType (GQLType (KIND)) import Data.Morpheus.Types.Internal.Value (ScalarValue (..)) import Data.Text (Text, pack) import GHC.Generics (Generic)@@ -22,7 +22,6 @@ instance GQLType ID where type KIND ID = SCALAR- __typeVisibility _ = False instance GQLScalar ID where parseValue (Int x) = return (ID $ pack $ show x)
src/Data/Morpheus/Types/Internal/AST/Operation.hs view
@@ -9,6 +9,7 @@ , RawOperation , VariableDefinitions , ValidVariables+ , DefaultValue ) where import Data.Morpheus.Types.Internal.AST.RawSelection (RawSelectionSet)@@ -19,8 +20,10 @@ import Data.Morpheus.Types.Internal.Value (Value) import Language.Haskell.TH.Syntax (Lift (..)) -type VariableDefinitions = Collection (Variable ())+type DefaultValue = Maybe Value +type VariableDefinitions = Collection (Variable DefaultValue)+ type ValidVariables = Collection (Variable Value) type ValidOperation = Operation Arguments SelectionSet@@ -47,5 +50,5 @@ , variableValue :: a } deriving (Show) -instance Lift (Variable ()) where+instance Lift a => Lift (Variable a) where lift (Variable t ir w p v) = apply 'Variable [liftText t, lift ir, lift w, lift p, lift v]
src/Data/Morpheus/Types/Internal/Data.hs view
@@ -49,9 +49,12 @@ , isNullable , toGQLWrapper , isWeaker- , isVisible , isSubscription , isOutputObject+ , sysTypes+ , isDefaultTypeName+ , isSchemaTypeName+ , isPrimitiveTypeName , OperationKind(..) ) where @@ -65,6 +68,19 @@ import Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap) import Data.Morpheus.Types.Internal.Value (Value (..)) +isDefaultTypeName :: Key -> Bool+isDefaultTypeName x = isSchemaTypeName x || isPrimitiveTypeName x++isSchemaTypeName :: Key -> Bool+isSchemaTypeName = (`elem` sysTypes)++isPrimitiveTypeName :: Key -> Bool+isPrimitiveTypeName = (`elem` ["String", "Float", "Int", "Boolean", "ID"])++sysTypes :: [Key]+sysTypes =+ ["__Schema", "__Type", "__Directive", "__TypeKind", "__Field", "__DirectiveLocation", "__InputValue", "__EnumValue"]+ data OperationKind = Query | Subscription@@ -203,7 +219,6 @@ { typeName :: Key , typeFingerprint :: DataFingerprint , typeDescription :: Maybe Key- , typeVisibility :: Bool , typeData :: a } deriving (Show) @@ -294,9 +309,6 @@ fromDataType f (InputObject dt) = f dt {typeData = ()} fromDataType f (InputUnion dt) = f dt {typeData = ()} fromDataType f (OutputObject dt) = f dt {typeData = ()}--isVisible :: DataFullType -> Bool-isVisible = fromDataType typeVisibility isTypeDefined :: Key -> DataTypeLib -> Maybe DataFingerprint isTypeDefined name lib = fromDataType typeFingerprint <$> lookupDataType name lib
src/Data/Morpheus/Types/Internal/DataD.hs view
@@ -13,21 +13,22 @@ -- MORPHEUS import Data.Morpheus.Types.Internal.Data (DataField, DataTypeKind) +data QueryD = QueryD+ { queryText :: String+ , queryTypes :: [GQLTypeD]+ , queryArgsType :: Maybe TypeD+ } deriving (Show, Lift)+ data GQLTypeD = GQLTypeD { typeD :: TypeD , typeKindD :: DataTypeKind , typeArgD :: [TypeD] } deriving (Show, Lift) -data QueryD = QueryD- { queryText :: String- , queryTypes :: [TypeD]- , queryArgTypes :: [TypeD]- } deriving (Show, Lift)- data TypeD = TypeD- { tName :: String- , tCons :: [ConsD]+ { tName :: String+ , tNamespace :: [String]+ , tCons :: [ConsD] } deriving (Show, Lift) data ConsD = ConsD
src/Data/Morpheus/Types/Internal/TH.hs view
@@ -32,3 +32,7 @@ instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type instanceHeadMultiT className iType li = applyT className (iType : li)++-- "User" -> ["name","id"] -> (User name id)+destructRecord :: String -> [String] -> PatQ+destructRecord conName fields = conP (mkName conName) (map (varP . mkName) fields)
src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -9,7 +9,6 @@ , Validation , ResolveT , failResolveT- , SchemaValidation , ResolveValue ) where @@ -33,8 +32,6 @@ } deriving (Show, Generic, FromJSON, ToJSON) type Validation = Either GQLErrors--type SchemaValidation = Validation type ResolveT = ExceptT GQLErrors
+ src/Data/Morpheus/Validation/Internal/Value.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Morpheus.Validation.Internal.Value+ ( validateInputValue+ , validateEnum+ ) where++import Data.List (elem)++-- MORPHEUS+import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))+import Data.Morpheus.Rendering.RenderGQL (renderWrapped)+import Data.Morpheus.Types.Internal.Data (DataField (..), DataKind (..), DataTyCon (..),+ DataTypeLib (..), DataValidator (..), Key, TypeAlias (..),+ WrapperD (..), isNullable)+import Data.Morpheus.Types.Internal.Value (Value (..))+import Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField)++-- Validate Variable Argument or all Possible input Values+validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataKind -> (Key, Value) -> InputValidation Value+validateInputValue lib prop' = validate+ where+ throwError :: [WrapperD] -> DataKind -> Value -> InputValidation Value+ throwError wrappers type' value' = Left $ UnexpectedType prop' (renderWrapped type' wrappers) value' Nothing+ -- VALIDATION+ validate :: [WrapperD] -> DataKind -> (Key, Value) -> InputValidation Value+ -- Validate Null. value = null ?+ validate wrappers tName (_, Null)+ | isNullable wrappers = return Null+ | otherwise = throwError wrappers tName Null+ -- Validate LIST+ validate (MaybeD:wrappers) type' value' = validateInputValue lib prop' wrappers type' value'+ validate (ListD:wrappers) type' (key', List list') = List <$> mapM validateElement list'+ where+ validateElement element' = validateInputValue lib prop' wrappers type' (key', element')+ {-- 2. VALIDATE TYPES, all wrappers are already Processed --}+ {-- VALIDATE OBJECT--}+ validate [] (ObjectKind DataTyCon {typeData = parentFields'}) (_, Object fields) =+ Object <$> mapM validateField fields+ where+ validateField (_name, value) = do+ (type', currentProp') <- validationData value+ wrappers' <- aliasWrappers . fieldType <$> getField+ value'' <- validateInputValue lib currentProp' wrappers' type' (_name, value)+ return (_name, value'')+ where+ validationData x = do+ fieldTypeName' <- aliasTyCon . fieldType <$> getField+ let currentProp = prop' ++ [Prop _name fieldTypeName']+ type' <- getInputType fieldTypeName' lib (typeMismatch x fieldTypeName' currentProp)+ return (type', currentProp)+ getField = lookupField _name parentFields' (UnknownField prop' _name)+ -- VALIDATE INPUT UNION+ -- TODO: Validate Union+ validate [] (UnionKind DataTyCon {typeData}) (_, Object fields) = return (Object fields)+ {-- VALIDATE SCALAR --}+ validate [] (EnumKind DataTyCon {typeData = tags', typeName = name'}) (_, value') =+ validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'+ {-- VALIDATE ENUM --}+ validate [] (ScalarKind DataTyCon {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =+ case validator' value' of+ Right _ -> return value'+ Left "" -> Left $ UnexpectedType prop' name' value' Nothing+ Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage)+ {-- 3. THROW ERROR: on invalid values --}+ validate wrappers' type' (_, value') = throwError wrappers' type' value'++validateEnum :: error -> [Key] -> Value -> Either error Value+validateEnum error' tags' (Enum enumValue) =+ if enumValue `elem` tags'+ then pure (Enum enumValue)+ else Left error'+validateEnum error' _ _ = Left error'++typeMismatch :: Value -> Key -> [Prop] -> InputError+typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing
src/Data/Morpheus/Validation/Query/Arguments.hs view
@@ -20,7 +20,7 @@ import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Internal.Value (Value (Null)) import Data.Morpheus.Validation.Internal.Utils (checkForUnknownKeys, checkNameCollision, getInputType)-import Data.Morpheus.Validation.Query.Input.Object (validateInputValue)+import Data.Morpheus.Validation.Internal.Value (validateInputValue) import Data.Text (Text) resolveArgumentVariables :: Text -> ValidVariables -> DataField -> RawArguments -> Validation Arguments
− src/Data/Morpheus/Validation/Query/Input/Enum.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Validation.Query.Input.Enum- ( validateEnum- ) where--import Data.List (elem)-import Data.Morpheus.Types.Internal.Value (Value (..))-import Data.Text (Text)--validateEnum :: error -> [Text] -> Value -> Either error Value-validateEnum error' tags' (Enum enumValue) =- if enumValue `elem` tags'- then pure (Enum enumValue)- else Left error'-validateEnum error' _ _ = Left error'
− src/Data/Morpheus/Validation/Query/Input/Object.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Validation.Query.Input.Object- ( validateInputValue- ) where--import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))-import Data.Morpheus.Rendering.RenderGQL (renderWrapped)-import Data.Morpheus.Types.Internal.Data (DataField (..), DataKind (..), DataTyCon (..),- DataTypeLib (..), DataValidator (..), TypeAlias (..),- WrapperD (..), isNullable)-import Data.Morpheus.Types.Internal.Value (Value (..))-import Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField)-import Data.Morpheus.Validation.Query.Input.Enum (validateEnum)-import Data.Text (Text)--typeMismatch :: Value -> Text -> [Prop] -> InputError-typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing---- Validate Variable Argument or all Possible input Values-validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataKind -> (Text, Value) -> InputValidation Value-validateInputValue lib prop' = validate- where- throwError :: [WrapperD] -> DataKind -> Value -> InputValidation Value- throwError wrappers type' value' = Left $ UnexpectedType prop' (renderWrapped type' wrappers) value' Nothing- -- VALIDATION- validate :: [WrapperD] -> DataKind -> (Text, Value) -> InputValidation Value- -- Validate Null. value = null ?- validate wrappers tName (_, Null)- | isNullable wrappers = return Null- | otherwise = throwError wrappers tName Null- -- Validate LIST- validate (MaybeD:wrappers) type' value' = validateInputValue lib prop' wrappers type' value'- validate (ListD:wrappers) type' (key', List list') = List <$> mapM validateElement list'- where- validateElement element' = validateInputValue lib prop' wrappers type' (key', element')- {-- 2. VALIDATE TYPES, all wrappers are already Processed --}- {-- VALIDATE OBJECT--}- validate [] (ObjectKind DataTyCon {typeData = parentFields'}) (_, Object fields) =- Object <$> mapM validateField fields- where- validateField (_name, value) = do- (type', currentProp') <- validationData value- wrappers' <- aliasWrappers . fieldType <$> getField- value'' <- validateInputValue lib currentProp' wrappers' type' (_name, value)- return (_name, value'')- where- validationData x = do- fieldTypeName' <- aliasTyCon . fieldType <$> getField- let currentProp = prop' ++ [Prop _name fieldTypeName']- type' <- getInputType fieldTypeName' lib (typeMismatch x fieldTypeName' currentProp)- return (type', currentProp)- getField = lookupField _name parentFields' (UnknownField prop' _name)- -- VALIDATE INPUT UNION- -- TODO: Validate Union- validate [] (UnionKind DataTyCon {typeData}) (_, Object fields) = return (Object fields)- {-- VALIDATE SCALAR --}- validate [] (EnumKind DataTyCon {typeData = tags', typeName = name'}) (_, value') =- validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'- {-- VALIDATE ENUM --}- validate [] (ScalarKind DataTyCon {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =- case validator' value' of- Right _ -> return value'- Left "" -> Left $ UnexpectedType prop' name' value' Nothing- Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage)- {-- 3. THROW ERROR: on invalid values --}- validate wrappers' type' (_, value') = throwError wrappers' type' value'
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -7,11 +7,11 @@ import Data.List ((\\)) import qualified Data.Map as M (lookup) import Data.Maybe (maybe)-import Data.Morpheus.Error.Input (InputValidation, inputErrorMessage)+import Data.Morpheus.Error.Input (inputErrorMessage) import Data.Morpheus.Error.Variable (uninitializedVariable, unknownType, unusedVariables, variableGotInvalidValue)-import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, ValidVariables,- Variable (..))+import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), RawOperation,+ ValidVariables, Variable (..)) import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawArgument (..), RawSelection (..), RawSelection' (..), RawSelectionSet, Reference (..))@@ -21,8 +21,8 @@ import Data.Morpheus.Types.Internal.Value (Value (..)) import Data.Morpheus.Types.Types (Variables) import Data.Morpheus.Validation.Internal.Utils (VALIDATION_MODE (..), getInputType)+import Data.Morpheus.Validation.Internal.Value (validateInputValue) import Data.Morpheus.Validation.Query.Fragment (getFragment)-import Data.Morpheus.Validation.Query.Input.Object (validateInputValue) import Data.Semigroup ((<>)) import Data.Text (Text) @@ -31,16 +31,6 @@ where error' = unknownType type' position' -lookupVariable :: Variables -> Text -> (Text -> error) -> Either error Value-lookupVariable variables' key' error' =- case M.lookup key' variables' of- Nothing -> Left $ error' key'- Just value -> pure value--handleInputError :: Text -> Position -> InputValidation Value -> Validation (Text, Value)-handleInputError key' position' (Left error') = Left $ variableGotInvalidValue key' (inputErrorMessage error') position'-handleInputError key' _ (Right value') = pure (key', value')- concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f @@ -71,7 +61,7 @@ allVariableReferences lib [operationSelection] >>= checkUnusedVariables mapM (lookupAndValidateValueOnBody typeLib root validationMode) operationArgs where- varToKey :: (Text, Variable ()) -> EnhancedKey+ varToKey :: (Text, Variable a) -> EnhancedKey varToKey (key', Variable {variablePosition}) = EnhancedKey key' variablePosition -- checkUnusedVariables :: [EnhancedKey] -> Validation ()@@ -81,21 +71,29 @@ unused' -> Left $ unusedVariables operationName unused' lookupAndValidateValueOnBody ::- DataTypeLib -> Variables -> VALIDATION_MODE -> (Text, Variable ()) -> Validation (Text, Variable Value)+ DataTypeLib -> Variables -> VALIDATION_MODE -> (Text, Variable DefaultValue) -> Validation (Text, Variable Value) lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType , variablePosition , isVariableRequired , variableTypeWrappers+ , variableValue = defaultValue }) =- toVariable <$>- (getVariableType variableType variablePosition typeLib >>=- checkType (validationMode /= WITHOUT_VARIABLES && isVariableRequired))+ toVariable <$> (getVariableType variableType variablePosition typeLib >>= checkType getVariable defaultValue) where toVariable (varKey, variableValue) = (varKey, var {variableValue})+ getVariable = M.lookup key bodyVariables ------------------------------------------------------------------- checkType True varType =- lookupVariable bodyVariables key (uninitializedVariable variablePosition variableType) >>= validator varType- checkType False varType = maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)+ checkType (Just variable) Nothing varType = validator varType variable+ checkType (Just variable) (Just defValue) varType = validator varType defValue >> validator varType variable+ checkType Nothing (Just defValue) varType = validator varType defValue+ checkType Nothing Nothing varType+ | validationMode /= WITHOUT_VARIABLES && isVariableRequired =+ Left $ uninitializedVariable variablePosition variableType key+ | otherwise = returnNull+ where+ returnNull = maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables) ----------------------------------------------------------------------------------------------- validator varType varValue =- handleInputError key variablePosition $ validateInputValue typeLib [] variableTypeWrappers varType (key, varValue)+ case validateInputValue typeLib [] variableTypeWrappers varType (key, varValue) of+ Left message -> Left $ variableGotInvalidValue key (inputErrorMessage message) variablePosition+ Right value -> pure (key, value)
test/Feature/Holistic/API.hs view
@@ -11,6 +11,7 @@ module Feature.Holistic.API ( api+ , rootResolver ) where import Data.Morpheus (interpreter)
test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json view
@@ -43,11 +43,6 @@ "deprecationReason": null }, {- "name": "VARIABLE_DEFINITION",- "isDeprecated": false,- "deprecationReason": null- },- { "name": "SCHEMA", "isDeprecated": false, "deprecationReason": null
test/Feature/InputType/cases.json view
@@ -20,16 +20,28 @@ "description": "fail when: variable is defined by the operation but can't found on request body" }, {- "path": "variables/nullableVariable",+ "path": "variables/valueNotProvided/nullableVariable", "description": "don't fail when: variable is defined by the operation but can't found on request body" }, {+ "path": "variables/valueNotProvided/nonNullVariableWithDefaultValue",+ "description": "don't fail when: not nullable variable was not provided but has default value"+ },+ { "path": "variables/invalidValue/invalidListVariable", "description": "fail when: variable receives invalid List value" }, { "path": "variables/invalidValue/nestedListNonNullListReceivedNull", "description": "fail: if list of nonNull elements receives null"+ },+ {+ "path": "variables/invalidValue/invalidDefaultValue",+ "description": "fail: if default value is incompatible"+ },+ {+ "path": "variables/invalidValue/invalidDefaultValueButVariableProvided",+ "description": "fail: if default value is incompatible eve if correct variable value was provided" }, { "path": "variables/nestedListNullableListReceivedNull",
+ test/Feature/InputType/variables/invalidValue/invalidDefaultValue/query.gql view
@@ -0,0 +1,5 @@+query invalidListVariable($v1: [[[Int!]!]]! = { id: "12" }) {+ q1 {+ a2(argList: [], argNestedList: $v1)+ }+}
+ test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json view
@@ -0,0 +1,13 @@+{+ "errors": [+ {+ "message": "Variable \"$v1\" got invalid value; Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.",+ "locations": [+ {+ "line": 1,+ "column": 27+ }+ ]+ }+ ]+}
+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql view
@@ -0,0 +1,5 @@+query invalidListVariable($v1: [[[Int!]!]]! = [["boo"]]) {+ q1 {+ a2(argList: [], argNestedList: $v1)+ }+}
+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json view
@@ -0,0 +1,13 @@+{+ "errors": [+ {+ "message": "Variable \"$v1\" got invalid value; Expected type \"[Int!]!\" found \"boo\".",+ "locations": [+ {+ "line": 1,+ "column": 27+ }+ ]+ }+ ]+}
+ test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/variables.json view
@@ -0,0 +1,3 @@+{+ "v1": []+}
− test/Feature/InputType/variables/nullableVariable/query.gql
@@ -1,5 +0,0 @@-query TestNullableVariable($i1: Int) {- q1 {- a1(arg1:"",arg2: $i1)- }-}
− test/Feature/InputType/variables/nullableVariable/response.json
@@ -1,7 +0,0 @@-{- "data": {- "q1": {- "a1": "a1Test"- }- }-}
+ test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql view
@@ -0,0 +1,5 @@+query TestNonNullVariable($i1: String! = "hello world") {+ q1 {+ a1(arg1: $i1)+ }+}
+ test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "q1": {+ "a1": "a1Test"+ }+ }+}
+ test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql view
@@ -0,0 +1,5 @@+query TestNullableVariable($i1: Int) {+ q1 {+ a1(arg1:"",arg2: $i1)+ }+}
+ test/Feature/InputType/variables/valueNotProvided/nullableVariable/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "q1": {+ "a1": "a1Test"+ }+ }+}
+ test/Rendering/Schema.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Rendering.Schema+ ( schemaProxy+ ) where++import Data.Morpheus.Document (importGQLDocumentWithNamespace)+import Data.Morpheus.Kind (SCALAR)+import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), IORes,+ ScalarValue (..))+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic)++data TestScalar =+ TestScalar+ deriving (Show, Generic)++instance GQLType TestScalar where+ type KIND TestScalar = SCALAR++instance GQLScalar TestScalar where+ parseValue _ = pure TestScalar+ serialize TestScalar = Int 0++importGQLDocumentWithNamespace "test/Rendering/schema.gql"++schemaProxy :: Proxy (GQLRootResolver IO () () (Query IORes) () ())+schemaProxy = Proxy @(GQLRootResolver IO () () (Query IORes) () ())
+ test/Rendering/TestSchemaRendering.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Rendering.TestSchemaRendering+ ( testSchemaRendering+ ) where++import Data.Morpheus.Document (toGraphQLDocument)+import Rendering.Schema (schemaProxy)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertEqual, testCase)++-- TODO: better Test+testSchemaRendering :: TestTree+testSchemaRendering = testCase "Test Rendering" $ assertEqual "test schema Rendering" schema expected+ where+ schema = toGraphQLDocument schemaProxy+ expected =+ "type Query { \n user: User!\n testUnion: TestUnion\n}\n\nenum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\nscalar TestScalar\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\nunion TestUnion =\n User!\n | Address!"
+ test/Rendering/schema.gql view
@@ -0,0 +1,27 @@+enum TestEnum {+ EnumA+ EnumB+ EnumC+}++input Coordinates {+ latitude: TestScalar!+ longitude: Int!+}++union TestUnion = User | Address++type Address {+ street: [[[[String!]!]!]]+}++type User {+ type: String!+ address(coordinates: Coordinates!, type: String): Int!+ friend(id: ID! , cityID: TestEnum): User!+}++type Query {+ user: User!+ testUnion: TestUnion+}
test/Spec.hs view
@@ -4,14 +4,15 @@ ( main ) where -import qualified Feature.Holistic.API as Holistic (api)-import qualified Feature.Input.Enum.API as InputEnum (api)-import qualified Feature.InputType.API as InputType (api)-import qualified Feature.Schema.API as Schema (api)-import qualified Feature.UnionType.API as UnionType (api)-import qualified Feature.WrappedTypeName.API as TypeName (api)-import Test.Tasty (defaultMain, testGroup)-import TestFeature (testFeature)+import qualified Feature.Holistic.API as Holistic (api)+import qualified Feature.Input.Enum.API as InputEnum (api)+import qualified Feature.InputType.API as InputType (api)+import qualified Feature.Schema.API as Schema (api)+import qualified Feature.UnionType.API as UnionType (api)+import qualified Feature.WrappedTypeName.API as TypeName (api)+import Rendering.TestSchemaRendering (testSchemaRendering)+import Test.Tasty (defaultMain, testGroup)+import TestFeature (testFeature) main :: IO () main = do@@ -21,4 +22,7 @@ schemaTest <- testFeature Schema.api "Feature/Schema" typeName <- testFeature TypeName.api "Feature/WrappedTypeName" inputEnum <- testFeature InputEnum.api "Feature/Input/Enum"- defaultMain (testGroup "Morpheus Graphql Tests" [ioTests, unionTest, inputTest, schemaTest, typeName, inputEnum])+ defaultMain+ (testGroup+ "Morpheus Graphql Tests"+ [ioTests, unionTest, inputTest, schemaTest, typeName, inputEnum, testSchemaRendering])