diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,15 +26,13 @@ _stack.yml_ ```yaml -resolver: lts-13.30 +resolver: lts-14.8 extra-deps: - - morpheus-graphql-0.4.0 - - aeson-1.4.4.0 - - time-compat-1.9.2.2 + - morpheus-graphql-0.5.0 ``` -As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack update` +As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update` ### Building your first GraphQL API @@ -77,10 +75,14 @@ importGQLDocumentWithNamespace "schema.gql" -rootResolver :: GQLRootResolver IO () () (Query IORes) () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - {queryResolver = return Query {queryDeity}, mutationResolver = pure (), subscriptionResolver = pure ()} + { + queryResolver = Query {queryDeity}, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } where queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower} where @@ -101,8 +103,8 @@ which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> IORes b`, representing resolving a set of arguments `a` to a concrete value `b`. ```haskell -data Query = Query - { deity :: DeityArgs -> IORes Deity +data Query m = Query + { deity :: DeityArgs -> m Deity } deriving (Generic, GQLType) data Deity = Deity @@ -119,8 +121,8 @@ } deriving (Generic) ``` -For each field in the `Query` type defined via `a -> IORes b` (like `deity`) we will define a resolver implementation that provides the values during runtime by referring to -some data source, e.g. a database or another API. Fields that are defined without `a -> IORes b` you can just provide a value. +For each field in the `Query` type defined via `a -> m b` (like `deity`) we will define a resolver implementation that provides the values during runtime by referring to +some data source, e.g. a database or another API. Fields that are defined without `a -> m b` you can just provide a value. In above example, the field of `DeityArgs` could also be named using reserved identities (such as: `type`, `where`, etc), in order to avoid conflict, a prime symbol (`'`) must be attached. For example, you can have: @@ -136,7 +138,7 @@ ```haskell resolveDeity :: DeityArgs -> IORes Deity -resolveDeity args = gqlResolver $ askDB (name args) (mythology args) +resolveDeity args = QueryResolver $ ExceptT $ askDB (name args) (mythology args) askDB :: Text -> Maybe Text -> IO (Either String Deity) askDB = ... @@ -147,12 +149,12 @@ To make this `Query` type available as an API, we define a `GQLRootResolver` and feed it to the Morpheus `interpreter`. A `GQLRootResolver` consists of `query`, `mutation` and `subscription` definitions, while we omit the latter for this example: ```haskell -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {deity = resolveDeity} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {deity = resolveDeity} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } gqlApi :: ByteString -> IO ByteString @@ -282,21 +284,21 @@ Just exchange deriving `GQLQuery` for `GQLMutation` and declare them separately at the `GQLRootResolver` definition ```haskell -newtype Mutation = Mutation - { createDeity :: Form -> IOMutRes Deity +newtype Mutation m = Mutation + { createDeity :: Form -> m Deity } deriving (Generic, GQLType) -createDeityMutation :: Form -> IOMutRes Deity +createDeityMutation :: Form -> m (Deity m) createDeityMutation = ... -rootResolver :: GQLRootResolver IO Query Mutation () +rootResolver :: GQLRootResolver IO Query Mutation Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {...} - , mutationResolver = return Mutation { + { queryResolver = Query {...} + , mutationResolver = Mutation { createDeity = createDeityMutation } - , subscriptionResolver = return () + , subscriptionResolver = Undefined } gqlApi :: ByteString -> IO ByteString @@ -311,7 +313,6 @@ every subscription has own Channel by which will be triggered ```haskell - data Channel = ChannelA | ChannelB @@ -320,32 +321,36 @@ = ContentA Int | ContentB Text -newtype Query = Query - { deity :: () -> IORes Deity - } deriving (Generic, GQLType) +newtype Query m = Query + { deity :: () -> m Deity + } deriving (Generic) -newtype Mutation = Mutation - { createDeity :: () -> IOMutRes Channel Content Deity - } deriving (Generic, GQLType) +newtype Mutation m = Mutation + { createDeity :: () -> m Deity + } deriving (Generic) -newtype Subscription = Subscription - { newDeity :: () -> IOSubRes Channel Content Deity - } deriving (Generic, GQLType) +newtype Subscription m = Subscription + { newDeity :: () -> m Deity + } deriving (Generic) -rootResolver :: GQLRootResolver IO Channel Content Query Mutation Subscription +type APIEvent = Event Channel Content + +rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = return Query {deity = const fetchDeity} - , mutationResolver = return Mutation {createDeity} - , subscriptionResolver = return Subscription {newDeity} + { queryResolver = Query {deity = const fetchDeity} + , mutationResolver = Mutation {createDeity} + , subscriptionResolver = Subscription {newDeity} } where - fetchDeity = resolver $ dbDeity "" Nothing - createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity - newDeity _args = SubResolver {subChannels = [ChannelA], subResolver} + createDeity _args = MutResolver events updateDeity + where + events = [Event {channels = [ChannelA], content = ContentA 1}] + updateDeity = updateDBDeity + newDeity _args = SubResolver [ChannelA] subResolver where - subResolver (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State - subResolver (Event [ChannelA] (ContentB value)) = resolver $ dbDeity value Nothing -- resolve New State + subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State + subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State subResolver _ = fetchDeity -- Resolve Old State ``` diff --git a/assets/simple.gql b/assets/simple.gql --- a/assets/simple.gql +++ b/assets/simple.gql @@ -1,42 +1,72 @@ +""" +my interface description +""" type Query { deity (name: [[[[[String!]]!]]], mythology: Realm): Deity! character (characterID: String! , age: Int ): Character! hero: Human! } +""" +my interface description +""" interface MyInterface { + """ + interface field description + """ name: String } + type Mutation { createDeity (name: [[[[[String!]]!]]], mythology: String): Deity! createCharacter (realm: Realm! , id: String! ): Character! } +""" +my unon description +""" union Character = Creature | Deity | Human +"my mutation description" type Deity { fullName: String! power: Power } +""" +my mutation description +some creature +""" type Creature { - creatureName: String! + name: String! realm: City! + immortality: Boolean! } +""" +human + +ewrw +""" type Human { humanName: String! lifetime: Lifetime! profession: Profession } + enum Profession { Priest Farmer Artist } +""" +human +ew jso +ewrw +""" input Realm { owner: String! age: Int @@ -44,11 +74,15 @@ profession: Profession } +"ancient city" enum City { Athens Ithaca Sparta Troy } +""" lifespan of mortal creatures """ scalar Lifetime + + scalar Power diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,64 @@ +## [0.5.0] - 31.10.2019 + +### Added + +- dummy support of `directives`, only parsing not actual implementation + +### Fixed + +- can be parsed `implements` with multiple interfaces separated by `&` +- can be parsed default value on `inputobject` +- Parser supports anonymous Operation: `query` , `mutation` , `subscription` + for example: + + ``` + mutation { + name + } + ``` + +- Morpheus client does not breaks on `Boolean` type, converts every GraphQL type `Boolean` to haskell `Bool` and GQL `String` to `Text` + +### Changed + +- Reduced `GQLRootResolver` signature : + + `GQLRootResolver IO () () Query () ()` -> `GQLRootResolver IO () Query () ()` + + `GQLRootResolver IO Channel Content Query Mutation Subscription` -> `GQLRootResolver IO APIEvent Query Mutation Subscription` + + where `APIEvent = Event Channel Content` + +- `GQLRootResolver` automatically assigns corresponding monad to GraphQL Types. + + you can write just: + + ```hs + GQLRootResolver IO APIEvent Query Mutation Subscription + ``` + + instead of: + + ```hs + GQLRootResolver IO APIEvent (Query (Resolver IO)) (Mutation (MutResolver IO ApiEvent) (Subscription (SubResolver IO ApiEvent)) + ``` + + where operations are generated by `importGQLDocument` or have form : + + ``` + data Query m = Query { + field1 :: Args -> m Field1, + .... + } + ``` + +- `()` was replaced with `Undefined` in `GQLRootResolver` for empty operations `mutation`, `subscription` + ``` + rootResolver :: GQLRootResolver IO () Query Undefined Undefined + ``` +- Root Operations `Query`, `Mutation`, `Subscription` are passed to root resolvers without boxing inside a monad. +- there are only 3 kind of resolvers `MutResolver`, `SubResolver` , `QueryResolver` defined by GADT `Resolver` + ## [0.4.0] - 09.10.2019 ## Changed diff --git a/examples/Client/Client.hs b/examples/Client/Client.hs --- a/examples/Client/Client.hs +++ b/examples/Client/Client.hs @@ -16,10 +16,12 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Morpheus.Client (Fetch (..), defineByDocumentFile, defineByIntrospectionFile, gql) import Data.Morpheus.Types (ScalarValue (..)) +import Data.Text (Text) defineByIntrospectionFile "./assets/introspection.json" [gql| + # Query Hero with Compile time Validation query GetUser ($coordinates: Coordinates!) { @@ -39,6 +41,7 @@ } |] + defineByDocumentFile "./assets/simple.gql" [gql| @@ -51,7 +54,8 @@ } character(characterID: $id ) { ...on Creature { - creatureName + name + immortality } ...on Human { lifetime @@ -60,7 +64,7 @@ } char2: character(characterID: $id ) { ...on Creature { - cName: creatureName + cName: name } ...on Human { lTime: lifetime @@ -69,6 +73,7 @@ } } |] + ioRes :: ByteString -> IO ByteString ioRes req = do diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -19,7 +19,7 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WebSockets as WaiWs import Network.WebSockets (defaultConnectionOptions) -import Sophisticated.API (Channel, Content, gqlRoot) +import Sophisticated.API (APIEvent, gqlRoot) import TH.Simple (thSimpleApi) import Web.Scotty (body, file, get, post, raw, scottyApp) @@ -33,7 +33,7 @@ where settings = Warp.setPort 3000 Warp.defaultSettings wsApp = gqlSocketApp gqlRoot - httpServer :: GQLState IO Channel Content -> IO Wai.Application + httpServer :: GQLState IO APIEvent -> IO Wai.Application httpServer state = scottyApp $ do post "/" $ raw =<< (liftIO . interpreter gqlRoot state =<< body) diff --git a/examples/Mythology/API.hs b/examples/Mythology/API.hs --- a/examples/Mythology/API.hs +++ b/examples/Mythology/API.hs @@ -5,16 +5,16 @@ ( mythologyApi ) where +import Control.Monad.Except (ExceptT (..)) import qualified Data.ByteString.Lazy.Char8 as B - import Data.Morpheus (interpreter) -import Data.Morpheus.Types (GQLRootResolver (..), GQLType, IORes, resolver) +import Data.Morpheus.Types (Resolver (..), IORes, GQLRootResolver (..), GQLType, Undefined (..)) import Data.Text (Text) import GHC.Generics (Generic) import Mythology.Character.Deity (Deity (..), dbDeity) -newtype Query = Query - { deity :: DeityArgs -> IORes Deity +newtype Query m = Query + { deity :: DeityArgs -> m Deity } deriving (Generic, GQLType) data DeityArgs = DeityArgs @@ -22,15 +22,15 @@ , mythology :: Maybe Text -- Optional Argument } deriving (Generic) -resolveDeity :: DeityArgs -> IORes Deity -resolveDeity args = resolver $ dbDeity (name args) (mythology args) +resolveDeity :: DeityArgs -> IORes e Deity +resolveDeity args = QueryResolver $ ExceptT $ dbDeity (name args) (mythology args) -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {deity = resolveDeity} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {deity = resolveDeity} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } mythologyApi :: B.ByteString -> IO B.ByteString diff --git a/examples/Sophisticated/API.hs b/examples/Sophisticated/API.hs --- a/examples/Sophisticated/API.hs +++ b/examples/Sophisticated/API.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -11,8 +12,7 @@ module Sophisticated.API ( gqlRoot - , Channel - , Content + , APIEvent ) where import Data.Map (Map) @@ -26,10 +26,10 @@ -- MORPHEUS import Data.Morpheus.Document (importGQLDocumentWithNamespace) import Data.Morpheus.Kind (INPUT_UNION, OBJECT, SCALAR) -import Data.Morpheus.Types (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, IOMutRes, - IORes, IOSubRes, Resolver, ScalarValue (..), SubResolver (..), constRes, - mutResolver, resolver) +import Data.Morpheus.Types (Event (..), GQLRootResolver (..), GQLScalar (..), GQLType (..), ID, QUERY, + Resolver (..), ScalarValue (..), constRes) + $(importGQLDocumentWithNamespace "examples/Sophisticated/api.gql") type AIntText = A (Int, Text) @@ -78,73 +78,59 @@ , contentMessage :: Text } -type MutRes = IOMutRes Channel Content +type APIEvent = (Event Channel Content) -type SubRes = IOSubRes Channel Content -gqlRoot :: GQLRootResolver IO Channel Content (Query IORes) (Mutation MutRes) (Subscription SubRes) +gqlRoot :: GQLRootResolver IO APIEvent Query Mutation Subscription gqlRoot = GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} where - queryResolver = - return - Query - { queryUser = const $ resolver fetchUser - , queryAnimal = \QueryAnimalArgs {queryAnimalArgsAnimal} -> return (pack $ show queryAnimalArgsAnimal) + queryResolver = Query + { queryUser = const fetchUser + , queryAnimal = \QueryAnimalArgs {queryAnimalArgsAnimal} -> pure (pack $ show queryAnimalArgsAnimal) , querySet = constRes $ S.fromList [1, 2] , queryMap = constRes $ M.fromList [("robin", 1), ("carl", 2)] , queryWrapped1 = constRes $ A (0, "") , queryWrapped2 = constRes $ A "" } ------------------------------------------------------------- - mutationResolver = return Mutation {mutationCreateAddress, mutationCreateUser} + mutationResolver = Mutation { mutationCreateUser , mutationCreateAddress } where mutationCreateUser _ = - mutResolver + MutResolver [Event [UPDATE_USER] (Update {contentID = 12, contentMessage = "some message for user"})] - fetchUser - --mutationCreateAddress :: () -> MutRes (Address MutRes) + (pure User + { userName = constRes "George" + , userEmail = constRes "George@email.com" + , userAddress = constRes mutationAddress + , userOffice = constRes Nothing + , userHome = constRes HH + , userEntity = constRes Nothing + }) + ------------------------- mutationCreateAddress _ = - mutResolver - [Event [UPDATE_ADDRESS] (Update {contentID = 10, contentMessage = "message for address"})] - (fetchAddress (Euro 1 0)) + MutResolver + [Event [UPDATE_ADDRESS] (Update {contentID = 10, contentMessage = "message for address"})] (pure mutationAddress) ---------------------------------------------------------------- - subscriptionResolver = return Subscription {subscriptionNewAddress, subscriptionNewUser} + subscriptionResolver = Subscription {subscriptionNewAddress, subscriptionNewUser} where - subscriptionNewUser () = SubResolver {subChannels = [UPDATE_USER], subResolver} + subscriptionNewUser () = SubResolver [UPDATE_USER] subResolver where - subResolver (Event _ Update {}) = resolver fetchUser - subscriptionNewAddress () = SubResolver {subChannels = [UPDATE_ADDRESS], subResolver} + subResolver (Event _ Update {}) = fetchUser + subscriptionNewAddress () = SubResolver [UPDATE_ADDRESS] subResolver where - subResolver (Event _ Update {contentID}) = resolver $ fetchAddress (Euro contentID 0) - -fetchAddress :: Monad m => Euro -> m (Either String (Address (Resolver m))) -fetchAddress _ = - return $ Right Address {addressCity = constRes "", addressStreet = constRes "", addressHouseNumber = constRes 0} - -fetchUser :: Monad m => m (Either String (User (Resolver m))) -fetchUser = - return $ - Right $ - User - { userName = constRes "George" - , userEmail = constRes "George@email.com" - , userAddress = const resolveAddress - , userOffice = resolveOffice - , userHome = constRes HH - , userEntity = constRes $ MyUnionUser unionUser - } - where - unionAddress = - Address {addressCity = constRes "Hamburg", addressStreet = constRes "Street", addressHouseNumber = constRes 20} - -- Office - resolveOffice _officeArgs = resolver $ fetchAddress (Euro 1 1) - resolveAddress = resolver $ fetchAddress (Euro 1 0) - unionUser = - User - { userName = constRes "David" - , userEmail = constRes "David@email.com" - , userAddress = const resolveAddress - , userOffice = resolveOffice - , userHome = constRes BLN - , userEntity = const $ return $ MyUnionAddress unionAddress + subResolver (Event _ Update {contentID}) = fetchAddress + ---------------------------------------------------------------------------------------------- + fetchAddress = pure Address {addressCity = constRes "", addressStreet = constRes "", addressHouseNumber = constRes 0} + fetchUser :: Resolver QUERY IO (Event Channel Content) (User (Resolver QUERY IO (Event Channel Content))) + fetchUser = pure User { userName = constRes "George" + , userEmail = constRes "George@email.com" + , userAddress = const fetchAddress + , userOffice = constRes Nothing + , userHome = constRes HH + , userEntity = constRes Nothing + } + mutationAddress = Address { + addressCity = constRes "", + addressStreet = constRes "", + addressHouseNumber = constRes 0 } diff --git a/examples/Sophisticated/api.gql b/examples/Sophisticated/api.gql --- a/examples/Sophisticated/api.gql +++ b/examples/Sophisticated/api.gql @@ -1,11 +1,11 @@ # for Input Union -input Cat { +input Cat @testDir { name: String! } input Dog { - name: String! + name: String! @testDirective(testName:"") } input Bird { @@ -14,35 +14,62 @@ # Main APi -enum CityID { +enum CityID @enumDir { + """ + temporary multiline Test for Enum field descripions + + """ Paris - BLN - HH + BLN @testDirective(testName:"") + "temporary singleline Test for Enum field descripions" + HH @enumFieldDir } input Coordinates { - latitude: Euro! + latitude: Euro! @testDirective(testName:"") + "temporary singleline Test for input object field descripions" longitude: [[[UniqueID!]!]]! } input UniqueID { - type: String, + """ + temporary multiline Test for Enum field descripions + + """ + type: String = "test default value" id: String! } -type Address { - city: String! +type Address @typeDirective(id:1) { + """ + temporary multiline Test for Enum field descripions + + """ + city: String! @deprecated(testName:"",testName2: 123) street: String! + "temporary singleline Test for input object field descripions" houseNumber: Int! } +""" +my custom description for user +""" type User { name: String! email: String! - address(coordinates: Coordinates!, comment: String): Address! - office(zipCode: [[[ID!]]!], id: CityID!): Address! - entity: MyUnion! + address( + """ + temporary multiline Test for + arguments + descripions + """ + coordinates: Coordinates! @argsDirective(id:1) , + "temporary singleline Test for input object field descripions" + comment: String = "test default value" + ): Address! home: CityID! + office(zipCode: [[[ID!]]!], id: CityID!): Address + entity: MyUnion } union MyUnion = User | Address diff --git a/examples/Subscription/SimpleSubscription.hs b/examples/Subscription/SimpleSubscription.hs --- a/examples/Subscription/SimpleSubscription.hs +++ b/examples/Subscription/SimpleSubscription.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings , ScopedTypeVariables , RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Subscription.SimpleSubscription where -import Data.Morpheus.Types (Event (..), GQLRootResolver (..), IOMutRes, IORes, IOSubRes, - SubResolver (..), resolver, toMutResolver) +import Data.Morpheus.Types (Event (..), Resolver (..), GQLRootResolver (..)) import Data.Text (Text) import GHC.Generics (Generic) -import Mythology.Character.Deity (Deity (..), dbDeity) +import Mythology.Character.Deity (Deity (..)) +import Mythology.Place.Places (Realm (..)) +-- TODO: importGQLDocument "examples/Subscription/api.gql" +-- data Channel = ChannelA | ChannelB @@ -18,30 +23,45 @@ = ContentA Int | ContentB Text -newtype Query = Query - { deity :: () -> IORes Deity +type MyEvent = Event Channel Content + +newtype Query m = Query + { deity :: () -> m Deity } deriving (Generic) -newtype Mutation = Mutation - { createDeity :: () -> IOMutRes Channel Content Deity +newtype Mutation m = Mutation + { createDeity :: () -> m Deity } deriving (Generic) -newtype Subscription = Subscription - { newDeity :: () -> IOSubRes Channel Content Deity +newtype Subscription (m :: * -> * ) = Subscription + { newDeity :: () -> m Deity } deriving (Generic) -rootResolver :: GQLRootResolver IO Channel Content Query Mutation Subscription +type APIEvent = Event Channel Content + +rootResolver :: GQLRootResolver IO APIEvent Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = return Query {deity = const fetchDeity} - , mutationResolver = return Mutation {createDeity} - , subscriptionResolver = return Subscription {newDeity} + { queryResolver = Query {deity = const fetchDeity} + , mutationResolver = Mutation {createDeity} + , subscriptionResolver = Subscription {newDeity} } where - fetchDeity = resolver $ dbDeity "" Nothing - createDeity _args = toMutResolver [Event {channels = [ChannelA], content = ContentA 1}] fetchDeity - newDeity _args = SubResolver {subChannels = [ChannelA], subResolver} + -- TODO: resolver $ dbDeity "" Nothing + createDeity _args = MutResolver [Event {channels = [ChannelA], content = ContentA 1}] + (pure Deity { + fullName = "" + , power = Nothing + , realm = Sky + }) + newDeity _args = SubResolver [ChannelA] subResolver where - subResolver (Event [ChannelA] (ContentA _value)) = resolver $ dbDeity "" Nothing -- resolve New State - subResolver (Event [ChannelA] (ContentB value)) = resolver $ dbDeity value Nothing -- resolve New State + subResolver (Event [ChannelA] (ContentA _value)) = fetchDeity -- resolve New State + subResolver (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State subResolver _ = fetchDeity -- Resolve Old State + --------------------------------------------------------- + fetchDeity = pure Deity { + fullName = "" + , power = Nothing + , realm = Sky + } diff --git a/examples/Subscription/api.gql b/examples/Subscription/api.gql new file mode 100644 --- /dev/null +++ b/examples/Subscription/api.gql @@ -0,0 +1,11 @@ +type Query { + deity: Deity +} + +type Mutation { + createDeity: Deity +} + +type Subscription { + newDeity: Deity +} diff --git a/examples/TH/Simple.hs b/examples/TH/Simple.hs --- a/examples/TH/Simple.hs +++ b/examples/TH/Simple.hs @@ -16,15 +16,19 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocumentWithNamespace) -import Data.Morpheus.Types (GQLRootResolver (..), IORes) +import Data.Morpheus.Types (GQLRootResolver (..), Undefined (..)) import Data.Text (Text) importGQLDocumentWithNamespace "examples/TH/simple.gql" -rootResolver :: GQLRootResolver IO () () (Query IORes) () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - {queryResolver = return Query {queryDeity}, mutationResolver = pure (), subscriptionResolver = pure ()} + { + queryResolver = Query {queryDeity}, + mutationResolver = Undefined, + subscriptionResolver = Undefined + } where queryDeity QueryDeityArgs {queryDeityArgsName} = pure Deity {deityName, deityPower} where diff --git a/morpheus-graphql.cabal b/morpheus-graphql.cabal --- a/morpheus-graphql.cabal +++ b/morpheus-graphql.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 7a85b066c745ff71fcf1c0be19c670fc75e393b6919cecc737943b70b5451977 +-- hash: 4915b5eb44b1d86031d2ea36b172b06b8f2e91862755d5e1df90e3d17542368c name: morpheus-graphql -version: 0.4.0 +version: 0.5.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -17,211 +19,223 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 extra-source-files: + changelog.md + README.md + examples/Sophisticated/api.gql + examples/Subscription/api.gql + examples/TH/simple.gql assets/introspection.json assets/mut.gql assets/pubsub.gql assets/simple.gql - changelog.md - examples/Sophisticated/api.gql - examples/TH/simple.gql - README.md data-files: test/Feature/Holistic/API.gql test/Feature/Holistic/arguments/nameConflict/query.gql - test/Feature/Holistic/arguments/nameConflict/response.json test/Feature/Holistic/arguments/undefinedArgument/query.gql - test/Feature/Holistic/arguments/undefinedArgument/response.json test/Feature/Holistic/arguments/unknownArguments/query.gql + test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql + test/Feature/Holistic/fragment/inlineFragment/query.gql + test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql + test/Feature/Holistic/fragment/loopingFragment/query.gql + test/Feature/Holistic/fragment/nameCollision/query.gql + test/Feature/Holistic/fragment/unknownTargetType/query.gql + test/Feature/Holistic/fragment/unusedFragment/query.gql + test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql + test/Feature/Holistic/introspection/defaultTypes/Float/query.gql + test/Feature/Holistic/introspection/defaultTypes/ID/query.gql + test/Feature/Holistic/introspection/defaultTypes/Int/query.gql + test/Feature/Holistic/introspection/defaultTypes/String/query.gql + test/Feature/Holistic/introspection/kinds/ENUM/query.gql + test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql + test/Feature/Holistic/introspection/kinds/OBJECT/query.gql + test/Feature/Holistic/introspection/kinds/SCALAR/query.gql + test/Feature/Holistic/introspection/kinds/UNION/query.gql + test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql + test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql + test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql + test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql + test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql + test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql + test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql + test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql + test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql + test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql + test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql + test/Feature/Holistic/parsing/complex/query.gql + test/Feature/Holistic/parsing/directive/notOnArgument/query.gql + test/Feature/Holistic/parsing/directive/notOnVariable/query.gql + test/Feature/Holistic/parsing/directive/operation/query.gql + test/Feature/Holistic/parsing/directive/selection/query.gql + test/Feature/Holistic/parsing/duplicatedFields/query.gql + test/Feature/Holistic/parsing/extraCommas/query.gql + test/Feature/Holistic/parsing/generousSpaces/query.gql + test/Feature/Holistic/parsing/invalidFields/query.gql + test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql + test/Feature/Holistic/parsing/missingCloseBrace/query.gql + test/Feature/Holistic/parsing/notNullSpacing/query.gql + test/Feature/Holistic/parsing/singleLineComments/query.gql + test/Feature/Holistic/selection/AliasNameConflict/query.gql + test/Feature/Holistic/selection/AliasResolve/query.gql + test/Feature/Holistic/selection/AliasUnknownField/query.gql + test/Feature/Holistic/selection/hasNoSubFields/query.gql + test/Feature/Holistic/selection/mustHaveSubFields/query.gql + test/Feature/Holistic/selection/nameConflict/query.gql + test/Feature/Holistic/selection/unknownField/query.gql + test/Feature/Input/Enum/decode2Con/query.gql + test/Feature/Input/Enum/decode3Con/query.gql + test/Feature/Input/Enum/decodeInvalidValue/query.gql + test/Feature/Input/Enum/decodeMany/con0/query.gql + test/Feature/Input/Enum/decodeMany/con1/query.gql + test/Feature/Input/Enum/decodeMany/con2/query.gql + test/Feature/Input/Enum/decodeMany/con3/query.gql + test/Feature/Input/Enum/decodeMany/con4/query.gql + test/Feature/Input/Enum/decodeMany/con5/query.gql + test/Feature/Input/Enum/decodeMany/con6/query.gql + test/Feature/InputType/variables/incompatibleType/equalType/query.gql + test/Feature/InputType/variables/incompatibleType/stricterType/query.gql + test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql + test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql + test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql + test/Feature/InputType/variables/invalidValue/invalidDefaultValue/query.gql + test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql + test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql + test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql + test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql + test/Feature/InputType/variables/undefinedVariable/query.gql + test/Feature/InputType/variables/unknownType/query.gql + test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql + test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql + test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql + test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql + test/Feature/InputType/variables/validListVariable/query.gql + test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql + test/Feature/InputType/variables/valueNotProvided/nonNullVariableWithDefaultValue/query.gql + test/Feature/InputType/variables/valueNotProvided/nullableVariable/query.gql + test/Feature/Schema/nameCollision/query.gql + test/Feature/UnionType/cannotBeSpreadOnType/query.gql + test/Feature/UnionType/fragmentOnAAndB/query.gql + test/Feature/UnionType/fragmentOnlyOnA/query.gql + test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql + test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql + test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql + test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql + test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql + test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql + test/Feature/WrappedTypeName/validWrappedTypes/query.gql + test/Rendering/schema.gql + test/Feature/Holistic/arguments/nameConflict/response.json + test/Feature/Holistic/arguments/undefinedArgument/response.json test/Feature/Holistic/arguments/unknownArguments/response.json test/Feature/Holistic/cases.json - test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json - test/Feature/Holistic/fragment/inlineFragment/query.gql test/Feature/Holistic/fragment/inlineFragment/response.json - test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json - test/Feature/Holistic/fragment/loopingFragment/query.gql test/Feature/Holistic/fragment/loopingFragment/response.json - test/Feature/Holistic/fragment/nameCollision/query.gql test/Feature/Holistic/fragment/nameCollision/response.json - test/Feature/Holistic/fragment/unknownTargetType/query.gql test/Feature/Holistic/fragment/unknownTargetType/response.json - test/Feature/Holistic/fragment/unusedFragment/query.gql test/Feature/Holistic/fragment/unusedFragment/response.json - test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json - test/Feature/Holistic/introspection/defaultTypes/Float/query.gql test/Feature/Holistic/introspection/defaultTypes/Float/response.json - test/Feature/Holistic/introspection/defaultTypes/ID/query.gql test/Feature/Holistic/introspection/defaultTypes/ID/response.json - test/Feature/Holistic/introspection/defaultTypes/Int/query.gql test/Feature/Holistic/introspection/defaultTypes/Int/response.json - test/Feature/Holistic/introspection/defaultTypes/String/query.gql test/Feature/Holistic/introspection/defaultTypes/String/response.json - test/Feature/Holistic/introspection/kinds/ENUM/query.gql test/Feature/Holistic/introspection/kinds/ENUM/response.json - test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json - test/Feature/Holistic/introspection/kinds/OBJECT/query.gql test/Feature/Holistic/introspection/kinds/OBJECT/response.json - test/Feature/Holistic/introspection/kinds/SCALAR/query.gql test/Feature/Holistic/introspection/kinds/SCALAR/response.json - test/Feature/Holistic/introspection/kinds/UNION/query.gql test/Feature/Holistic/introspection/kinds/UNION/response.json - test/Feature/Holistic/introspection/schemaTypes/__Directive/query.gql test/Feature/Holistic/introspection/schemaTypes/__Directive/response.json - test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/query.gql test/Feature/Holistic/introspection/schemaTypes/__DirectiveLocation/response.json - test/Feature/Holistic/introspection/schemaTypes/__EnumValue/query.gql test/Feature/Holistic/introspection/schemaTypes/__EnumValue/response.json - test/Feature/Holistic/introspection/schemaTypes/__Field/query.gql test/Feature/Holistic/introspection/schemaTypes/__Field/response.json - test/Feature/Holistic/introspection/schemaTypes/__InputValue/query.gql test/Feature/Holistic/introspection/schemaTypes/__InputValue/response.json - test/Feature/Holistic/introspection/schemaTypes/__Schema/query.gql test/Feature/Holistic/introspection/schemaTypes/__Schema/response.json - test/Feature/Holistic/introspection/schemaTypes/__Type/query.gql test/Feature/Holistic/introspection/schemaTypes/__Type/response.json - test/Feature/Holistic/introspection/schemaTypes/__TypeKind/query.gql test/Feature/Holistic/introspection/schemaTypes/__TypeKind/response.json - test/Feature/Holistic/parsing/complex/query.gql + test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json + test/Feature/Holistic/parsing/AnonymousOperation/query/response.json + test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json test/Feature/Holistic/parsing/complex/response.json - test/Feature/Holistic/parsing/duplicatedFields/query.gql + test/Feature/Holistic/parsing/directive/notOnArgument/response.json + test/Feature/Holistic/parsing/directive/notOnVariable/response.json + test/Feature/Holistic/parsing/directive/operation/response.json + test/Feature/Holistic/parsing/directive/selection/response.json test/Feature/Holistic/parsing/duplicatedFields/response.json - test/Feature/Holistic/parsing/extraCommas/query.gql test/Feature/Holistic/parsing/extraCommas/response.json - test/Feature/Holistic/parsing/generousSpaces/query.gql test/Feature/Holistic/parsing/generousSpaces/response.json - test/Feature/Holistic/parsing/invalidFields/query.gql test/Feature/Holistic/parsing/invalidFields/response.json - test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql test/Feature/Holistic/parsing/invalidNotNullOperator/response.json - test/Feature/Holistic/parsing/missingCloseBrace/query.gql test/Feature/Holistic/parsing/missingCloseBrace/response.json - test/Feature/Holistic/parsing/multilineComments/query.gql - test/Feature/Holistic/parsing/multilineComments/response.json - test/Feature/Holistic/parsing/notNullSpacing/query.gql test/Feature/Holistic/parsing/notNullSpacing/response.json test/Feature/Holistic/parsing/notNullSpacing/variables.json - test/Feature/Holistic/parsing/singleLineComments/query.gql test/Feature/Holistic/parsing/singleLineComments/response.json - test/Feature/Holistic/selection/AliasNameConflict/query.gql test/Feature/Holistic/selection/AliasNameConflict/response.json - test/Feature/Holistic/selection/AliasResolve/query.gql test/Feature/Holistic/selection/AliasResolve/response.json - test/Feature/Holistic/selection/AliasUnknownField/query.gql test/Feature/Holistic/selection/AliasUnknownField/response.json - test/Feature/Holistic/selection/hasNoSubFields/query.gql test/Feature/Holistic/selection/hasNoSubFields/response.json - test/Feature/Holistic/selection/mustHaveSubFields/query.gql test/Feature/Holistic/selection/mustHaveSubFields/response.json - test/Feature/Holistic/selection/nameConflict/query.gql test/Feature/Holistic/selection/nameConflict/response.json - test/Feature/Holistic/selection/unknownField/query.gql test/Feature/Holistic/selection/unknownField/response.json test/Feature/Input/Enum/cases.json - test/Feature/Input/Enum/decode2Con/query.gql test/Feature/Input/Enum/decode2Con/response.json - test/Feature/Input/Enum/decode3Con/query.gql test/Feature/Input/Enum/decode3Con/response.json - test/Feature/Input/Enum/decodeInvalidValue/query.gql test/Feature/Input/Enum/decodeInvalidValue/response.json - test/Feature/Input/Enum/decodeMany/con0/query.gql test/Feature/Input/Enum/decodeMany/con0/response.json - test/Feature/Input/Enum/decodeMany/con1/query.gql test/Feature/Input/Enum/decodeMany/con1/response.json - test/Feature/Input/Enum/decodeMany/con2/query.gql test/Feature/Input/Enum/decodeMany/con2/response.json - test/Feature/Input/Enum/decodeMany/con3/query.gql test/Feature/Input/Enum/decodeMany/con3/response.json - test/Feature/Input/Enum/decodeMany/con4/query.gql test/Feature/Input/Enum/decodeMany/con4/response.json - test/Feature/Input/Enum/decodeMany/con5/query.gql test/Feature/Input/Enum/decodeMany/con5/response.json - test/Feature/Input/Enum/decodeMany/con6/query.gql test/Feature/Input/Enum/decodeMany/con6/response.json test/Feature/InputType/cases.json - test/Feature/InputType/variables/incompatibleType/equalType/query.gql test/Feature/InputType/variables/incompatibleType/equalType/response.json test/Feature/InputType/variables/incompatibleType/equalType/variables.json - test/Feature/InputType/variables/incompatibleType/stricterType/query.gql test/Feature/InputType/variables/incompatibleType/stricterType/response.json test/Feature/InputType/variables/incompatibleType/stricterType/variables.json - test/Feature/InputType/variables/incompatibleType/weakerType1/query.gql test/Feature/InputType/variables/incompatibleType/weakerType1/response.json test/Feature/InputType/variables/incompatibleType/weakerType1/variables.json - test/Feature/InputType/variables/incompatibleType/weakerType2/query.gql test/Feature/InputType/variables/incompatibleType/weakerType2/response.json test/Feature/InputType/variables/incompatibleType/weakerType2/variables.json - test/Feature/InputType/variables/incompatibleType/weakerType3/query.gql test/Feature/InputType/variables/incompatibleType/weakerType3/response.json test/Feature/InputType/variables/incompatibleType/weakerType3/variables.json - test/Feature/InputType/variables/invalidValue/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 - test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json - test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json - test/Feature/InputType/variables/undefinedVariable/query.gql test/Feature/InputType/variables/undefinedVariable/response.json - test/Feature/InputType/variables/unknownType/query.gql test/Feature/InputType/variables/unknownType/response.json - test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json - test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/query.gql test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/response.json test/Feature/InputType/variables/unusedVariable/variableUsedInAlias/variables.json - test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/query.gql test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/response.json test/Feature/InputType/variables/unusedVariable/variableUsedInFragment/variables.json - test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/query.gql test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/response.json test/Feature/InputType/variables/unusedVariable/variableUsedInInlineFragment/variables.json - test/Feature/InputType/variables/validListVariable/query.gql test/Feature/InputType/variables/validListVariable/response.json test/Feature/InputType/variables/validListVariable/variables.json - test/Feature/InputType/variables/valueNotProvided/nonNullVariable/query.gql test/Feature/InputType/variables/valueNotProvided/nonNullVariable/response.json - test/Feature/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 - test/Feature/UnionType/cannotBeSpreadOnType/query.gql test/Feature/UnionType/cannotBeSpreadOnType/response.json test/Feature/UnionType/cases.json - test/Feature/UnionType/fragmentOnAAndB/query.gql test/Feature/UnionType/fragmentOnAAndB/response.json - test/Feature/UnionType/fragmentOnlyOnA/query.gql test/Feature/UnionType/fragmentOnlyOnA/response.json - test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/query.gql test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json - test/Feature/UnionType/inlineFragment/fragmentOnAAndB/query.gql test/Feature/UnionType/inlineFragment/fragmentOnAAndB/response.json - test/Feature/UnionType/selectionWithoutFragmentNotAllowed/query.gql test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json test/Feature/WrappedTypeName/cases.json - test/Feature/WrappedTypeName/ignoreMutationResolver/query.gql test/Feature/WrappedTypeName/ignoreMutationResolver/response.json - test/Feature/WrappedTypeName/ignoreQueryResolver/query.gql test/Feature/WrappedTypeName/ignoreQueryResolver/response.json - test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql test/Feature/WrappedTypeName/ignoreSubscriptionResolver/response.json - test/Feature/WrappedTypeName/validWrappedTypes/query.gql test/Feature/WrappedTypeName/validWrappedTypes/response.json - test/Rendering/schema.gql source-repository head type: git @@ -272,19 +286,19 @@ Data.Morpheus.Execution.Server.Resolve Data.Morpheus.Execution.Subscription.Apollo Data.Morpheus.Execution.Subscription.ClientRegister - Data.Morpheus.Parsing.Document.DataType Data.Morpheus.Parsing.Document.Parser + Data.Morpheus.Parsing.Document.TypeSystem Data.Morpheus.Parsing.Internal.Create Data.Morpheus.Parsing.Internal.Internal + Data.Morpheus.Parsing.Internal.Pattern Data.Morpheus.Parsing.Internal.Terms Data.Morpheus.Parsing.Internal.Value Data.Morpheus.Parsing.JSONSchema.Parse Data.Morpheus.Parsing.JSONSchema.Types Data.Morpheus.Parsing.Request.Arguments - Data.Morpheus.Parsing.Request.Body - Data.Morpheus.Parsing.Request.Fragment Data.Morpheus.Parsing.Request.Operation Data.Morpheus.Parsing.Request.Parser + Data.Morpheus.Parsing.Request.Selection Data.Morpheus.Rendering.Haskell.Render Data.Morpheus.Rendering.Haskell.RenderHS Data.Morpheus.Rendering.Haskell.Terms @@ -305,13 +319,13 @@ Data.Morpheus.Types.Internal.Base Data.Morpheus.Types.Internal.Data Data.Morpheus.Types.Internal.DataD + Data.Morpheus.Types.Internal.Resolver Data.Morpheus.Types.Internal.Stream Data.Morpheus.Types.Internal.TH Data.Morpheus.Types.Internal.Validation Data.Morpheus.Types.Internal.Value Data.Morpheus.Types.Internal.WebSocket Data.Morpheus.Types.IO - Data.Morpheus.Types.Resolver Data.Morpheus.Types.Types Data.Morpheus.Validation.Document.Validation Data.Morpheus.Validation.Internal.Utils diff --git a/src/Data/Morpheus/Document.hs b/src/Data/Morpheus/Document.hs --- a/src/Data/Morpheus/Document.hs +++ b/src/Data/Morpheus/Document.hs @@ -42,7 +42,7 @@ parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes -- | Generates schema.gql file from 'GQLRootResolver' -toGraphQLDocument :: RootResCon m e c query mut sub => proxy (GQLRootResolver m e c query mut sub) -> ByteString +toGraphQLDocument :: RootResCon m event query mut sub => proxy (GQLRootResolver m event query mut sub) -> ByteString toGraphQLDocument x = case fullSchema x of Left errors -> pack (show errors) diff --git a/src/Data/Morpheus/Error/Internal.hs b/src/Data/Morpheus/Error/Internal.hs --- a/src/Data/Morpheus/Error/Internal.hs +++ b/src/Data/Morpheus/Error/Internal.hs @@ -8,11 +8,15 @@ , internalErrorT ) where -import Data.Morpheus.Error.Utils (globalErrorMessage) -import Data.Morpheus.Types.Internal.Validation (GQLErrors, ResolveT, failResolveT) -import Data.Morpheus.Types.Internal.Value (Value (..)) import Data.Text (Text) import qualified Data.Text as T (concat, pack) + +-- MORPHEUS +import Data.Morpheus.Error.Utils (globalErrorMessage) +import Data.Morpheus.Types.Internal.Resolver (ResolveT, failResolveT) +import Data.Morpheus.Types.Internal.Validation (GQLErrors) +import Data.Morpheus.Types.Internal.Value (Value (..)) + -- GQL:: if no mutation defined -> "Schema is not configured for mutations." -- all kind internal error in development diff --git a/src/Data/Morpheus/Execution/Client/Fetch.hs b/src/Data/Morpheus/Execution/Client/Fetch.hs --- a/src/Data/Morpheus/Execution/Client/Fetch.hs +++ b/src/Data/Morpheus/Execution/Client/Fetch.hs @@ -16,11 +16,19 @@ import Data.Text (pack) import Language.Haskell.TH +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A + -- -- MORPHEUS import Data.Morpheus.Types.Internal.TH (instanceHeadT) import Data.Morpheus.Types.IO (GQLRequest (..), JSONResponse (..)) +fixVars :: A.Value -> Maybe A.Value +fixVars x + | x == A.emptyArray = Nothing + | otherwise = Just x + class Fetch a where type Args a :: * __fetch :: @@ -32,7 +40,7 @@ -> m (Either String a) __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq) where - gqlReq = GQLRequest {operationName = Just (pack opName), query = pack strQuery, variables = Just (toJSON vars)} + gqlReq = GQLRequest {operationName = Just (pack opName), query = pack strQuery, variables = fixVars (toJSON vars)} ------------------------------------------------------------- processResponse JSONResponse {responseData = Just x} = pure x processResponse invalidResponse = fail $ show invalidResponse diff --git a/src/Data/Morpheus/Execution/Client/Selection.hs b/src/Data/Morpheus/Execution/Client/Selection.hs --- a/src/Data/Morpheus/Execution/Client/Selection.hs +++ b/src/Data/Morpheus/Execution/Client/Selection.hs @@ -8,17 +8,18 @@ ( operationTypes ) where +import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import Data.Text (Text, pack, unpack) - -- -- MORPHEUS 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) + Variable (..), VariableDefinitions, getOperationName) +import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet, + ValidSelection) import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..), DataTyCon (..), DataTypeKind (..), DataTypeLib (..), Key, TypeAlias (..), allDataTypes) @@ -37,10 +38,10 @@ operationTypes lib variables = genOperation where genOperation Operation {operationName, operationSelection} = do - (queryTypes, enums) <- genRecordType [] operationName queryDataType operationSelection + (queryTypes, enums) <- genRecordType [] (getOperationName operationName) queryDataType operationSelection inputTypeRequests <- resolveUpdates [] $ map (scanInputTypes lib . variableType . snd) variables inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums) - pure (rootArguments (operationName <> "Args"), queryTypes <> inputTypesAndEnums) + pure (rootArguments (getOperationName operationName <> "Args"), queryTypes <> inputTypesAndEnums) where queryDataType = OutputObject $ snd $ query lib ------------------------------------------------------------------------- @@ -93,14 +94,14 @@ pure (ConsD {cName, cFields}, concat subTypes, concat requests) --------------------------------------------------------------------------------------------- where - genField :: (Text, Selection) -> Validation DataField - genField (fieldName, sel) = genFieldD sel + genField :: (Text, ValidSelection) -> Validation DataField + genField (fieldName, sel@Selection { selectionAlias }) = genFieldD sel where - fieldPath = path <> [fieldName] + fieldPath = path <> [fromMaybe fieldName selectionAlias] ------------------------------- - genFieldD Selection {selectionRec = SelectionAlias {aliasFieldName}} = do - fieldType <- snd <$> lookupFieldType lib fieldPath datatype aliasFieldName - pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False} + genFieldD Selection {selectionAlias = Just aliasFieldName} = do + fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName + pure $ DataField {fieldName = aliasFieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False} genFieldD _ = do fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False} @@ -108,23 +109,20 @@ newFieldTypes :: DataFullType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]]) newFieldTypes parentType seSet = unzip <$> mapM valSelection seSet where - valSelection selection@(selKey, _) = do - let (key, sel) = getSelectionFieldKey selection + valSelection (key, selection@Selection { selectionAlias }) = do fieldDatatype <- fst <$> lookupFieldType lib fieldPath parentType key - validateSelection fieldDatatype sel + validateSelection fieldDatatype selection -------------------------------------------------------------------- where - fieldPath = path <> [selKey] + fieldPath = path <> [fromMaybe key selectionAlias] -------------------------------------------------------------------- - validateSelection :: DataFullType -> Selection -> Validation ([GQLTypeD], [Text]) + validateSelection :: DataFullType -> ValidSelection -> 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 @@ -194,13 +192,8 @@ 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 + Nothing -> Left (compileError $ "cant find field \""<> key<>"\"") +lookupFieldType _ _ dt _ = Left (compileError $ "Type should be output Object \"" <> pack (show dt)) withLeaf :: (DataLeaf -> Validation b) -> DataFullType -> Validation b withLeaf f (Leaf x) = f x @@ -213,21 +206,19 @@ getType :: DataTypeLib -> Text -> Validation DataFullType getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename -isPrimitive :: Text -> Bool -isPrimitive "Boolean" = True -isPrimitive "Int" = True -isPrimitive "Float" = True -isPrimitive "String" = True -isPrimitive "ID" = True -isPrimitive _ = False +typeFromScalar :: Text -> Text +typeFromScalar "Boolean" = "Bool" +typeFromScalar "Int" = "Int" +typeFromScalar "Float" = "Float" +typeFromScalar "String" = "Text" +typeFromScalar "ID" = "ID" +typeFromScalar _ = "ScalarValue" 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 path (OutputObject x) = pack $ nameSpaceType path $ typeName x -typeFrom path (Union x) = pack $ nameSpaceType path $ typeName x -typeFrom _ (InputUnion x) = typeName x +typeFrom _ (Leaf (BaseScalar x)) = typeName x +typeFrom _ (Leaf (CustomScalar DataTyCon {typeName})) = typeFromScalar typeName +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 diff --git a/src/Data/Morpheus/Execution/Document/Convert.hs b/src/Data/Morpheus/Execution/Document/Convert.hs --- a/src/Data/Morpheus/Execution/Document/Convert.hs +++ b/src/Data/Morpheus/Execution/Document/Convert.hs @@ -17,7 +17,7 @@ import Data.Morpheus.Execution.Internal.Utils (capital) import Data.Morpheus.Types.Internal.Data (ArgsType (..), DataField (..), DataField, DataFullType (..), DataLeaf (..), DataTyCon (..), DataTypeKind (..), - DataTypeKind (..), OperationKind (..), ResolverKind (..), + DataTypeKind (..), OperationType (..), ResolverKind (..), TypeAlias (..), sysTypes) import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..)) import Data.Morpheus.Types.Internal.Validation (Validation) diff --git a/src/Data/Morpheus/Execution/Document/Encode.hs b/src/Data/Morpheus/Execution/Document/Encode.hs --- a/src/Data/Morpheus/Execution/Document/Encode.hs +++ b/src/Data/Morpheus/Execution/Document/Encode.hs @@ -7,20 +7,19 @@ ( deriveEncode ) where -import Data.Text (unpack) -import Data.Typeable (Typeable) +import Data.Text (unpack) +import Data.Typeable (Typeable) import Language.Haskell.TH +import Data.Semigroup ((<>)) -- -- MORPHEUS -import Data.Morpheus.Execution.Server.Encode (Encode (..), ObjectResolvers (..)) -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, destructRecord, instanceHeadMultiT, typeT) -import Data.Morpheus.Types.Internal.Validation (ResolveT) -import Data.Morpheus.Types.Internal.Value (Value) -import Data.Morpheus.Types.Resolver +import Data.Morpheus.Execution.Server.Encode (Encode (..), ObjectResolvers (..)) +import Data.Morpheus.Types.GQLType (TRUE) +import Data.Morpheus.Types.Internal.Data (DataField (..), QUERY, SUBSCRIPTION, isSubscription) +import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..)) +import Data.Morpheus.Types.Internal.Resolver (Resolver, MapGraphQLT (..), Resolving,PureOperation) +import Data.Morpheus.Types.Internal.TH (applyT, destructRecord, instanceHeadMultiT, typeT) -- @Subscription: -- @@ -33,26 +32,30 @@ -- objectResolvers _ ( x y) = [("field1", encode x), ("field2", encode y)] -- -- + + deriveEncode :: GQLTypeD -> Q [Dec] deriveEncode GQLTypeD {typeKindD, typeD = TypeD {tName, tCons = [ConsD {cFields}]}} = pure <$> instanceD (cxt constrains) appHead methods - where - result = appT resultMonad (conT ''Value) - where - resultMonad - | isSubscription typeKindD = typeT ''SubResolveT ["m", "e", "c"] -- (SubResolveT m e c Value) - | otherwise = typeT ''ResolveT ["m"] -- (ResolveT m Value) - mainType = applyT (mkName tName) [mainTypeArg] -- defines ( (SubResolver m e c)) or ( (Resolver m)) + where + subARgs = conT ''SUBSCRIPTION : map (varT . mkName) ["m","e"] + instanceArgs + | isSubscription typeKindD = subARgs + | otherwise = map (varT . mkName) ["o","m","e"] + mainType = applyT (mkName tName) [mainTypeArg] where mainTypeArg - | isSubscription typeKindD = typeT ''SubResolver ["m", "e", "c"] -- (SubResolver m e c) - | otherwise = typeT ''Resolver ["m"] -- (Resolver m) + | isSubscription typeKindD = applyT ''Resolver subARgs + | otherwise = typeT ''Resolver ["fieldOKind","m","e"] ----------------------------------------------------------------------------------------- + typeables + | isSubscription typeKindD = [applyT ''MapGraphQLT $ map conT [''QUERY, ''SUBSCRIPTION],applyT ''Resolving [conT ''QUERY, varT $ mkName "m", varT $ mkName "e"]] + | otherwise = [typeT ''PureOperation ["fieldOKind"],typeT ''MapGraphQLT ["fieldOKind","o"] , typeT ''Resolving ["fieldOKind","m","e"] , typeT ''Typeable ["fieldOKind"] , typeT ''Typeable ["o"]] -- defines Constraint: (Typeable m, Monad m) - constrains = [typeT ''Monad ["m"], typeT ''Typeable ["m"]] + constrains = typeables <>[typeT ''Monad ["m"], applyT ''Encode (mainType:instanceArgs) , typeT ''Typeable ["m"],typeT ''Typeable ["e"]] ------------------------------------------------------------------- -- defines: instance => ObjectResolvers ('TRUE) ( (ResolveT m)) (ResolveT m value) where - appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) [mainType, result] + appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) (mainType: instanceArgs) ------------------------------------------------------------------ -- defines: objectResolvers = [("field1",encode field1),("field2",encode field2), ...] methods = [funD 'objectResolvers [clause argsE (normalB body) []]] diff --git a/src/Data/Morpheus/Execution/Internal/Declare.hs b/src/Data/Morpheus/Execution/Internal/Declare.hs --- a/src/Data/Morpheus/Execution/Internal/Declare.hs +++ b/src/Data/Morpheus/Execution/Internal/Declare.hs @@ -23,7 +23,7 @@ DataTypeKind (..), TypeAlias (..), WrapperD (..), isOutputObject, isSubscription) import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..)) -import Data.Morpheus.Types.Resolver (UnSubResolver) +import Data.Morpheus.Types.Internal.Resolver (UnSubResolver) type FUNC = (->) diff --git a/src/Data/Morpheus/Execution/Server/Encode.hs b/src/Data/Morpheus/Execution/Server/Encode.hs --- a/src/Data/Morpheus/Execution/Server/Encode.hs +++ b/src/Data/Morpheus/Execution/Server/Encode.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -14,222 +13,181 @@ module Data.Morpheus.Execution.Server.Encode ( EncodeCon - , EncodeMutCon - , EncodeSubCon , GResolver(..) , Encode(..) , encodeQuery - , encodeOperation + , encodeSubscription + , encodeMutation , ObjectResolvers(..) - , OBJ_RES ) where -import Control.Monad ((>=>)) -import Control.Monad.Except (liftEither, runExceptT, withExceptT) import Data.Map (Map) import qualified Data.Map as M (toList) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) +import Data.Semigroup ((<>)) import Data.Set (Set) import qualified Data.Set as S (toList) import Data.Text (pack) import GHC.Generics -- MORPHEUS -import Data.Morpheus.Error.Internal (internalErrorT) -import Data.Morpheus.Error.Selection (resolverError, subfieldsNotSelected) +import Data.Morpheus.Error.Internal (internalUnknownTypeMessage) import Data.Morpheus.Execution.Server.Decode (DecodeObject, decodeArguments) import Data.Morpheus.Execution.Server.Generics.EnumRep (EnumRep (..)) -import Data.Morpheus.Kind (Context (..), ENUM, GQL_KIND, OBJECT, SCALAR, UNION, - VContext (..)) +import Data.Morpheus.Kind (ENUM, GQL_KIND, OBJECT, ResContext (..), SCALAR, + UNION, VContext (..)) import Data.Morpheus.Types.Custom (MapKind, Pair (..), mapKindFromList) import Data.Morpheus.Types.GQLScalar (GQLScalar (..)) import Data.Morpheus.Types.GQLType (GQLType (CUSTOM, KIND, __typeName)) import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation) -import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet) +import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), ValidSelection) import Data.Morpheus.Types.Internal.Base (Key) -import Data.Morpheus.Types.Internal.Stream (PublishStream, StreamT (..), SubscribeStream, - initExceptStream, injectEvents) -import Data.Morpheus.Types.Internal.Validation (GQLErrors, ResolveT, failResolveT) +import Data.Morpheus.Types.Internal.Data (MUTATION, OperationType, QUERY, SUBSCRIPTION) +import Data.Morpheus.Types.Internal.Resolver (MapGraphQLT (..), PureOperation (..), Resolver (..), + Resolving (..), ResolvingStrategy (..), resolveObject, + withObject) +import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Internal.Value (GQLValue (..), Value (..)) -import Data.Morpheus.Types.Resolver (Event (..), Resolver, SubResolveT, SubResolver (..)) -class Encode resolver value where - encode :: resolver -> (Key, Selection) -> value +class Encode resolver o m e where + encode :: PureOperation o => resolver -> (Key, ValidSelection) -> ResolvingStrategy o m e Value -instance {-# OVERLAPPABLE #-} EncodeKind (KIND a) a res => Encode a res where +instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o m e , PureOperation o) => Encode a o m e where encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a) -- MAYBE -instance (GQLValue value, Encode a value) => Encode (Maybe a) value where - encode Nothing = const gqlNull - encode (Just value) = encode value +instance (Monad m , Encode a o m e) => Encode (Maybe a) o m e where + encode = maybe (const $ pure gqlNull) encode -- Tuple (a,b) -instance Encode (Pair k v) value => Encode (k, v) value where +instance Encode (Pair k v) o m e => Encode (k, v) o m e where encode (key, value) = encode (Pair key value) -- Set -instance Encode [a] value => Encode (Set a) value where +instance Encode [a] o m e => Encode (Set a) o m e where encode = encode . S.toList -- Map -instance (Eq k, Monad m, Encode (MapKind k v (Resolver m)) (ResolveT m value)) => - Encode (Map k v) (ResolveT m value) where - encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver m)) +instance (Eq k, Monad m, Encode (MapKind k v (Resolver o m e)) o m e) => Encode (Map k v) o m e where + encode value = encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o m e)) -- LIST [] -instance (Monad m, GQLValue value, Encode a (m value)) => Encode [a] (m value) where +instance (Monad m, Encode a o m e) => Encode [a] o m e where encode list query = gqlList <$> traverse (`encode` query) list --- GQL a -> b -instance (DecodeObject a, Monad m, Encode b (ResolveT m value)) => Encode (a -> b) (ResolveT m value) where - encode resolver selection = decodeArgs selection >>= (`encode` selection) . resolver - where - decodeArgs :: (Key, Selection) -> ResolveT m a - decodeArgs = liftEither . decodeArguments . selectionArguments . snd --- GQL Either Resolver Monad -instance (Monad m, Encode a (ResolveT m value)) => Encode (Either String a) (ResolveT m value) where - encode resolver = (`encodeResolver` liftEither resolver) - --- GQL ExceptT Resolver Monad -instance (Monad m, Encode b (ResolveT m value)) => Encode (Resolver m b) (ResolveT m value) where - encode = flip encodeResolver - --- GQL Mutation Resolver Monad -instance (Monad m, Encode b (ResolveT m value)) => Encode (Resolver m b) (ResolveT (StreamT m c) value) where - encode resolver = injectEvents [] . encode resolver - --- GQL Subscription Resolver Monad -instance (Monad m, Encode b (ResolveT m Value)) => Encode (SubResolver m e c b) (SubResolveT m e c Value) where - encode resolver selection = handleResolver resolver - where - handleResolver SubResolver {subChannels, subResolver} = - initExceptStream [subChannels] (encodeResolver selection . subResolver) +-- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY +instance (DecodeObject a, Resolving fO m e ,Monad m,PureOperation fO, MapGraphQLT fO o, Encode b fO m e ) => Encode (a -> Resolver fO m e b) o m e where + encode resolver selection@(_, Selection { selectionArguments }) = mapGraphQLT $ resolving encode (getArgs args resolver) selection + where + args :: Validation a + args = decodeArguments selectionArguments -- ENCODE GQL KIND -class EncodeKind (kind :: GQL_KIND) a value where - encodeKind :: VContext kind a -> (Key, Selection) -> value +class EncodeKind (kind :: GQL_KIND) a o m e where + encodeKind :: PureOperation o => VContext kind a -> (Key, ValidSelection) -> ResolvingStrategy o m e Value -- SCALAR -instance (GQLScalar a, GQLValue value) => EncodeKind SCALAR a value where - encodeKind = pure . gqlScalar . serialize . unVContext +instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o m e where + encodeKind = pure . pure . gqlScalar . serialize . unVContext -- ENUM -instance (Generic a, EnumRep (Rep a), GQLValue value) => EncodeKind ENUM a value where - encodeKind = pure . gqlString . encodeRep . from . unVContext +instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o m e where + encodeKind = pure . pure . gqlString . encodeRep . from . unVContext -- OBJECT -instance (Monad m, EncodeCon m a value, GQLValue value) => EncodeKind OBJECT a (ResolveT m value) where - encodeKind (VContext value) (_, Selection {selectionRec = SelectionSet selection}) = - resolveFields selection (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value) +instance (Monad m, EncodeCon o m e a, Monad m, GResolver OBJECT (Rep a) o m e) => EncodeKind OBJECT a o m e where + encodeKind (VContext value) = withObject encodeK where + encodeK selection = resolveObject selection (__typenameResolver : objectResolvers (Proxy :: Proxy (CUSTOM a)) value) __typenameResolver = ("__typename", const $ pure $ gqlString $ __typeName (Proxy @a)) - encodeKind _ (key, Selection {selectionPosition}) = failResolveT $ subfieldsNotSelected key "" selectionPosition +-- exploreKindChannels -- UNION -instance (Monad m, GQL_RES a, GResolver UNION (Rep a) (ResolveT m value)) => EncodeKind UNION a (ResolveT m value) where +instance (Monad m, GQL_RES a, GResolver UNION (Rep a) o m e) => EncodeKind UNION a o m e where encodeKind (VContext value) (key, sel@Selection {selectionRec = UnionSelection selections}) = resolver (key, sel {selectionRec = SelectionSet lookupSelection}) -- SPEC: if there is no any fragment that supports current object Type GQL returns {} where lookupSelection = fromMaybe [] $ lookup typeName selections (typeName, resolver) = unionResolver value - encodeKind _ _ = internalErrorT "union Resolver only should recieve UnionSelection" + encodeKind _ _ = Fail $ internalUnknownTypeMessage "union Resolver only should recieve UnionSelection" -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) -type EncodeOperator m a value = Resolver m a -> ValidOperation -> m (Either GQLErrors value) - -type OBJ_RES m a value = ObjectResolvers (CUSTOM a) a (ResolveT m value) - -type EncodeCon m a value = (GQL_RES a, OBJ_RES m a value) - -type EncodeMutCon m event con mut = EncodeCon (PublishStream m event con) mut Value +type EncodeOperator o m e a = a -> ValidOperation -> ResolvingStrategy o m e Value -type EncodeSubCon m event con sub = EncodeCon (SubscribeStream m event) sub (Event event con -> ResolveT m Value) +type EncodeCon o m e a = (GQL_RES a, ObjectResolvers (CUSTOM a) a o m e) -type FieldRes m value = (Key, (Key, Selection) -> ResolveT m value) +type FieldRes o m e = (Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value) type family GRes (kind :: GQL_KIND) value :: * -type instance GRes OBJECT v = [(Key, (Key, Selection) -> v)] +type instance GRes OBJECT v = [(Key, (Key, ValidSelection) -> v)] -type instance GRes UNION v = (Key, (Key, Selection) -> v) +type instance GRes UNION v = (Key, (Key, ValidSelection) -> v) --- GENERICS ------------------------------------------------ -class ObjectResolvers (custom :: Bool) a value where - objectResolvers :: Proxy custom -> a -> [(Key, (Key, Selection) -> value)] +class ObjectResolvers (custom :: Bool) a (o :: OperationType) (m :: * -> *) e where + objectResolvers :: PureOperation o => Proxy custom -> a -> [(Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value)] -instance (Generic a, GResolver OBJECT (Rep a) value) => ObjectResolvers 'False a value where - objectResolvers _ = getResolvers (Context :: Context OBJECT value) . from +instance (Generic a, GResolver OBJECT (Rep a) o m e ) => ObjectResolvers 'False a o m e where + objectResolvers _ = getResolvers (ResContext :: ResContext OBJECT o m e value) . from -unionResolver :: (Generic a, GResolver UNION (Rep a) value) => a -> (Key, (Key, Selection) -> value) -unionResolver = getResolvers (Context :: Context UNION value) . from +unionResolver :: (Generic a, PureOperation o, GResolver UNION (Rep a) o m e) => a -> (Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value) +unionResolver = getResolvers (ResContext :: ResContext UNION o m e value) . from -- | Derives resolvers for OBJECT and UNION -class GResolver (kind :: GQL_KIND) f value where - getResolvers :: Context kind value -> f a -> GRes kind value +class GResolver (kind :: GQL_KIND) f o m e where + getResolvers :: PureOperation o => ResContext kind o m e value -> f a -> GRes kind (ResolvingStrategy o m e Value) -instance GResolver kind f value => GResolver kind (M1 D c f) value where +instance GResolver kind f o m e => GResolver kind (M1 D c f) o m e where getResolvers context (M1 src) = getResolvers context src -instance GResolver kind f value => GResolver kind (M1 C c f) value where +instance GResolver kind f o m e => GResolver kind (M1 C c f) o m e where getResolvers context (M1 src) = getResolvers context src -- OBJECT -instance GResolver OBJECT U1 value where +instance GResolver OBJECT U1 o m e where getResolvers _ _ = [] -instance (Selector s, GQLType a, Encode a value) => GResolver OBJECT (M1 S s (K1 s2 a)) value where +instance (Selector s, GQLType a, Encode a o m e) => GResolver OBJECT (M1 S s (K1 s2 a)) o m e where getResolvers _ m@(M1 (K1 src)) = [(pack (selName m), encode src)] -instance (GResolver OBJECT f value, GResolver OBJECT g value) => GResolver OBJECT (f :*: g) value where - getResolvers context (a :*: b) = getResolvers context a ++ getResolvers context b +instance (GResolver OBJECT f o m e, GResolver OBJECT g o m e) => GResolver OBJECT (f :*: g) o m e where + getResolvers context (a :*: b) = getResolvers context a ++ getResolvers context b -- UNION -instance (Selector s, GQLType a, Encode a value) => GResolver UNION (M1 S s (K1 s2 a)) value where +instance (Selector s, GQLType a, Encode a o m e ) => GResolver UNION (M1 S s (K1 s2 a)) o m e where getResolvers _ (M1 (K1 src)) = (__typeName (Proxy @a), encode src) -instance (GResolver UNION a value, GResolver UNION b value) => GResolver UNION (a :+: b) value where +instance (GResolver UNION a o m e, GResolver UNION b o m e) => GResolver UNION (a :+: b) o m e where getResolvers context (L1 x) = getResolvers context x getResolvers context (R1 x) = getResolvers context x ----- HELPERS ---------------------------- encodeQuery :: - forall m a schema. (GQL_RES a, GQL_RES schema, Monad m, EncodeCon m schema Value, EncodeCon m a Value) - => schema - -> EncodeOperator m a Value -encodeQuery schema = encodeOperationWith (objectResolvers (Proxy :: Proxy (CUSTOM schema)) schema) - -encodeOperation :: (Monad m, GQL_RES a, EncodeCon m a value, GQLValue value) => EncodeOperator m a value -encodeOperation = encodeOperationWith [] + forall m event query (schema :: (* -> *) -> *). (Monad m, EncodeCon QUERY m event (schema (Resolver QUERY m event)), EncodeCon QUERY m event query, Resolving QUERY m event) + => schema (Resolver QUERY m event) + -> EncodeOperator QUERY m event query +encodeQuery schema = encodeOperationWith (objectResolvers (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY m event)))) schema) -encodeOperationWith :: - forall m a value. (Monad m, GQL_RES a, GQLValue value, EncodeCon m a value) - => [FieldRes m value] - -> EncodeOperator m a value -encodeOperationWith externalRes rootResolver Operation {operationSelection, operationPosition, operationName} = - runExceptT $ - operationResolveT >>= - resolveFields operationSelection . (++) externalRes . objectResolvers (Proxy :: Proxy (CUSTOM a)) - where - operationResolveT = withExceptT (resolverError operationPosition operationName) rootResolver +encodeMutation :: + forall m event mut. (Monad m, EncodeCon MUTATION m event mut, Resolving MUTATION m event) + => EncodeOperator MUTATION m event mut +encodeMutation = encodeOperationWith [] -encodeResolver :: (Monad m, Encode a (ResolveT m res)) => (Key, Selection) -> Resolver m a -> ResolveT m res -encodeResolver selection@(fieldName, Selection {selectionPosition}) = - withExceptT (resolverError selectionPosition fieldName) >=> (`encode` selection) +encodeSubscription :: + forall m event mut. (Monad m, EncodeCon SUBSCRIPTION m event mut, Resolving SUBSCRIPTION m event) + => EncodeOperator SUBSCRIPTION m event mut +encodeSubscription = encodeOperationWith [] -resolveFields :: (Monad m, GQLValue a) => SelectionSet -> [FieldRes m a] -> ResolveT m a -resolveFields selectionSet resolvers = gqlObject <$> traverse selectResolver selectionSet - where - selectResolver (key, selection) = - (key, ) <$> - case selectionRec selection of - SelectionAlias name selectionRec -> lookupRes name (selection {selectionRec}) - _ -> lookupRes key selection - ------------------------------------------------------------- - where - lookupRes resKey sel = (fromMaybe (const $ return gqlNull) $ lookup resKey resolvers) (key, sel) +encodeOperationWith :: + forall o m e a . (Monad m, EncodeCon o m e a, Resolving o m e, PureOperation o) + => [FieldRes o m e] + -> EncodeOperator o m e a +encodeOperationWith externalRes rootResolver Operation {operationSelection} = resolveObject operationSelection resolvers + where + resolvers = externalRes <> objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver diff --git a/src/Data/Morpheus/Execution/Server/Interpreter.hs b/src/Data/Morpheus/Execution/Server/Interpreter.hs --- a/src/Data/Morpheus/Execution/Server/Interpreter.hs +++ b/src/Data/Morpheus/Execution/Server/Interpreter.hs @@ -18,9 +18,9 @@ import Data.Morpheus.Execution.Server.Resolve (RootResCon, byteStringIO, statefulResolver, statelessResolver, streamResolver) import Data.Morpheus.Execution.Subscription.ClientRegister (GQLState) +import Data.Morpheus.Types.Internal.Resolver (GQLRootResolver (..)) import Data.Morpheus.Types.Internal.Stream (ResponseStream) import Data.Morpheus.Types.IO (GQLRequest, GQLResponse) -import Data.Morpheus.Types.Resolver (GQLRootResolver (..)) -- | main query processor and resolver -- possible versions of interpreter @@ -39,32 +39,32 @@ -- -- or -- k :: GQLRequest -> IO GQLResponse -- @ -class Interpreter k m e c where +class Interpreter k m e where interpreter :: Monad m - => (RootResCon m e c que mut sub) => - GQLRootResolver m e c que mut sub -> k + => (RootResCon m e query mut sub) => + GQLRootResolver m e query mut sub -> k {- simple HTTP stateless Interpreter without side effects -} type StateLess m a = a -> m a -instance Interpreter (GQLRequest -> m GQLResponse) m e c where +instance Interpreter (GQLRequest -> m GQLResponse) m e where interpreter = statelessResolver -instance Interpreter (StateLess m LB.ByteString) m e c where +instance Interpreter (StateLess m LB.ByteString) m e where interpreter root = byteStringIO (statelessResolver root) -instance Interpreter (StateLess m LT.Text) m e c where +instance Interpreter (StateLess m LT.Text) m e where interpreter root request = decodeUtf8 <$> interpreter root (encodeUtf8 request) -instance Interpreter (StateLess m ByteString) m e c where +instance Interpreter (StateLess m ByteString) m e where interpreter root request = LB.toStrict <$> interpreter root (LB.fromStrict request) -instance Interpreter (StateLess m Text) m e c where +instance Interpreter (StateLess m Text) m e where interpreter root request = LT.toStrict <$> interpreter root (LT.fromStrict request) @@ -72,21 +72,21 @@ HTTP Interpreter with state and side effects, every mutation will trigger subscriptions in shared `GQLState` -} -type WSPub m e c a = GQLState m e c -> a -> m a +type WSPub m e a = GQLState m e -> a -> m a -instance Interpreter (WSPub IO e c LB.ByteString) IO e c where +instance Interpreter (WSPub IO e LB.ByteString) IO e where interpreter root state = statefulResolver state (byteStringIO (streamResolver root)) -instance Interpreter (WSPub IO e c LT.Text) IO e c where +instance Interpreter (WSPub IO e LT.Text) IO e where interpreter root state request = decodeUtf8 <$> interpreter root state (encodeUtf8 request) -instance Interpreter (WSPub IO e c ByteString) IO e c where +instance Interpreter (WSPub IO e ByteString) IO e where interpreter root state request = LB.toStrict <$> interpreter root state (LB.fromStrict request) -instance Interpreter (WSPub IO e c Text) IO e c where +instance Interpreter (WSPub IO e Text) IO e where interpreter root state request = LT.toStrict <$> interpreter root state (LT.fromStrict request) @@ -94,22 +94,22 @@ WebSocket Interpreter without state and side effects, mutations and subscription will return Actions that will be executed in WebSocket server -} -type WSSub m e c a = a -> ResponseStream m e c a +type WSSub m e a = a -> ResponseStream m e a -instance Interpreter (GQLRequest -> ResponseStream m e c LB.ByteString) m e c where +instance Interpreter (GQLRequest -> ResponseStream m e LB.ByteString) m e where interpreter root request = encode <$> streamResolver root request -instance Interpreter (WSSub m e c LB.ByteString) m e c where +instance Interpreter (WSSub m e LB.ByteString) m e where interpreter root = byteStringIO (streamResolver root) -instance Interpreter (WSSub m e c LT.Text) m e c where +instance Interpreter (WSSub m e LT.Text) m e where interpreter root request = decodeUtf8 <$> interpreter root (encodeUtf8 request) -instance Interpreter (WSSub m e c ByteString) m e c where +instance Interpreter (WSSub m e ByteString) m e where interpreter root request = LB.toStrict <$> interpreter root (LB.fromStrict request) -instance Interpreter (WSSub m e c Text) m e c where +instance Interpreter (WSSub m e Text) m e where interpreter root request = LT.toStrict <$> interpreter root (LT.fromStrict request) diff --git a/src/Data/Morpheus/Execution/Server/Resolve.hs b/src/Data/Morpheus/Execution/Server/Resolve.hs --- a/src/Data/Morpheus/Execution/Server/Resolve.hs +++ b/src/Data/Morpheus/Execution/Server/Resolve.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,7 +17,7 @@ ) where import Control.Monad.Except (liftEither) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Control.Monad.Trans.Except (runExceptT) import Data.Aeson (encode) import Data.Aeson.Internal (formatError, ifromJSON) import Data.Aeson.Parser (eitherDecodeWith, jsonNoDup) @@ -25,43 +26,46 @@ import Data.Proxy (Proxy (..)) -- MORPHEUS -import Data.Morpheus.Error.Utils (badRequestError, renderErrors) +import Data.Morpheus.Error.Utils (badRequestError) 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.Encode (EncodeCon, encodeMutation, encodeQuery, + encodeSubscription) 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) +--import Data.Morpheus.Schema.Schema (Root) import Data.Morpheus.Schema.SchemaAPI (defaultTypes, hiddenRootFields, schemaAPI) import Data.Morpheus.Types.GQLType (GQLType (CUSTOM)) import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation) import Data.Morpheus.Types.Internal.Data (DataFingerprint (..), DataTyCon (..), - DataTypeLib (..), OperationKind (..), initTypeLib) -import Data.Morpheus.Types.Internal.Stream (Event (..), ResponseEvent (..), ResponseStream, - StreamState (..), StreamT (..), closeStream, mapS) + DataTypeLib (..), MUTATION, OperationType (..), + QUERY, SUBSCRIPTION, initTypeLib) +import Data.Morpheus.Types.Internal.Resolver (GQLRootResolver (..), Resolver (..), ResponseT, + toResponseRes) +import Data.Morpheus.Types.Internal.Stream (GQLChannel (..), ResponseEvent (..), + ResponseStream, closeStream) import Data.Morpheus.Types.Internal.Validation (Validation) -import Data.Morpheus.Types.Internal.Value (Value (..)) -import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..)) -import Data.Morpheus.Types.Resolver (GQLRootResolver (..), Resolver, ResponseT) +import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..), renderResponse) import Data.Morpheus.Validation.Internal.Utils (VALIDATION_MODE (..)) import Data.Morpheus.Validation.Query.Validation (validateRequest) import Data.Typeable (Typeable) -type EventCon event = Eq event +type EventCon event = (Eq (StreamChannel event), Typeable event, GQLChannel event) -type RootResCon m event cont query mutation subscription +type IntrospectConstraint m event query mutation subscription = ( + IntroCon (query (Resolver QUERY m event)) + , IntroCon (mutation (Resolver MUTATION m event)) + , IntroCon (subscription (Resolver SUBSCRIPTION m event))) + +type RootResCon m event query mutation subscription = ( EventCon event , Typeable m - -- Introspection - , IntroCon query - , IntroCon mutation - , IntroCon subscription - , OBJ_RES m (Root (Resolver m)) Value + , IntrospectConstraint m event query mutation subscription + -- , OBJ_RES m (Root (Resolver m)) Value -- Resolving - , EncodeCon m query Value - , EncodeMutCon m event cont mutation - , EncodeSubCon m event cont subscription) + , EncodeCon QUERY m event (query (Resolver QUERY m event)) + , EncodeCon MUTATION m event (mutation (Resolver MUTATION m event)) + , EncodeCon SUBSCRIPTION m event (subscription (Resolver SUBSCRIPTION m event))) decodeNoDup :: L.ByteString -> Either String GQLRequest decodeNoDup str = @@ -76,53 +80,40 @@ Right req -> encode <$> resolver req statelessResolver :: - (Monad m, RootResCon m s cont query mut sub) - => GQLRootResolver m s cont query mut sub + (Monad m, RootResCon m event query mut sub) + => GQLRootResolver m event query mut sub -> GQLRequest -> m GQLResponse statelessResolver root = fmap snd . closeStream . streamResolver root streamResolver :: - (Monad m, RootResCon m event cont query mut sub) - => GQLRootResolver m event cont query mut sub + (Monad m, RootResCon m event query mut sub) + => GQLRootResolver m event query mut sub -> GQLRequest - -> ResponseStream m event cont GQLResponse + -> ResponseStream m event GQLResponse streamResolver root@GQLRootResolver {queryResolver, mutationResolver, subscriptionResolver} request = renderResponse <$> runExceptT (validRequest >>= execOperator) ------------------------------------------------------------ where - renderResponse (Left errors) = Errors $ renderErrors errors - renderResponse (Right value) = Data value --------------------------------------------------------- - validRequest :: Monad m => ResponseT m event cont (DataTypeLib, ValidOperation) + validRequest :: Monad m => ResponseT m event (DataTypeLib, ValidOperation) validRequest = liftEither $ do schema <- fullSchema $ Identity root query <- parseGQL request >>= validateRequest schema FULL_VALIDATION Right (schema, query) ---------------------------------------------------------- - execOperator (schema, operation@Operation {operationKind = Query}) = - ExceptT $ - StreamT - (StreamState [] <$> - runExceptT - (do schemaRes <- schemaAPI schema - ExceptT (encodeQuery schemaRes queryResolver operation))) - execOperator (_, operation@Operation {operationKind = Mutation}) = - ExceptT $ mapS Publish (encodeOperation mutationResolver operation) - execOperator (_, operation@Operation {operationKind = Subscription}) = - ExceptT $ StreamT $ handleActions <$> closeStream (encodeOperation subscriptionResolver operation) - where - handleActions (_, Left gqlError) = StreamState [] (Left gqlError) - handleActions (channels, Right subResolver) = - StreamState [Subscribe $ Event (concat channels) handleRes] (Right Null) - where - handleRes event = renderResponse <$> runExceptT (subResolver event) + execOperator (schema, operation@Operation {operationType = Query}) = + toResponseRes (encodeQuery (schemaAPI schema) queryResolver operation) + execOperator (_, operation@Operation {operationType = Mutation}) = toResponseRes (encodeMutation mutationResolver operation) + execOperator (_, operation@Operation {operationType = Subscription}) = response + where + response = toResponseRes (encodeSubscription subscriptionResolver operation) statefulResolver :: EventCon s - => GQLState IO s cont - -> (L.ByteString -> ResponseStream IO s cont L.ByteString) + => GQLState IO s + -> (L.ByteString -> ResponseStream IO s L.ByteString) -> L.ByteString -> IO L.ByteString statefulResolver state streamApi request = do @@ -134,23 +125,23 @@ execute Subscribe {} = pure () fullSchema :: - forall proxy m s cont query mutation subscription. (IntroCon query, IntroCon mutation, IntroCon subscription) - => proxy (GQLRootResolver m s cont query mutation subscription) + forall proxy m event query mutation subscription. (IntrospectConstraint m event query mutation subscription) + => proxy (GQLRootResolver m event query mutation subscription) -> Validation DataTypeLib fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema where querySchema = resolveUpdates (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query")) (defaultTypes : types) where - (fields, types) = objectFields (Proxy @(CUSTOM query)) (Proxy @query) + (fields, types) = objectFields (Proxy @(CUSTOM (query (Resolver QUERY m event)))) (Proxy @(query (Resolver QUERY m event))) ------------------------------ mutationSchema lib = resolveUpdates (lib {mutation = maybeOperator fields "Mutation"}) types where - (fields, types) = objectFields (Proxy @(CUSTOM mutation)) (Proxy @mutation) + (fields, types) = objectFields (Proxy @(CUSTOM (mutation (Resolver MUTATION m event)))) (Proxy @(mutation (Resolver MUTATION m event))) ------------------------------ subscriptionSchema lib = resolveUpdates (lib {subscription = maybeOperator fields "Subscription"}) types where - (fields, types) = objectFields (Proxy @(CUSTOM subscription)) (Proxy @subscription) + (fields, types) = objectFields (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION m event)))) (Proxy @(subscription (Resolver SUBSCRIPTION m event))) -- maybeOperator :: [a] -> Text -> Maybe (Text, DataTyCon[a]) maybeOperator [] = const Nothing maybeOperator fields = Just . operatorType fields diff --git a/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs b/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs --- a/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +++ b/src/Data/Morpheus/Execution/Subscription/ClientRegister.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns , FlexibleContexts #-} module Data.Morpheus.Execution.Subscription.ClientRegister ( ClientRegister @@ -18,23 +18,23 @@ import Data.Text (Text) import Data.UUID.V4 (nextRandom) import Network.WebSockets (Connection, sendTextData) - + -- MORPHEUS import Data.Morpheus.Execution.Subscription.Apollo (toApolloResponse) -import Data.Morpheus.Types.Internal.Stream (Event (..), PubEvent, SubEvent) +import Data.Morpheus.Types.Internal.Stream (Event (..),GQLChannel(..), SubEvent) import Data.Morpheus.Types.Internal.WebSocket (ClientID, ClientSession (..), GQLClient (..)) -type ClientRegister m e c = [(ClientID, GQLClient m e c)] +type ClientRegister m e = [(ClientID, GQLClient m e)] -- | shared GraphQL state between __websocket__ and __http__ server, -- stores information about subscriptions -type GQLState m e c = MVar (ClientRegister m e c) -- SharedState +type GQLState m e = MVar (ClientRegister m e ) -- SharedState -- | initializes empty GraphQL state -initGQLState :: IO (GQLState m e c) +initGQLState :: IO (GQLState m e) initGQLState = newMVar [] -connectClient :: Connection -> GQLState m e c -> IO (GQLClient m e c) +connectClient :: Connection -> GQLState m e -> IO (GQLClient m e) connectClient clientConnection varState' = do client' <- newClient modifyMVar_ varState' (addClient client') @@ -47,19 +47,19 @@ addClient client' state' = return (client' : state') disconnectClient :: - GQLClient m e c -> GQLState m e c -> IO (ClientRegister m e c) + GQLClient m e -> GQLState m e -> IO (ClientRegister m e) disconnectClient client state = modifyMVar state removeUser where removeUser state' = let s' = removeClient state' in return (s', s') - removeClient :: ClientRegister m e c -> ClientRegister m e c + removeClient :: ClientRegister m e -> ClientRegister m e removeClient = filter ((/= clientID client) . fst) updateClientByID :: ClientID - -> (GQLClient m e c -> GQLClient m e c) - -> MVar (ClientRegister m e c) + -> (GQLClient m e -> GQLClient m e) + -> MVar (ClientRegister m e ) -> IO () updateClientByID id' updateFunc state = modifyMVar_ state (return . map updateClient) @@ -68,7 +68,7 @@ | key' == id' = (key', updateFunc client') updateClient state' = state' -publishUpdates :: (Eq e) => GQLState IO e c -> PubEvent e c -> IO () +publishUpdates :: (Eq (StreamChannel e), GQLChannel e) => GQLState IO e -> e -> IO () publishUpdates state event = do state' <- readMVar state traverse_ sendMessage state' @@ -84,10 +84,10 @@ sendTextData clientConnection . toApolloResponse sessionId filterByChannels = filter - (([] /=) . - intersect (channels event) . channels . sessionSubscription) + (not . null . + intersect (streamChannels event) . channels . sessionSubscription) -removeClientSubscription :: ClientID -> Text -> GQLState m e c -> IO () +removeClientSubscription :: ClientID -> Text -> GQLState m e -> IO () removeClientSubscription id' sid' = updateClientByID id' stopSubscription where stopSubscription client' = @@ -97,7 +97,7 @@ } addClientSubscription :: - ClientID -> SubEvent m e c -> Text -> GQLState m e c -> IO () + ClientID -> SubEvent m e -> Text -> GQLState m e -> IO () addClientSubscription id' sessionSubscription sessionId = updateClientByID id' startSubscription where diff --git a/src/Data/Morpheus/Kind.hs b/src/Data/Morpheus/Kind.hs --- a/src/Data/Morpheus/Kind.hs +++ b/src/Data/Morpheus/Kind.hs @@ -15,8 +15,11 @@ , GQL_KIND , Context(..) , VContext(..) + , ResContext(..) ) where +import Data.Morpheus.Types.Internal.Data (OperationType (..)) + data GQL_KIND = SCALAR | OBJECT @@ -25,6 +28,9 @@ | UNION | INPUT_UNION | WRAPPER + + +data ResContext (kind :: GQL_KIND) (operation:: OperationType) (m :: * -> * ) event value = ResContext --type ObjectConstraint a = -- | context , like Proxy with multiple parameters diff --git a/src/Data/Morpheus/Parsing/Document/DataType.hs b/src/Data/Morpheus/Parsing/Document/DataType.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Document/DataType.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Document.DataType - ( parseDataType - ) where - -import Data.Morpheus.Parsing.Internal.Create (createArgument, createEnumType, createField, createScalarType, - createType, createUnionType) -import Data.Morpheus.Parsing.Internal.Internal (Parser) -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) -import Text.Megaparsec (label, sepBy1, some, (<|>)) -import Text.Megaparsec.Char (char, space1, string) - -dataArgument :: Parser (Text, DataArgument) -dataArgument = - 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 -typeDef kind = do - _ <- string kind - space1 - token - -dataInputObject :: Parser (Text, DataFullType) -dataInputObject = - label "inputObject" $ do - typeName <- typeDef "input" - typeData <- inputObjectEntries - pure (typeName, InputObject $ createType typeName typeData) - -inputObjectEntries :: Parser [(Key, DataArgument)] -inputObjectEntries = label "inputEntries" $ setOf entry - where - entry = - label "entry" $ do - ((fieldName, _), (wrappers, fieldType)) <- parseAssignment qualifier parseWrappedType - nonNull <- parseNonNull - return (fieldName, createField [] fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType)) - -outputObjectEntries :: Parser [(Key, DataField)] -outputObjectEntries = label "entries" $ setOf entry - where - fieldWithArgs = - label "fieldWithArgs" $ do - (name, _) <- qualifier - args <- parseMaybeTuple dataArgument - return (name, args) - entry = - label "entry" $ do - ((fieldName, fieldArgs), (wrappers, fieldType)) <- parseAssignment fieldWithArgs parseWrappedType - nonNull <- parseNonNull - return (fieldName, createField fieldArgs fieldName (toHSWrappers $ nonNull ++ wrappers, fieldType)) - -dataObject :: Parser (Text, RawDataType) -dataObject = - label "object" $ do - typeName <- typeDef "type" - interfaces <- maybeImplements - typeData <- outputObjectEntries - pure (typeName, Implements interfaces $ createType typeName typeData) - -maybeImplements :: Parser [Text] -maybeImplements = implements <|> pure [] - where - implements = - label "implements" $ do - _ <- string "implements" - space1 - spaceAndComments - some token - -dataInterface :: Parser (Text, RawDataType) -dataInterface = - label "interface" $ do - typeName <- typeDef "interface" - typeData <- outputObjectEntries - pure (typeName, Interface $ createType typeName typeData) - -dataScalar :: Parser (Text, DataFullType) -dataScalar = - label "scalar" $ do - typeName <- typeDef "scalar" - pure $ createScalarType typeName - -dataEnum :: Parser (Text, DataFullType) -dataEnum = - label "enum" $ do - typeName <- typeDef "enum" - typeData <- setOf token - pure $ createEnumType typeName typeData - -dataUnion :: Parser (Text, DataFullType) -dataUnion = - label "union" $ do - typeName <- typeDef "union" - _ <- char '=' - spaceAndComments - typeData <- unionsParser - spaceAndComments - pure $ createUnionType typeName typeData - where - unionsParser = token `sepBy1` pipeLiteral - -parseFinalDataType :: Parser (Text, DataFullType) -parseFinalDataType = label "dataType" $ dataInputObject <|> dataUnion <|> dataEnum <|> dataScalar - -parseDataType :: Parser (Text, RawDataType) -parseDataType = label "dataType" $ dataInterface <|> dataObject <|> finalDataT - where - finalDataT = do - (name, datatype) <- parseFinalDataType - pure (name, FinalDataType datatype) diff --git a/src/Data/Morpheus/Parsing/Document/Parser.hs b/src/Data/Morpheus/Parsing/Document/Parser.hs --- a/src/Data/Morpheus/Parsing/Document/Parser.hs +++ b/src/Data/Morpheus/Parsing/Document/Parser.hs @@ -5,15 +5,15 @@ ( parseTypes ) where -import Data.Text (Text) -import Text.Megaparsec (eof, label, manyTill, runParser) +import Data.Text (Text) +import Text.Megaparsec (eof, label, manyTill, runParser) -- MORPHEUS -import Data.Morpheus.Parsing.Document.DataType (parseDataType) -import Data.Morpheus.Parsing.Internal.Internal (processErrorBundle) -import Data.Morpheus.Parsing.Internal.Terms (spaceAndComments) -import Data.Morpheus.Types.Internal.Data (RawDataType) -import Data.Morpheus.Types.Internal.Validation (Validation) +import Data.Morpheus.Parsing.Document.TypeSystem (parseDataType) +import Data.Morpheus.Parsing.Internal.Internal (processErrorBundle) +import Data.Morpheus.Parsing.Internal.Terms (spaceAndComments) +import Data.Morpheus.Types.Internal.Data (RawDataType) +import Data.Morpheus.Types.Internal.Validation (Validation) parseTypes :: Text -> Validation [(Text, RawDataType)] parseTypes doc = diff --git a/src/Data/Morpheus/Parsing/Document/TypeSystem.hs b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Document/TypeSystem.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parsing.Document.TypeSystem + ( parseDataType + ) where + +import Data.Text (Text) +import Text.Megaparsec (label, sepBy1, (<|>)) + +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Create (createField) +import Data.Morpheus.Parsing.Internal.Internal (Parser) +import Data.Morpheus.Parsing.Internal.Pattern (fieldsDefinition, inputValueDefinition, optionalDirectives, + typDeclaration) +import Data.Morpheus.Parsing.Internal.Terms (keyword, operator, optDescription, parseName, pipeLiteral, + sepByAnd, setOf) +import Data.Morpheus.Types.Internal.Data (DataField, DataFingerprint (..), DataFullType (..), + DataLeaf (..), DataTyCon (..), DataValidator (..), Key, + RawDataType (..)) + + +-- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars +-- +-- ScalarTypeDefinition: +-- Description(opt) scalar Name Directives(Const)(opt) +-- +scalarTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +scalarTypeDefinition typeDescription = + label "ScalarTypeDefinition" $ do + typeName <- typDeclaration "scalar" + -- TODO: handle directives + _ <- optionalDirectives + pure ( + typeName, + Leaf $ CustomScalar DataTyCon { + typeName, + typeDescription, + typeFingerprint = SystemFingerprint typeName, + typeData = DataValidator pure + } + ) + +-- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects +-- +-- ObjectTypeDefinition: +-- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt) +-- +-- ImplementsInterfaces +-- implements &(opt) NamedType +-- ImplementsInterfaces & NamedType +-- +-- FieldsDefinition +-- { FieldDefinition(list) } +-- +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +objectTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) +objectTypeDefinition typeDescription = + label "ObjectTypeDefinition" $ do + name <- typDeclaration "type" + interfaces <- optionalImplementsInterfaces + -- TODO: handle directives + _directives <- optionalDirectives + fields <- fieldsDefinition + -------------------------- + pure (name, + Implements interfaces $ DataTyCon { + typeName = name, + typeDescription, + typeFingerprint = SystemFingerprint name, + typeData = fields + } + ) + +optionalImplementsInterfaces :: Parser [Text] +optionalImplementsInterfaces = implements <|> pure [] + where + implements = label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseName + +-- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces +-- +-- InterfaceTypeDefinition +-- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) +-- +interfaceTypeDefinition :: Maybe Text -> Parser (Text, RawDataType) +interfaceTypeDefinition typeDescription = + label "InterfaceTypeDefinition" $ do + typeName <- typDeclaration "interface" + -- TODO: handle directives + _directives <- optionalDirectives + fields <- fieldsDefinition + pure ( + typeName, + Interface DataTyCon { + typeName, + typeDescription, + typeFingerprint = SystemFingerprint typeName, + typeData = fields + } + ) + + +-- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions +-- +-- UnionTypeDefinition: +-- Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt) +-- +-- UnionMemberTypes: +-- = |(opt) NamedType +-- UnionMemberTypes | NamedType +-- +unionTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +unionTypeDefinition typeDescription = + label "UnionTypeDefinition" $ do + typeName <- typDeclaration "union" + -- TODO: handle directives + _directives <- optionalDirectives + memberTypes <- unionMemberTypes + pure ( + typeName, + Union DataTyCon { + typeName, + typeDescription, + typeFingerprint = SystemFingerprint typeName, + typeData = map unionField memberTypes + } + ) + where + unionField fieldType = createField [] "" ([], fieldType) + unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral + +-- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums +-- +-- EnumTypeDefinition +-- Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt) +-- +-- EnumValuesDefinition +-- { EnumValueDefinition(list) } +-- +-- EnumValueDefinition +-- Description(opt) EnumValue Directives(Const)(opt) +-- +enumTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +enumTypeDefinition typeDescription = + label "EnumTypeDefinition" $ do + typeName <- typDeclaration "enum" + -- TODO: handle directives + _directives <- optionalDirectives + enumValuesDefinition <- setOf enumValueDefinition + pure ( + typeName, + Leaf $ LeafEnum DataTyCon { + typeName, + typeDescription, + typeFingerprint = SystemFingerprint typeName, + typeData = enumValuesDefinition + } + ) + where + enumValueDefinition = label "EnumValueDefinition" $ do + -- TODO: handle Description + _fieldDescription <- optDescription + enumValueName <- parseName + -- TODO: handle directives + _directive <- optionalDirectives + return enumValueName + +-- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects +-- +-- InputObjectTypeDefinition +-- Description(opt) input Name Directives(Const)(opt) InputFieldsDefinition(opt) +-- +-- InputFieldsDefinition: +-- { InputValueDefinition(list) } +-- +inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataFullType) +inputObjectTypeDefinition typeDescription = + label "InputObjectTypeDefinition" $ do + typeName <- typDeclaration "input" + -- TODO: handle directives + _directives <- optionalDirectives + fields <- inputFieldsDefinition + pure + ( + typeName, + InputObject DataTyCon { + typeName, + typeDescription, + typeFingerprint = SystemFingerprint typeName, + typeData = fields + } + ) + where + inputFieldsDefinition :: Parser [(Key, DataField)] + inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition + + +parseFinalDataType :: Maybe Text -> Parser (Text, DataFullType) +parseFinalDataType description = label "TypeDefinition" $ + inputObjectTypeDefinition description + <|> unionTypeDefinition description + <|> enumTypeDefinition description + <|> scalarTypeDefinition description + +parseDataType :: Parser (Text, RawDataType) +parseDataType = label "TypeDefinition" $ do + description <- optDescription + types description + where + types description = interfaceTypeDefinition description <|> + objectTypeDefinition description <|> + finalDataT + where + finalDataT = do + (name, datatype) <- parseFinalDataType description + pure (name, FinalDataType datatype) diff --git a/src/Data/Morpheus/Parsing/Internal/Pattern.hs b/src/Data/Morpheus/Parsing/Internal/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Internal/Pattern.hs @@ -0,0 +1,100 @@ +module Data.Morpheus.Parsing.Internal.Pattern + ( inputValueDefinition + , fieldsDefinition + , typDeclaration + , optionalDirectives + ) where + + +import Text.Megaparsec (label, many) + +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Create (createField) +import Data.Morpheus.Parsing.Internal.Internal (Parser) +import Data.Morpheus.Parsing.Internal.Terms (keyword, optDescription, litAssignment, operator, parseAssignment, + parseMaybeTuple, parseName, parseType, setOf) +import Data.Morpheus.Parsing.Internal.Value (parseDefaultValue, parseValue) +import Data.Morpheus.Types.Internal.Data (DataField, Key, Name) + + +-- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition +-- +-- InputValueDefinition +-- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) +-- +inputValueDefinition :: Parser (Key, DataField) +inputValueDefinition = label "InputValueDefinition" $ do + -- TODO: handle Description(opt) + _description <- optDescription + name <- parseName + litAssignment -- ':' + type_ <- parseType + -- TODO: handle default value + _ <- parseDefaultValue + _ <- optionalDirectives + pure (name, createField [] name type_) + +-- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments +-- +-- ArgumentsDefinition: +-- ( InputValueDefinition(list) ) +-- +argumentsDefinition :: Parser [(Key, DataField)] +argumentsDefinition = label "ArgumentsDefinition" $ parseMaybeTuple inputValueDefinition + + +-- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition +-- +-- FieldsDefinition : +-- { FieldDefinition(list) } +-- +fieldsDefinition :: Parser [(Key, DataField)] +fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition + + +-- FieldDefinition +-- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) +-- +fieldDefinition :: Parser (Key, DataField) +fieldDefinition = label "FieldDefinition" $ do + -- TODO: handle Description(opt) + _description <- optDescription + name <- parseName + args <- argumentsDefinition + litAssignment -- ':' + type_ <- parseType + -- TODO: handle directives + _ <- optionalDirectives + pure (name, createField args name type_) + +-- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives +-- +-- example: @directive ( arg1: "value" , .... ) +-- +-- Directives[Const] +-- Directive[Const](list) +-- +optionalDirectives :: Parser [()] +optionalDirectives = label "Directives" $ many directive + +-- Directive[Const] +-- +-- @ Name Arguments[Const](opt) +-- TODO: returns real DataType +directive :: Parser () +directive = label "Directive" $ do + operator '@' + _name <- parseName + _args <- parseMaybeTuple (parseAssignment parseName parseValue) + pure () + + +-- typDeclaration : Not in spec ,start part of type definitions +-- +-- typDeclaration +-- Description(opt) scalar Name +-- +typDeclaration :: Name -> Parser Name +typDeclaration kind = do + keyword kind + parseName diff --git a/src/Data/Morpheus/Parsing/Internal/Terms.hs b/src/Data/Morpheus/Parsing/Internal/Terms.hs --- a/src/Data/Morpheus/Parsing/Internal/Terms.hs +++ b/src/Data/Morpheus/Parsing/Internal/Terms.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -10,25 +11,50 @@ , pipeLiteral ------------- , setOf - , onType + , parseTypeCondition , spreadLiteral , parseNonNull , parseMaybeTuple , parseAssignment , parseWrappedType , litEquals + , litAssignment + , parseTuple + , parseAlias + , sepByAnd + , parseName + , parseType + , keyword + , operator + , optDescription ) where import Data.Functor (($>)) -import Data.Morpheus.Parsing.Internal.Internal (Parser, Position, getLocation) -import Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..)) -import Data.Morpheus.Types.Internal.Value (convertToHaskellName) import Data.Text (Text, pack) -import Text.Megaparsec (between, label, many, sepBy, sepEndBy, skipMany, skipManyTill, - (), (<|>)) +import Text.Megaparsec (between, label,try, many, manyTill, optional, sepBy, sepEndBy, + skipMany, skipManyTill, try, (), (<|>)) import Text.Megaparsec.Char (char, digitChar, letterChar, newline, printChar, space, space1, string) +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal (Parser, Position, getLocation) +import Data.Morpheus.Types.Internal.Data (DataTypeWrapper (..), Key, Description , Name, WrapperD (..), toHSWrappers) +import Data.Morpheus.Types.Internal.Value (convertToHaskellName) + + +-- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names +-- +-- Name :: /[_A-Za-z][_0-9A-Za-z]*/ +-- +parseName :: Parser Name +parseName = token + +keyword :: Key -> Parser () +keyword word = string word *> space1 *> spaceAndComments + +operator :: Char -> Parser () +operator x = char x *> spaceAndComments + -- LITERALS setLiteral :: Parser [a] -> Parser [a] setLiteral = between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments) @@ -39,6 +65,9 @@ litEquals :: Parser () litEquals = char '=' *> spaceAndComments +litAssignment :: Parser () +litAssignment = char ':' *> spaceAndComments + -- PRIMITIVE ------------------------------------ token :: Parser Text @@ -56,6 +85,11 @@ value <- token return (value, position) + +-- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable +-- +-- Variable : $Name +-- variable :: Parser (Text, Position) variable = label "variable" $ do @@ -67,16 +101,47 @@ spaceAndComments1 :: Parser () spaceAndComments1 = space1 *> spaceAndComments +-- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description +-- +-- Description: +-- StringValue +-- TODO: should support """ and " +-- +optDescription :: Parser (Maybe Description) +optDescription = optional parseDescription + +parseDescription :: Parser Text +parseDescription = pack <$> (blockDescription <|> singleLine) <* spaceAndComments + where + blockDescription = blockQuotes *> manyTill (printChar <|> newline) blockQuotes <* spaceAndComments + where + blockQuotes = string "\"\"\"" + ---------------------------- + singleLine = stringQuote *> manyTill printChar stringQuote <* spaceAndComments + where + stringQuote = char '"' + +-- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens +-- Ignored: +-- UnicodeBOM +-- WhiteSpace +-- LineTerminator +-- Comment +-- Comma +-- TODO: implement as in specification spaceAndComments :: Parser () -spaceAndComments = space *> skipMany (inlineComment <|> multilineComment) *> space +spaceAndComments = ignoredTokens + +ignoredTokens :: Parser () +ignoredTokens = label "IgnoredTokens" $ space *> skipMany inlineComment *> space where inlineComment = char '#' *> skipManyTill printChar newline *> space ------------------------------------------------------------------------ - multilineComment = multilineIndicator *> skipManyTill (printChar *> space <|> space) multilineIndicator *> space - -------------------- - multilineIndicator = string "\"\"\"" -- COMPLEX +sepByAnd :: Parser a -> Parser [a] +sepByAnd entry = entry `sepBy` (char '&' *> spaceAndComments) + ----------------------------- setOf :: Parser a -> Parser [a] setOf entry = setLiteral (entry `sepEndBy` many (char ',' *> spaceAndComments)) @@ -102,12 +167,17 @@ parseAssignment nameParser valueParser = label "assignment" $ do name' <- nameParser - char ':' *> spaceAndComments + litAssignment value' <- valueParser pure (name', value') -onType :: Parser Text -onType = do +-- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions +-- +-- TypeCondition: +-- on NamedType +-- +parseTypeCondition :: Parser Text +parseTypeCondition = do _ <- string "on" space1 token @@ -133,3 +203,18 @@ (do (wrappers, name) <- unwrapped <|> wrapped nonNull' <- parseNonNull return ((ListType : nonNull') ++ wrappers, name)) + +-- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias +-- Alias +-- Name: +parseAlias :: Parser (Maybe Key) +parseAlias = try (optional alias) <|> pure Nothing + where + alias = label "alias" $ token <* char ':' <* spaceAndComments + + +parseType :: Parser ([WrapperD],Key) +parseType = do + (wrappers, fieldType) <- parseWrappedType + nonNull <- parseNonNull + pure (toHSWrappers $ nonNull ++ wrappers, fieldType) diff --git a/src/Data/Morpheus/Parsing/Internal/Value.hs b/src/Data/Morpheus/Parsing/Internal/Value.hs --- a/src/Data/Morpheus/Parsing/Internal/Value.hs +++ b/src/Data/Morpheus/Parsing/Internal/Value.hs @@ -29,7 +29,14 @@ parseValue :: Parser Value parseValue = label "value" $ do - value <- valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue <|> objectValue <|> listValue + value <- + valueNull + <|> booleanValue + <|> valueNumber + <|> enumValue + <|> stringValue + <|> objectValue + <|> listValue spaceAndComments return value diff --git a/src/Data/Morpheus/Parsing/Request/Arguments.hs b/src/Data/Morpheus/Parsing/Request/Arguments.hs --- a/src/Data/Morpheus/Parsing/Request/Arguments.hs +++ b/src/Data/Morpheus/Parsing/Request/Arguments.hs @@ -4,14 +4,25 @@ ( maybeArguments ) where +import Text.Megaparsec (label, (<|>)) + +-- MORPHEUS import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) import Data.Morpheus.Parsing.Internal.Terms (parseAssignment, parseMaybeTuple, token, variable) 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.RawSelection (Argument (..), RawArgument (..), RawArguments) import Data.Morpheus.Types.Internal.AST.Selection (ArgumentOrigin (..)) -import Text.Megaparsec (label, (<|>)) +import Data.Morpheus.Types.Internal.Base (Reference (..)) + +-- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments +-- +-- Arguments[Const] +-- ( Argument[Const](list) ) +-- +-- Argument[Const] +-- Name : Value[Const] +-- TODO: move variable to Value valueArgument :: Parser RawArgument valueArgument = label "valueArgument" $ do diff --git a/src/Data/Morpheus/Parsing/Request/Body.hs b/src/Data/Morpheus/Parsing/Request/Body.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Body.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Request.Body - ( entries - ) where - -import Data.Text (Text) -import Text.Megaparsec (label, try, (<|>)) - --- --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) -import Data.Morpheus.Parsing.Internal.Terms (onType, parseAssignment, qualifier, setOf, - spreadLiteral, token) -import Data.Morpheus.Parsing.Request.Arguments (maybeArguments) -import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..), - RawSelection' (..), RawSelectionSet, Reference (..)) - -spread :: Parser (Text, RawSelection) -spread = - label "spread" $ do - referencePosition <- spreadLiteral - referenceName <- token - return (referenceName, Spread $ Reference {referenceName, referencePosition}) - -inlineFragment :: Parser (Text, RawSelection) -inlineFragment = - label "InlineFragment" $ do - fragmentPosition <- spreadLiteral - fragmentType <- onType - fragmentSelection <- entries - pure ("INLINE_FRAGMENT", InlineFragment $ Fragment {fragmentType, fragmentSelection, fragmentPosition}) - -{- - accept: - - field - - field {...} - - field (...) - - field () {...} --} -parseSelectionField :: Parser (Text, RawSelection) -parseSelectionField = - label "SelectionField" $ do - (name, position) <- qualifier - arguments <- maybeArguments - value <- body arguments <|> buildField arguments position - return (name, value) - where - buildField rawSelectionArguments rawSelectionPosition = - pure (RawSelectionField $ RawSelection' {rawSelectionArguments, rawSelectionRec = (), rawSelectionPosition}) - -alias :: Parser (Text, RawSelection) -alias = - label "alias" $ do - ((name, rawAliasPosition), rawAliasSelection) <- parseAssignment qualifier parseSelectionField - return (name, RawAlias {rawAliasPosition, rawAliasSelection}) - -entries :: Parser RawSelectionSet -entries = label "entries" $ setOf entry - where - entry = label "entry" $ try inlineFragment <|> try spread <|> try alias <|> parseSelectionField - -body :: RawArguments -> Parser RawSelection -body rawSelectionArguments = - label "body" $ do - rawSelectionPosition <- getLocation - rawSelectionRec <- entries - return (RawSelectionSet $ RawSelection' {rawSelectionArguments, rawSelectionRec, rawSelectionPosition}) diff --git a/src/Data/Morpheus/Parsing/Request/Fragment.hs b/src/Data/Morpheus/Parsing/Request/Fragment.hs deleted file mode 100644 --- a/src/Data/Morpheus/Parsing/Request/Fragment.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Morpheus.Parsing.Request.Fragment - ( fragment - ) where - -import Data.Text (Text) -import Text.Megaparsec (label) -import Text.Megaparsec.Char (space, string) - --- MORPHEUS -import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) -import Data.Morpheus.Parsing.Internal.Terms (onType, token) -import Data.Morpheus.Parsing.Request.Body (entries) -import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..)) - -fragment :: Parser (Text, Fragment) -fragment = - label "fragment" $ do - _ <- string "fragment" - space - fragmentPosition <- getLocation - name <- token - fragmentType <- onType - fragmentSelection <- entries - pure (name, Fragment {fragmentType, fragmentSelection, fragmentPosition}) diff --git a/src/Data/Morpheus/Parsing/Request/Operation.hs b/src/Data/Morpheus/Parsing/Request/Operation.hs --- a/src/Data/Morpheus/Parsing/Request/Operation.hs +++ b/src/Data/Morpheus/Parsing/Request/Operation.hs @@ -2,69 +2,88 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Parsing.Request.Operation - ( parseAnonymousQuery - , parseOperation + (parseOperation ) where import Data.Functor (($>)) import Data.Text (Text) -import Text.Megaparsec (label, (), (<|>)) +import Text.Megaparsec (label, optional, (), (<|>)) import Text.Megaparsec.Char (string) -- -- MORPHEUS 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.Pattern (optionalDirectives) +import Data.Morpheus.Parsing.Internal.Terms (operator, parseMaybeTuple, parseName, parseType, + spaceAndComments1, variable) import Data.Morpheus.Parsing.Internal.Value (parseDefaultValue) -import Data.Morpheus.Parsing.Request.Body (entries) +import Data.Morpheus.Parsing.Request.Selection (parseSelectionSet) import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), RawOperation, Variable (..)) -import Data.Morpheus.Types.Internal.Data (OperationKind (..), toHSWrappers) +import Data.Morpheus.Types.Internal.Data (OperationType (..), isNullable) -operationArgument :: Parser (Text, Variable DefaultValue) -operationArgument = - label "operatorArgument" $ do - ((name, variablePosition), (wrappers, variableType)) <- parseAssignment variable parseWrappedType - nonNull <- parseNonNull + +-- Variables : https://graphql.github.io/graphql-spec/June2018/#VariableDefinition +-- +-- VariableDefinition +-- Variable : Type DefaultValue(opt) +-- +variableDefinition :: Parser (Text, Variable DefaultValue) +variableDefinition = + label "VariableDefinition" $ do + (name, variablePosition) <- variable + operator ':' + (variableTypeWrappers, variableType) <- parseType defaultValue <- parseDefaultValue pure ( name , Variable { variableType - , isVariableRequired = 0 < length nonNull - , variableTypeWrappers = toHSWrappers $ nonNull ++ wrappers + , isVariableRequired = not (isNullable variableTypeWrappers) + , variableTypeWrappers , variablePosition , variableValue = defaultValue }) -parseOperation :: Parser RawOperation -parseOperation = - label "operator" $ do +-- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations +-- +-- OperationDefinition +-- OperationType Name(opt) VariableDefinitions(opt) Directives(opt) SelectionSet +-- +-- OperationType: one of +-- query, mutation, subscription +parseOperationDefinition :: Parser RawOperation +parseOperationDefinition = + label "OperationDefinition" $ do operationPosition <- getLocation - operationKind <- parseOperationKind - operationName <- token - operationArgs <- parseMaybeTuple operationArgument - operationSelection <- entries - pure (Operation {operationName, operationKind, operationArgs, operationSelection, operationPosition}) + operationType <- parseOperationType + operationName <- optional parseName + operationArgs <- parseMaybeTuple variableDefinition + -- TODO: handle directives + _directives <- optionalDirectives + operationSelection <- parseSelectionSet + pure (Operation {operationName, operationType, operationArgs, operationSelection, operationPosition}) +parseOperationType :: Parser OperationType +parseOperationType = + label "OperationType" $ do + kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription) + spaceAndComments1 + return kind + parseAnonymousQuery :: Parser RawOperation parseAnonymousQuery = label "AnonymousQuery" $ do operationPosition <- getLocation - operationSelection <- entries + operationSelection <- parseSelectionSet pure (Operation - { operationName = "AnonymousQuery" - , operationKind = Query + { operationName = Nothing + , operationType = Query , operationArgs = [] , operationSelection , operationPosition }) "can't parse AnonymousQuery" -parseOperationKind :: Parser OperationKind -parseOperationKind = - label "operatorKind" $ do - kind <- (string "query" $> Query) <|> (string "mutation" $> Mutation) <|> (string "subscription" $> Subscription) - spaceAndComments1 - return kind +parseOperation :: Parser RawOperation +parseOperation = parseAnonymousQuery <|> parseOperationDefinition diff --git a/src/Data/Morpheus/Parsing/Request/Parser.hs b/src/Data/Morpheus/Parsing/Request/Parser.hs --- a/src/Data/Morpheus/Parsing/Request/Parser.hs +++ b/src/Data/Morpheus/Parsing/Request/Parser.hs @@ -9,14 +9,14 @@ import Data.HashMap.Lazy (toList) import Data.Text (Text) import Data.Void (Void) -import Text.Megaparsec (ParseErrorBundle, eof, label, manyTill, runParser, (<|>)) +import Text.Megaparsec (ParseErrorBundle, eof, label, manyTill, runParser) -- -- MORPHEUS import Data.Morpheus.Parsing.Internal.Internal (Parser, processErrorBundle) import Data.Morpheus.Parsing.Internal.Terms (spaceAndComments) -import Data.Morpheus.Parsing.Request.Fragment (fragment) -import Data.Morpheus.Parsing.Request.Operation (parseAnonymousQuery, parseOperation) +import Data.Morpheus.Parsing.Request.Operation (parseOperation) +import Data.Morpheus.Parsing.Request.Selection (parseFragmentDefinition) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Internal.Value (Value (..), replaceValue) import Data.Morpheus.Types.IO (GQLRequest (..)) @@ -29,8 +29,8 @@ request = label "GQLQueryRoot" $ do spaceAndComments - operation <- parseAnonymousQuery <|> parseOperation - fragments <- manyTill fragment eof + operation <- parseOperation + fragments <- manyTill parseFragmentDefinition eof pure GQLQueryRoot {operation, fragments, inputVariables = []} parseGQL :: GQLRequest -> Validation GQLQueryRoot diff --git a/src/Data/Morpheus/Parsing/Request/Selection.hs b/src/Data/Morpheus/Parsing/Request/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Parsing/Request/Selection.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Morpheus.Parsing.Request.Selection + ( parseSelectionSet + , parseFragmentDefinition + ) where + +import Data.Text (Text) +import Text.Megaparsec (label, try, (<|>)) + +-- +-- MORPHEUS +import Data.Morpheus.Parsing.Internal.Internal (Parser, getLocation) +import Data.Morpheus.Parsing.Internal.Pattern (optionalDirectives) +import Data.Morpheus.Parsing.Internal.Terms (keyword, parseAlias, parseName, parseTypeCondition, + setOf, spreadLiteral, token) +import Data.Morpheus.Parsing.Request.Arguments (maybeArguments) +import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), RawArguments, RawSelection (..), + RawSelectionSet, Reference (..)) +import Data.Morpheus.Types.Internal.AST.Selection (Selection (..)) + + +-- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets +-- +-- SelectionSet: +-- { Selection(list) } +-- +-- Selection: +-- Field +-- FragmentSpread +-- InlineFragment +-- +parseSelectionSet :: Parser RawSelectionSet +parseSelectionSet = label "SelectionSet" $ setOf parseSelection + where + parseSelection = label "Selection" $ + try inlineFragment + <|> try spread + <|> parseSelectionField + +-- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields +-- +-- Field +-- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) +-- +parseSelectionField :: Parser (Text, RawSelection) +parseSelectionField = + label "SelectionField" $ do + position <- getLocation + aliasName <- parseAlias + name <- parseName + arguments <- maybeArguments + -- TODO: handle Directives + _directives <- optionalDirectives + value <- selSet aliasName arguments <|> buildField aliasName arguments position + return (name, value) + where + ---------------------------------------- + buildField selectionAlias selectionArguments selectionPosition = + pure (RawSelectionField $ Selection { selectionAlias , selectionArguments, selectionRec = (), selectionPosition}) + ----------------------------------------- + selSet :: Maybe Text -> RawArguments -> Parser RawSelection + selSet selectionAlias selectionArguments = + label "body" $ do + selectionPosition <- getLocation + selectionRec <- parseSelectionSet + return (RawSelectionSet $ Selection {selectionAlias , selectionArguments, selectionRec, selectionPosition}) + + +-- +-- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments +-- +-- FragmentName : Name +-- + +-- FragmentSpread +-- ...FragmentName Directives(opt) +-- +spread :: Parser (Text, RawSelection) +spread = + label "FragmentSpread" $ do + referencePosition <- spreadLiteral + referenceName <- token + -- TODO: handle Directives + _directives <- optionalDirectives + return (referenceName, Spread $ Reference {referenceName, referencePosition}) + +-- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition +-- +-- FragmentDefinition: +-- fragment FragmentName TypeCondition Directives(opt) SelectionSet +-- +parseFragmentDefinition :: Parser (Text, Fragment) +parseFragmentDefinition = + label "FragmentDefinition" $ do + keyword "fragment" + fragmentPosition <- getLocation + name <- parseName + fragmentType <- parseTypeCondition + -- TODO: handle Directives + _directives <- optionalDirectives + fragmentSelection <- parseSelectionSet + pure (name, Fragment {fragmentType, fragmentSelection, fragmentPosition}) + +-- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments +-- +-- InlineFragment: +-- ... TypeCondition(opt) Directives(opt) SelectionSet +-- +inlineFragment :: Parser (Text, RawSelection) +inlineFragment = + label "InlineFragment" $ do + fragmentPosition <- spreadLiteral + -- TODO: optional + fragmentType <- parseTypeCondition + -- TODO: handle Directives + _directives <- optionalDirectives + fragmentSelection <- parseSelectionSet + pure ("INLINE_FRAGMENT", InlineFragment $ Fragment {fragmentType, fragmentSelection, fragmentPosition}) diff --git a/src/Data/Morpheus/Schema/Schema.hs b/src/Data/Morpheus/Schema/Schema.hs --- a/src/Data/Morpheus/Schema/Schema.hs +++ b/src/Data/Morpheus/Schema/Schema.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances , FlexibleContexts #-} module Data.Morpheus.Schema.Schema ( Root(..) diff --git a/src/Data/Morpheus/Schema/SchemaAPI.hs b/src/Data/Morpheus/Schema/SchemaAPI.hs --- a/src/Data/Morpheus/Schema/SchemaAPI.hs +++ b/src/Data/Morpheus/Schema/SchemaAPI.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -21,25 +20,23 @@ 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 (..), +import Data.Morpheus.Types.Internal.Data (DataField (..), DataObject, DataTypeLib (..), QUERY, allDataTypes) -import Data.Morpheus.Types.Resolver (GQLFail (..), ResolveT, Resolver) +import Data.Morpheus.Types.Internal.Resolver (Resolver (..)) -convertTypes :: Monad m => DataTypeLib -> (Resolver m) [S__Type (Resolver m)] +convertTypes :: Monad m => DataTypeLib -> Resolver QUERY m e [S__Type (Resolver QUERY m e )] convertTypes lib = traverse (`render` lib) (allDataTypes lib) -buildSchemaLinkType :: Monad m => (Text, DataObject) -> S__Type (Resolver m) +buildSchemaLinkType :: Monad m => (Text, DataObject) -> S__Type (Resolver QUERY m e ) buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just [] -findType :: Monad m => Text -> DataTypeLib -> Resolver m (Maybe (S__Type (Resolver m))) -findType name lib = getType >>= renderT +findType :: Monad m => Text -> DataTypeLib -> Resolver QUERY m e (Maybe (S__Type (Resolver QUERY m e ))) +findType name lib = renderT (lookup name (allDataTypes lib)) where - getType = pure $ (name, ) <$> lookup name (allDataTypes lib) - ------------------------------------------------------------ - renderT (Just datatype) = toSuccess (const Nothing) Just (render datatype lib) + renderT (Just datatype) = Just <$> render (name,datatype) lib renderT Nothing = pure Nothing -initSchema :: Monad m => DataTypeLib -> (Resolver m) (S__Schema (Resolver m)) +initSchema :: Monad m => DataTypeLib -> Resolver QUERY m e (S__Schema (Resolver QUERY m e )) initSchema lib = pure S__Schema @@ -68,8 +65,8 @@ , introspect (Proxy @(S__Schema Maybe)) ] -schemaAPI :: Monad m => DataTypeLib -> ResolveT m (Root (Resolver m)) -schemaAPI lib = pure $ Root {root__type, root__schema} +schemaAPI :: Monad m => DataTypeLib -> Root (Resolver QUERY m e) +schemaAPI lib = Root {root__type, root__schema} where root__type (Root__typeArgs name) = findType name lib root__schema _ = initSchema lib diff --git a/src/Data/Morpheus/Server.hs b/src/Data/Morpheus/Server.hs --- a/src/Data/Morpheus/Server.hs +++ b/src/Data/Morpheus/Server.hs @@ -24,17 +24,16 @@ import Data.Morpheus.Execution.Subscription.ClientRegister (GQLState, addClientSubscription, connectClient, disconnectClient, initGQLState, publishUpdates, removeClientSubscription) -import Data.Morpheus.Types.Internal.Stream (ResponseEvent (..), ResponseStream, closeStream) +import Data.Morpheus.Types.Internal.Resolver (GQLRootResolver (..)) +import Data.Morpheus.Types.Internal.Stream (GQLChannel (..), ResponseEvent (..), + ResponseStream, closeStream) import Data.Morpheus.Types.Internal.WebSocket (GQLClient (..)) import Data.Morpheus.Types.IO (GQLResponse (..)) -import Data.Morpheus.Types.Resolver (GQLRootResolver (..)) -handleSubscription :: - Eq e - => GQLClient IO e c - -> GQLState IO e c +handleSubscription :: (Eq (StreamChannel e), GQLChannel e) => GQLClient IO e + -> GQLState IO e -> Text - -> ResponseStream IO e c GQLResponse + -> ResponseStream IO e GQLResponse -> IO () handleSubscription GQLClient {clientConnection, clientID} state sessionId stream = do (actions, response) <- closeStream stream @@ -48,9 +47,9 @@ -- | Wai WebSocket Server App for GraphQL subscriptions gqlSocketApp :: - RootResCon IO e c que mut sub - => GQLRootResolver IO e c que mut sub - -> GQLState IO e c + RootResCon IO e que mut sub + => GQLRootResolver IO e que mut sub + -> GQLState IO e -> ServerApp gqlSocketApp gqlRoot state pending = do connection <- diff --git a/src/Data/Morpheus/Types.hs b/src/Data/Morpheus/Types.hs --- a/src/Data/Morpheus/Types.hs +++ b/src/Data/Morpheus/Types.hs @@ -1,16 +1,7 @@ +{-# LANGUAGE DataKinds #-} -- | GQL Types module Data.Morpheus.Types - ( resolver - , mutResolver - , toMutResolver - -- Resolver Monad - , IORes - , IOMutRes - , IOSubRes - , Resolver - , SubRootRes - , SubResolver(..) - , Event(..) + ( Event(..) -- Type Classes , GQLType(KIND, description) , GQLScalar(parseValue, serialize) @@ -21,22 +12,40 @@ , ScalarValue(..) , GQLRootResolver(..) , constRes + , constMutRes + , Undefined(..) + , Res + , MutRes + , SubRes + , IORes + , IOMutRes + , IOSubRes + , Resolver(..) + , QUERY + , MUTATION + , SUBSCRIPTION ) where -import Data.Morpheus.Types.GQLScalar (GQLScalar (parseValue, serialize)) -import Data.Morpheus.Types.GQLType (GQLType (KIND, description)) -import Data.Morpheus.Types.ID (ID (..)) -import Data.Morpheus.Types.Internal.Value (ScalarValue (..)) -import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..)) -import Data.Morpheus.Types.Resolver (Event (..), GQLRootResolver (..), MutResolver, Resolver, - SubResolver (..), SubRootRes, mutResolver, resolver, toMutResolver) +import Data.Morpheus.Types.GQLScalar (GQLScalar (parseValue, serialize)) +import Data.Morpheus.Types.GQLType (GQLType (KIND, description)) +import Data.Morpheus.Types.ID (ID (..)) +import Data.Morpheus.Types.Internal.Data (MUTATION, QUERY, SUBSCRIPTION) +import Data.Morpheus.Types.Internal.Resolver (Event (..), GQLRootResolver (..), PureOperation, Resolver (..)) +import Data.Morpheus.Types.Internal.Value (ScalarValue (..)) +import Data.Morpheus.Types.IO (GQLRequest (..), GQLResponse (..)) +import Data.Morpheus.Types.Types (Undefined (..)) --- resolves constant value on any argument -constRes :: Monad m => b -> a -> m b -constRes = const . return +type Res = Resolver QUERY +type MutRes = Resolver MUTATION +type SubRes = Resolver SUBSCRIPTION -type IORes = Resolver IO +type IORes = Res IO +type IOMutRes = MutRes IO +type IOSubRes = SubRes IO -type IOMutRes e c = MutResolver IO e c +-- resolves constant value on any argument +constRes :: (PureOperation o ,Monad m) => b -> a -> Resolver o m e b +constRes = const . pure -type IOSubRes e c = SubResolver IO e c +constMutRes :: Monad m => [e] -> a -> args -> MutRes m e a +constMutRes list value = const $ MutResolver list $ pure value diff --git a/src/Data/Morpheus/Types/Custom.hs b/src/Data/Morpheus/Types/Custom.hs --- a/src/Data/Morpheus/Types/Custom.hs +++ b/src/Data/Morpheus/Types/Custom.hs @@ -33,12 +33,12 @@ } deriving (Generic) -mapKindFromList :: (Eq k, Monad m) => [(k, v)] -> MapKind k v m +mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m mapKindFromList inputPairs = MapKind {size = length inputPairs, pairs = resolvePairs} where filterBy MapArgs {oneOf = Just list} = filter ((`elem` list) . fst) inputPairs filterBy _ = inputPairs - resolvePairs = return . (map toGQLTuple . filterBy) + resolvePairs = pure . (map toGQLTuple . filterBy) toGQLTuple (x, y) = Pair x y diff --git a/src/Data/Morpheus/Types/GQLType.hs b/src/Data/Morpheus/Types/GQLType.hs --- a/src/Data/Morpheus/Types/GQLType.hs +++ b/src/Data/Morpheus/Types/GQLType.hs @@ -16,28 +16,26 @@ , FALSE ) where -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.Text (Text, intercalate, pack) -import Data.Typeable (TyCon, TypeRep, Typeable, splitTyConApp, tyConFingerprint, - tyConName, typeRep, typeRepTyCon) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import Data.Text (Text, intercalate, pack) +import Data.Typeable (TyCon, TypeRep, Typeable, splitTyConApp, tyConFingerprint, + tyConName, typeRep, typeRepTyCon) -- MORPHEUS import Data.Morpheus.Kind -import Data.Morpheus.Types.Custom (MapKind, Pair) -import Data.Morpheus.Types.Internal.Data (DataFingerprint (..)) -import Data.Morpheus.Types.Resolver (Resolver, SubResolver) +import Data.Morpheus.Types.Custom (MapKind, Pair) +import Data.Morpheus.Types.Internal.Data (DataFingerprint (..), QUERY) +import Data.Morpheus.Types.Internal.Resolver (Resolver (..)) +import Data.Morpheus.Types.Types (Undefined (..)) type TRUE = 'True type FALSE = 'False resolverCon :: TyCon -resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver Maybe) - -subResCon :: TyCon -subResCon = typeRepTyCon $ typeRep $ Proxy @(SubResolver Maybe) +resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY Maybe) -- | replaces typeName (A,B) with Pair_A_B replacePairCon :: TyCon -> TyCon @@ -51,7 +49,7 @@ -- Ignores Resolver name from typeName ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon] ignoreResolver (con, _) - | con `elem` [resolverCon, subResCon] = [] + | con == resolverCon = [] ignoreResolver (con, args) = con : concatMap (ignoreResolver . splitTyConApp) args -- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'. @@ -92,6 +90,10 @@ type KIND () = WRAPPER type CUSTOM () = 'False +instance Typeable m => GQLType (Undefined m) where + type KIND (Undefined m) = WRAPPER + type CUSTOM (Undefined m) = 'False + instance GQLType Int where type KIND Int = SCALAR @@ -111,6 +113,7 @@ __typeName _ = __typeName (Proxy @a) __typeFingerprint _ = __typeFingerprint (Proxy @a) + instance GQLType a => GQLType [a] where type KIND [a] = WRAPPER __typeName _ = __typeName (Proxy @a) @@ -141,15 +144,10 @@ __typeName _ = __typeName (Proxy @a) __typeFingerprint _ = __typeFingerprint (Proxy @a) -instance GQLType a => GQLType (Resolver m a) where - type KIND (Resolver m a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) - -instance GQLType a => GQLType (SubResolver m e c a) where - type KIND (SubResolver m e c a) = WRAPPER - __typeName _ = __typeName (Proxy @a) - __typeFingerprint _ = __typeFingerprint (Proxy @a) +instance GQLType a => GQLType (Resolver o m e a) where + type KIND (Resolver o m e a) = WRAPPER + __typeName _ = __typeName (Proxy @a) + __typeFingerprint _ = __typeFingerprint (Proxy @a) instance GQLType b => GQLType (a -> b) where type KIND (a -> b) = WRAPPER diff --git a/src/Data/Morpheus/Types/IO.hs b/src/Data/Morpheus/Types/IO.hs --- a/src/Data/Morpheus/Types/IO.hs +++ b/src/Data/Morpheus/Types/IO.hs @@ -6,6 +6,7 @@ ( GQLRequest(..) , GQLResponse(..) , JSONResponse(..) + , renderResponse ) where import Data.Aeson (FromJSON (..), ToJSON (..), pairs, withObject, (.:?), (.=)) @@ -15,8 +16,13 @@ -- MORPHEUS import Data.Morpheus.Types.Internal.Base (Key) -import Data.Morpheus.Types.Internal.Validation (JSONError (..)) +import Data.Morpheus.Types.Internal.Validation (JSONError (..),Validation) import Data.Morpheus.Types.Internal.Value (Value) +import Data.Morpheus.Error.Utils ( renderErrors) + +renderResponse :: Validation Value -> GQLResponse +renderResponse (Left errors) = Errors $ renderErrors errors +renderResponse (Right value) = Data value instance FromJSON a => FromJSON (JSONResponse a) where parseJSON = withObject "JSONResponse" objectParser diff --git a/src/Data/Morpheus/Types/Internal/AST/Operation.hs b/src/Data/Morpheus/Types/Internal/AST/Operation.hs --- a/src/Data/Morpheus/Types/Internal/AST/Operation.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Operation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Types.Internal.AST.Operation @@ -10,15 +11,19 @@ , VariableDefinitions , ValidVariables , DefaultValue + , getOperationName ) where +import Data.Maybe (fromMaybe) +import Language.Haskell.TH.Syntax (Lift (..)) + +-- MORPHEUS import Data.Morpheus.Types.Internal.AST.RawSelection (RawSelectionSet) import Data.Morpheus.Types.Internal.AST.Selection (Arguments, SelectionSet) import Data.Morpheus.Types.Internal.Base (Collection, Key, Position) -import Data.Morpheus.Types.Internal.Data (OperationKind, WrapperD) -import Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap) +import Data.Morpheus.Types.Internal.Data (OperationType, WrapperD) +import Data.Morpheus.Types.Internal.TH (apply, liftMaybeText, liftText, liftTextMap) import Data.Morpheus.Types.Internal.Value (Value) -import Language.Haskell.TH.Syntax (Lift (..)) type DefaultValue = Maybe Value @@ -30,9 +35,12 @@ type RawOperation = Operation VariableDefinitions RawSelectionSet +getOperationName :: Maybe Key -> Key +getOperationName = fromMaybe "AnonymousOperation" + data Operation args sel = Operation - { operationName :: Key - , operationKind :: OperationKind + { operationName :: Maybe Key + , operationType :: OperationType , operationArgs :: args , operationSelection :: sel , operationPosition :: Position @@ -40,7 +48,7 @@ instance Lift (Operation VariableDefinitions RawSelectionSet) where lift (Operation name kind args sel pos) = - apply 'Operation [liftText name, lift kind, liftTextMap args, liftTextMap sel, lift pos] + apply 'Operation [liftMaybeText name, lift kind, liftTextMap args, liftTextMap sel, lift pos] data Variable a = Variable { variableType :: Key diff --git a/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs b/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs --- a/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs +++ b/src/Data/Morpheus/Types/Internal/AST/RawSelection.hs @@ -8,24 +8,18 @@ , RawArgument(..) , RawSelection(..) , Fragment(..) - , RawSelection'(..) , FragmentLib , RawArguments , RawSelectionSet + , Selection (..) ) where -import Data.Morpheus.Types.Internal.AST.Selection (Argument (..)) -import Data.Morpheus.Types.Internal.Base (Collection, Key, Position) -import Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap, liftTextTuple) import Language.Haskell.TH.Syntax (Lift (..)) -data Reference = Reference - { referenceName :: Key - , referencePosition :: Position - } deriving (Show) - -instance Lift Reference where - lift (Reference name pos) = apply 'Reference [liftText name, lift pos] +-- MORPHEUS +import Data.Morpheus.Types.Internal.AST.Selection (Argument (..), Selection (..)) +import Data.Morpheus.Types.Internal.Base (Collection, Key, Position, Reference (..)) +import Data.Morpheus.Types.Internal.TH (apply, liftMaybeText, liftText, liftTextMap) data Fragment = Fragment { fragmentType :: Key @@ -36,14 +30,10 @@ instance Lift Fragment where lift (Fragment t p sel) = apply 'Fragment [liftText t, lift p, liftTextMap sel] -data RawSelection' a = RawSelection' - { rawSelectionArguments :: RawArguments - , rawSelectionPosition :: Position - , rawSelectionRec :: a - } deriving (Show) +type RawSelection' a = Selection RawArguments a instance Lift a => Lift (RawSelection' a) where - lift (RawSelection' t p sel) = apply 'RawSelection' [liftTextMap t, lift p, lift sel] + lift (Selection t p alias sel) = apply 'Selection [liftTextMap t, lift p, liftMaybeText alias , lift sel] type FragmentLib = [(Key, Fragment)] @@ -57,18 +47,15 @@ type RawSelectionSet = Collection RawSelection instance Lift RawSelection where - lift (RawSelectionSet (RawSelection' t p sel)) = - apply 'RawSelectionSet [apply 'RawSelection' [liftTextMap t, lift p, liftTextMap sel]] + lift (RawSelectionSet (Selection t p alias sel)) = + apply 'RawSelectionSet [apply 'Selection [liftTextMap t, lift p, liftMaybeText alias,liftTextMap sel]] lift (RawSelectionField p) = apply 'RawSelectionField [lift p] lift (InlineFragment f) = apply 'InlineFragment [lift f] lift (Spread f) = apply 'Spread [lift f] - lift (RawAlias p s) = apply 'RawAlias [lift p, liftTextTuple s] data RawSelection = RawSelectionSet (RawSelection' RawSelectionSet) | RawSelectionField (RawSelection' ()) | InlineFragment Fragment | Spread Reference - | RawAlias { rawAliasPosition :: Position - , rawAliasSelection :: (Key, RawSelection) } deriving (Show) diff --git a/src/Data/Morpheus/Types/Internal/AST/Selection.hs b/src/Data/Morpheus/Types/Internal/AST/Selection.hs --- a/src/Data/Morpheus/Types/Internal/AST/Selection.hs +++ b/src/Data/Morpheus/Types/Internal/AST/Selection.hs @@ -4,9 +4,10 @@ ( Argument(..) , Arguments , SelectionSet - , Selection(..) , SelectionRec(..) , ArgumentOrigin(..) + , ValidSelection + , Selection(..) ) where import Data.Morpheus.Types.Internal.Base (Collection, Key, Position) @@ -26,20 +27,21 @@ type Arguments = Collection Argument -type SelectionSet = Collection Selection +type SelectionSet = Collection ValidSelection +type ValidSelection = Selection Arguments SelectionRec + type UnionSelection = Collection SelectionSet -data Selection = Selection - { selectionArguments :: Arguments +data Selection args rec = Selection + { selectionArguments :: args , selectionPosition :: Position - , selectionRec :: SelectionRec + , selectionAlias :: Maybe Key + , selectionRec :: rec } deriving (Show) data SelectionRec = SelectionSet SelectionSet | UnionSelection UnionSelection - | SelectionAlias { aliasFieldName :: Key - , aliasSelection :: SelectionRec } | SelectionField deriving (Show) diff --git a/src/Data/Morpheus/Types/Internal/Base.hs b/src/Data/Morpheus/Types/Internal/Base.hs --- a/src/Data/Morpheus/Types/Internal/Base.hs +++ b/src/Data/Morpheus/Types/Internal/Base.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Types.Internal.Base ( Key , Collection + , Reference (..) , Position , EnhancedKey(..) , Location(..) @@ -12,11 +14,14 @@ , enhanceKeyWithNull ) where -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) -import Language.Haskell.TH.Syntax (Lift) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift (..)) +-- MORPHEUS +import Data.Morpheus.Types.Internal.TH (apply, liftText) + type Position = Location data Location = Location @@ -28,6 +33,14 @@ type Message = Text type Collection a = [(Key, a)] + +data Reference = Reference + { referenceName :: Key + , referencePosition :: Position + } deriving (Show) + +instance Lift Reference where + lift (Reference name pos) = apply 'Reference [liftText name, lift pos] -- Text value that includes position for debugging, where EnhancedKey "a" 1 === EnhancedKey "a" 3 data EnhancedKey = EnhancedKey diff --git a/src/Data/Morpheus/Types/Internal/Data.hs b/src/Data/Morpheus/Types/Internal/Data.hs --- a/src/Data/Morpheus/Types/Internal/Data.hs +++ b/src/Data/Morpheus/Types/Internal/Data.hs @@ -55,7 +55,12 @@ , isDefaultTypeName , isSchemaTypeName , isPrimitiveTypeName - , OperationKind(..) + , OperationType(..) + , QUERY + , MUTATION + , SUBSCRIPTION + , Name + , Description ) where import Data.Semigroup ((<>)) @@ -68,6 +73,13 @@ import Data.Morpheus.Types.Internal.TH (apply, liftText, liftTextMap) import Data.Morpheus.Types.Internal.Value (Value (..)) +type Name = Key +type Description = Key + +type QUERY = 'Query +type MUTATION = 'Mutation +type SUBSCRIPTION = 'Subscription + isDefaultTypeName :: Key -> Bool isDefaultTypeName x = isSchemaTypeName x || isPrimitiveTypeName x @@ -81,7 +93,7 @@ sysTypes = ["__Schema", "__Type", "__Directive", "__TypeKind", "__Field", "__DirectiveLocation", "__InputValue", "__EnumValue"] -data OperationKind +data OperationType = Query | Subscription | Mutation @@ -106,7 +118,7 @@ data DataTypeKind = KindScalar - | KindObject (Maybe OperationKind) + | KindObject (Maybe OperationType) | KindUnion | KindEnum | KindInputObject diff --git a/src/Data/Morpheus/Types/Internal/Resolver.hs b/src/Data/Morpheus/Types/Internal/Resolver.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Types/Internal/Resolver.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Types.Internal.Resolver + ( ResolveT + , Event(..) + , GQLRootResolver(..) + , UnSubResolver + , GQLFail(..) + , ResponseT + , failResolveT + , Resolver(..) + , ResolvingStrategy(..) + , MapGraphQLT(..) + , PureOperation(..) + , resolveObject + , toResponseRes + , withObject + , Resolving(..) + ) where + +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, withExceptT) +import Data.Maybe (fromMaybe) +import Data.Semigroup ((<>)) +import Data.Text (pack, unpack) + +-- MORPHEUS +import Data.Morpheus.Error.Selection (resolverError, subfieldsNotSelected) +import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet, + ValidSelection) +import Data.Morpheus.Types.Internal.Base (Message) +import Data.Morpheus.Types.Internal.Data (Key, MUTATION, OperationType, QUERY, SUBSCRIPTION) +import Data.Morpheus.Types.Internal.Stream (Channel (..), Event (..), ResponseEvent (..), + ResponseStream, StreamChannel, StreamState (..), + StreamT (..), closeStream, injectEvents, mapS, pushEvents) +import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation) +import Data.Morpheus.Types.Internal.Value (GQLValue (..), Value) +import Data.Morpheus.Types.IO (renderResponse) + +withObject :: ( SelectionSet -> ResolvingStrategy o m e value) -> (Key,ValidSelection) -> ResolvingStrategy o m e value +withObject f (_, Selection {selectionRec = SelectionSet selection}) = f selection +withObject _ (key, Selection {selectionPosition}) = Fail $ subfieldsNotSelected key "" selectionPosition + +class Monad m => + GQLFail (t :: (* -> *) -> * -> *) m + where + gqlFail :: Monad m => Message -> t m a + toSuccess :: Monad m => (Message -> b) -> (a -> b) -> t m a -> t m b + +instance Monad m => GQLFail (ExceptT String) m where + gqlFail = ExceptT . pure . Left . unpack + toSuccess fFail fSuc (ExceptT value) = ExceptT $ pure . mapCases <$> value + where + mapCases (Right x) = fSuc x + mapCases (Left x) = fFail $ pack $ show x + +---------------------------------------------------------------------------------------- +type ResolveT = ExceptT GQLErrors +type ResponseT m e = ResolveT (ResponseStream m e) + +-- +-- Recursive Resolver + +newtype RecResolver m a b = RecResolver { + unRecResolver :: a -> ResolveT m b +} + +instance Functor m => Functor (RecResolver m a) where + fmap f (RecResolver x) = RecResolver eventFmap + where + eventFmap event = fmap f (x event) + +instance Monad m => Applicative (RecResolver m a) where + pure = RecResolver . const . pure + (RecResolver f) <*> (RecResolver res) = RecResolver recX + where + recX event = f event <*> res event + +instance Monad m => Monad (RecResolver m a) where + (RecResolver x) >>= next = RecResolver recX + where + recX event = x event >>= (\v-> v event) . unRecResolver . next +------------------------------------------------------------ +-- +--- GraphQLT + +data ResolvingStrategy (o::OperationType) (m:: * -> *) event value where + QueryResolving :: { unQueryT :: ResolveT m value } -> ResolvingStrategy QUERY m event value + MutationResolving :: { unMutationT :: ResolveT (StreamT m event) value } -> ResolvingStrategy MUTATION m event value + SubscriptionResolving :: { unSubscriptionT :: ResolveT (StreamT m (Channel event)) (RecResolver m event value) } -> ResolvingStrategy SUBSCRIPTION m event value + -- SubscriptionRecT :: RecResolver m event value -> GraphQLT SUBSCRIPTION m event value + Fail :: GQLErrors -> ResolvingStrategy o m event value + +-- GraphQLT Functor +instance Monad m => Functor (ResolvingStrategy o m e) where + fmap _ (Fail mErrors) = Fail mErrors + fmap f (QueryResolving mResolver) = QueryResolving $ f <$> mResolver + fmap f (MutationResolving mResolver) = MutationResolving $ f <$> mResolver + fmap f (SubscriptionResolving mResolver) = SubscriptionResolving $ fmap f <$> mResolver + +-- GraphQLT Applicative +instance (PureOperation o, Monad m) => Applicative (ResolvingStrategy o m e) where + pure = pureGraphQLT + ------------------------------------- + _ <*> (Fail mErrors) = Fail mErrors + (Fail mErrors) <*> _ = Fail mErrors + ------------------------------------- + (QueryResolving f) <*> (QueryResolving res) = QueryResolving (f <*> res) + ------------------------------------------------------------------------ + (MutationResolving f) <*> (MutationResolving res) = MutationResolving (f <*> res) + -------------------------------------------------------------- + (SubscriptionResolving f) <*> (SubscriptionResolving res) = SubscriptionResolving $ do + f1 <- f + res1 <- res + pure (f1 <*> res1) + +-- GADTResolver +data Resolver (o::OperationType) (m :: * -> * ) event value where + FailedResolver :: { unFailedResolver :: String } -> Resolver o m event value + QueryResolver:: { unQueryResolver :: ExceptT String m value } -> Resolver QUERY m event value + MutResolver :: { + mutEvents :: [event] , + mutResolver :: ExceptT String m value + } -> Resolver MUTATION m event value + SubResolver :: { + subChannels :: [StreamChannel event] , + subResolver :: event -> Resolver QUERY m event value + } -> Resolver SUBSCRIPTION m event value + +-- GADTResolver Functor +instance Functor m => Functor (Resolver o m e) where + fmap _ (FailedResolver mErrors) = FailedResolver mErrors + fmap f (QueryResolver mResolver) = QueryResolver $ fmap f mResolver + fmap f (MutResolver events mResolver) = MutResolver events $ fmap f mResolver + fmap f (SubResolver events mResolver) = SubResolver events (eventFmap mResolver) + where + eventFmap res event = fmap f (res event) + +-- GADTResolver Applicative +instance (PureOperation o ,Monad m) => Applicative (Resolver o m e) where + pure = pureRes + ------------------------------------- + _ <*> (FailedResolver mErrors) = FailedResolver mErrors + (FailedResolver mErrors) <*> _ = FailedResolver mErrors + ------------------------------------- + (QueryResolver f) <*> (QueryResolver res) = QueryResolver (f <*> res) + --------------------------------------------------------------------- + (MutResolver events1 f) <*> (MutResolver events2 res) = MutResolver (events1 <> events2) (f <*> res) + -------------------------------------------------------------- + (SubResolver e1 f) <*> (SubResolver e2 res) = SubResolver (e1<>e2) $ + \event -> f event <*> res event + +instance (Monad m) => Monad (Resolver QUERY m e) where + return = pure + ------------------------------------- + (FailedResolver mErrors) >>= _ = FailedResolver mErrors + ------------------------------------- + (QueryResolver f) >>= nextM = QueryResolver (f >>= unQueryResolver. nextM) + +-- Pure Operation +class PureOperation (o::OperationType) where + pureRes :: Monad m => a -> Resolver o m event a + pureGraphQLT :: Monad m => a -> ResolvingStrategy o m event a + eitherGraphQLT :: Monad m => Validation a -> ResolvingStrategy o m event a + +instance PureOperation QUERY where + pureRes = QueryResolver . pure + pureGraphQLT = QueryResolving . pure + eitherGraphQLT = QueryResolving . ExceptT . pure + +instance PureOperation MUTATION where + pureRes = MutResolver [] . pure + pureGraphQLT = MutationResolving . pure + eitherGraphQLT = MutationResolving . ExceptT . pure + +instance PureOperation SUBSCRIPTION where + pureRes = SubResolver [] . const . pure + pureGraphQLT = SubscriptionResolving . pure . pure + eitherGraphQLT = SubscriptionResolving . fmap pure . ExceptT . pure + + +resolveObject :: (Monad m , PureOperation o ) => SelectionSet -> [FieldRes o m e] -> ResolvingStrategy o m e Value +resolveObject selectionSet fieldResolvers = gqlObject <$> traverse selectResolver selectionSet + where + selectResolver (key, selection@Selection { selectionAlias }) = (fromMaybe key selectionAlias,) <$> lookupRes selection + where + lookupRes sel = (fromMaybe (const $ pure gqlNull) $ lookup key fieldResolvers) (key, sel) + +class Resolving o m e where + getArgs :: Validation args -> (args -> Resolver o m e value) -> Resolver o m e value + resolving :: Monad m => (value -> (Key,ValidSelection) -> ResolvingStrategy o m e Value) -> Resolver o m e value -> (Key, ValidSelection) -> ResolvingStrategy o m e Value + +type FieldRes o m e = (Key, (Key, ValidSelection) -> ResolvingStrategy o m e Value) + +instance Resolving o m e where + getArgs (Right x) f = f x + getArgs (Left _) _ = FailedResolver "" + --------------------------------------------------------------------------------------------------------------------------------------- + resolving encode gResolver selection@(fieldName,Selection { selectionPosition }) = __resolving gResolver + where + __resolving (FailedResolver message) = Fail $ resolverError selectionPosition fieldName message + __resolving (QueryResolver res) = + QueryResolving $ withExceptT (resolverError selectionPosition fieldName) res >>= unQueryT . (`encode` selection) + --------------------------------------------------------------------------------------------------------------------------------------- + __resolving (MutResolver events res) = + MutationResolving $ pushEvents events $ withExceptT (resolverError selectionPosition fieldName) (injectEvents [] res) >>= unMutationT . (`encode` selection) + -------------------------------------------------------------------------------------------------------------------------------- + __resolving (SubResolver subChannels res) = + SubscriptionResolving $ ExceptT $ StreamT $ pure $ StreamState { streamEvents , streamValue } + where + streamValue = pure $ RecResolver $ \event -> withExceptT (resolverError selectionPosition fieldName) ( unQueryResolver $ res event) >>= unPub event . (`encode` selection) + streamEvents :: [Channel e] + streamEvents = map Channel subChannels + +unPub :: Monad m => event -> ResolvingStrategy SUBSCRIPTION m event a -> ResolveT m a +unPub event x = do + func <- unPureSub x + func event + +unPureSub :: Monad m => ResolvingStrategy SUBSCRIPTION m event a -> ResolveT m (event -> ResolveT m a) +unPureSub = ExceptT . fmap (fmap unRecResolver . streamValue) . runStreamT . runExceptT . unSubscriptionT + +class MapGraphQLT (fromO :: OperationType) (toO :: OperationType) where + mapGraphQLT :: Monad m => ResolvingStrategy fromO m e a -> ResolvingStrategy toO m e a + +instance MapGraphQLT fromO fromO where + mapGraphQLT = id + +instance MapGraphQLT QUERY SUBSCRIPTION where + mapGraphQLT (QueryResolving x) = SubscriptionResolving $ injectEvents [] (fmap pure x) + mapGraphQLT (Fail x) = Fail x + +toResponseRes :: Monad m => ResolvingStrategy o m event Value -> ResponseT m event Value +toResponseRes (Fail errors) = ExceptT $ StreamT $ pure $ StreamState [] $ Left errors +toResponseRes (QueryResolving resT) = ExceptT $ StreamT $ StreamState [] <$> runExceptT resT +toResponseRes (MutationResolving resT) = ExceptT $ mapS Publish (runExceptT resT) +toResponseRes (SubscriptionResolving resT) = + ExceptT $ StreamT $ handleActions <$> closeStream (runExceptT resT) + where + handleActions (_, Left gqlError) = StreamState [] (Left gqlError) + handleActions (channels, Right subResolver) = + StreamState [Subscribe $ Event channels handleRes] (Right gqlNull) + where + handleRes event = renderResponse <$> runExceptT (unRecResolver subResolver event) + +type family UnSubResolver (a :: * -> *) :: (* -> *) + +type instance UnSubResolver (Resolver SUBSCRIPTION m e) = Resolver QUERY m e + +------------------------------------------------------------------- +failResolveT :: Monad m => GQLErrors -> ResolveT m a +failResolveT = ExceptT . pure . Left + +------------------------------------------------------------------- +-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. +-- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional, +-- if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it. +data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver + { queryResolver :: query (Resolver QUERY m event) + , mutationResolver :: mut (Resolver MUTATION m event) + , subscriptionResolver :: sub (Resolver SUBSCRIPTION m event) + } diff --git a/src/Data/Morpheus/Types/Internal/Stream.hs b/src/Data/Morpheus/Types/Internal/Stream.hs --- a/src/Data/Morpheus/Types/Internal/Stream.hs +++ b/src/Data/Morpheus/Types/Internal/Stream.hs @@ -1,57 +1,66 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Stream ( StreamState(..) , ResponseEvent(..) , SubEvent - , PubEvent , Event(..) -- STREAMS , StreamT(..) - , SubscribeStream - , PublishStream , ResponseStream , closeStream , mapS , injectEvents , initExceptStream - , GQLStream(..) + , pushEvents + -- , GQLMonad(..) + , GQLChannel(..) + , Channel(..) ) where -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Morpheus.Types.Internal.Data (OperationKind (..)) -import Data.Morpheus.Types.IO (GQLResponse) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Data.Semigroup ((<>)) -newtype GQLStream (o :: OperationKind) (m :: * -> *) event a = GQLStream - { unGQLStream :: StreamT m (CHANNEL o m event a) (RESOLVER o m event a) - } +-- MORPHEUS +import Data.Morpheus.Types.IO (GQLResponse) -instance Functor m => Functor (GQLStream 'Query m event) where - fmap f (GQLStream x) = GQLStream (f <$> x) +-- EVENTS +data ResponseEvent m event + = Publish event + | Subscribe (SubEvent m event) -instance Functor m => Functor (GQLStream 'Mutation m event) where - fmap f (GQLStream x) = GQLStream (f <$> x) +-- STREAMS +type ResponseStream m event = StreamT m (ResponseEvent m event) -class STREAM (o :: OperationKind) where - type RESOLVER o (m :: * -> *) event a :: * - type CHANNEL o (m :: * -> *) event a :: * +type SubEvent m event = Event (Channel event) (event-> m GQLResponse) -instance STREAM 'Query where - type CHANNEL 'Query m event a = () - type RESOLVER 'Query m event a = a +newtype Channel event = Channel { + unChannel :: StreamChannel event +} -instance STREAM 'Mutation where - type CHANNEL 'Mutation m event a = event - type RESOLVER 'Mutation m event a = a +instance (Eq (StreamChannel event)) => Eq (Channel event) where + Channel x == Channel y = x == y -instance STREAM 'Subscription where - type CHANNEL 'Subscription m (Event channel content) a = channel - type RESOLVER 'Subscription m event a = event -> m a +class GQLChannel a where + type StreamChannel a :: * + streamChannels :: a -> [Channel a] + +instance GQLChannel () where + type StreamChannel () = () + streamChannels _ = [] + +instance GQLChannel (Event channel content) where + type StreamChannel (Event channel content) = channel + streamChannels Event { channels } = map Channel channels + data Event e c = Event { channels :: [e] , content :: c @@ -83,22 +92,6 @@ (StreamState e2 v2) <- runStreamT $ mFunc v1 return $ StreamState (e1 ++ e2) v2 -type SubEvent m e c = Event e (Event e c -> m GQLResponse) - -type PubEvent e c = Event e c - --- EVENTS -data ResponseEvent m e c - = Publish (PubEvent e c) - | Subscribe (SubEvent m e c) - --- STREAMS -type SubscribeStream m e = StreamT m [e] - -type PublishStream m e c = StreamT m (PubEvent e c) - -type ResponseStream m event con = StreamT m (ResponseEvent m event con) - -- Helper Functions toTuple :: StreamState s a -> ([s], a) toTuple StreamState {streamEvents, streamValue} = (streamEvents, streamValue) @@ -111,6 +104,11 @@ StreamT $ do state <- ma return $ state {streamEvents = map func (streamEvents state)} + +pushEvents :: Functor m => [event] -> ExceptT e (StreamT m event) a -> ExceptT e (StreamT m event) a +pushEvents events = ExceptT . StreamT . fmap updateState . runStreamT . runExceptT + where + updateState x = x { streamEvents = events <> streamEvents x } injectEvents :: Functor m => [event] -> ExceptT e m a -> ExceptT e (StreamT m event) a injectEvents states = ExceptT . StreamT . fmap (StreamState states) . runExceptT diff --git a/src/Data/Morpheus/Types/Internal/TH.hs b/src/Data/Morpheus/Types/Internal/TH.hs --- a/src/Data/Morpheus/Types/Internal/TH.hs +++ b/src/Data/Morpheus/Types/Internal/TH.hs @@ -6,6 +6,10 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax +liftMaybeText :: Maybe Text -> ExpQ +liftMaybeText (Just x) = appE (conE 'Just) (liftText x) +liftMaybeText Nothing = conE 'Nothing + liftText :: Text -> ExpQ liftText x = appE (varE 'pack) (lift (unpack x)) diff --git a/src/Data/Morpheus/Types/Internal/Validation.hs b/src/Data/Morpheus/Types/Internal/Validation.hs --- a/src/Data/Morpheus/Types/Internal/Validation.hs +++ b/src/Data/Morpheus/Types/Internal/Validation.hs @@ -7,8 +7,6 @@ , GQLErrors , JSONError(..) , Validation - , ResolveT - , failResolveT , ResolveValue ) where @@ -33,9 +31,4 @@ type Validation = Either GQLErrors -type ResolveT = ExceptT GQLErrors - type ResolveValue m = ExceptT GQLErrors m Value - -failResolveT :: Monad m => GQLErrors -> ResolveT m a -failResolveT = ExceptT . pure . Left diff --git a/src/Data/Morpheus/Types/Internal/WebSocket.hs b/src/Data/Morpheus/Types/Internal/WebSocket.hs --- a/src/Data/Morpheus/Types/Internal/WebSocket.hs +++ b/src/Data/Morpheus/Types/Internal/WebSocket.hs @@ -16,24 +16,24 @@ type ClientID = UUID -data ClientSession m e c = +data ClientSession m e = ClientSession { sessionId :: Text - , sessionSubscription :: SubEvent m e c + , sessionSubscription :: SubEvent m e } -instance (Show e, Show c) => Show (ClientSession m e c) where +instance (Show e) => Show (ClientSession m e ) where show ClientSession {sessionId} = "GQLSession { id: " <> show sessionId <> ", sessions: " <> "" <> " }" -data GQLClient m e c = +data GQLClient m e = GQLClient { clientID :: ClientID , clientConnection :: Connection - , clientSessions :: [ClientSession m e c] + , clientSessions :: [ClientSession m e ] } -instance (Show e, Show c) => Show (GQLClient m e c) where +instance (Show e) => Show (GQLClient m e) where show GQLClient {clientID, clientSessions} = "GQLClient {id:" <> show clientID <> ", sessions:" <> show clientSessions <> "}" diff --git a/src/Data/Morpheus/Types/Resolver.hs b/src/Data/Morpheus/Types/Resolver.hs deleted file mode 100644 --- a/src/Data/Morpheus/Types/Resolver.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Data.Morpheus.Types.Resolver - ( Pure - , Resolver - , MutResolver - , SubResolver(..) - , ResolveT - , SubResolveT - , MutResolveT - , SubRootRes - , Event(..) - , GQLRootResolver(..) - , UnSubResolver - , resolver - , mutResolver - , toMutResolver - , GQLFail(..) - , ResponseT - ) where - -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Text (pack, unpack) - --- MORPHEUS --- -import Data.Morpheus.Types.Internal.Base (Message) -import Data.Morpheus.Types.Internal.Stream (Event (..), PublishStream, ResponseStream, StreamState (..), - StreamT (..), SubscribeStream) -import Data.Morpheus.Types.Internal.Validation (ResolveT) - -class Monad m => - GQLFail (t :: (* -> *) -> * -> *) m - where - gqlFail :: Monad m => Message -> t m a - toSuccess :: Monad m => (Message -> b) -> (a -> b) -> t m a -> t m b - -instance Monad m => GQLFail Resolver m where - gqlFail = ExceptT . pure . Left . unpack - toSuccess fFail fSuc (ExceptT value) = ExceptT $ pure . mapCases <$> value - where - mapCases (Right x) = fSuc x - mapCases (Left x) = fFail $ pack $ show x - ----------------------------------------------------------------------------------------- -{-- -newtype SubResolveT m e c a = SubResolveT - { unSubResolveT :: ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a) - } - -newtype MutResolveT m e c a = MutResolveT - { unMutResolveT :: ResolveT (PublishStream m e c) a - } --} -data SubResolver m e c a = SubResolver - { subChannels :: [e] - , subResolver :: Event e c -> Resolver m a - } - -type family UnSubResolver (a :: * -> *) :: (* -> *) - -type instance UnSubResolver (SubResolver m e c) = Resolver m - -------------------------------------------------------------------- -type Resolver = ExceptT String - -type ResponseT m e c = ResolveT (ResponseStream m e c) - -type MutResolveT m e c = ResolveT (PublishStream m e c) - -type SubResolveT m e c a = ResolveT (SubscribeStream m e) (Event e c -> ResolveT m a) - -type MutResolver m e c = Resolver (PublishStream m e c) - -type SubRootRes m e sub = Resolver (SubscribeStream m e) sub - -------------------------------------------------------------------- --- | Pure Resolver without effect -type Pure = Either String - --- | GraphQL Resolver -resolver :: m (Either String a) -> Resolver m a -resolver = ExceptT - -toMutResolver :: Monad m => [Event e c] -> Resolver m a -> MutResolver m e c a -toMutResolver channels = ExceptT . StreamT . fmap (StreamState channels) . runExceptT - --- | GraphQL Resolver for mutation or subscription resolver , adds effect to normal resolver -mutResolver :: Monad m => [Event e c] -> (StreamT m (Event e c)) (Either String a) -> MutResolver m e c a -mutResolver channels = ExceptT . StreamT . fmap effectPlus . runStreamT - where - effectPlus state = state {streamEvents = channels ++ streamEvents state} - --- | GraphQL Root resolver, also the interpreter generates a GQL schema from it. --- --- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional, --- if your schema does not supports __mutation__ or __subscription__ , you acn use __()__ for it. -data GQLRootResolver m e c query mut sub = GQLRootResolver - { queryResolver :: Resolver m query - , mutationResolver :: Resolver (PublishStream m e c) mut - , subscriptionResolver :: SubRootRes m e sub - } diff --git a/src/Data/Morpheus/Types/Types.hs b/src/Data/Morpheus/Types/Types.hs --- a/src/Data/Morpheus/Types/Types.hs +++ b/src/Data/Morpheus/Types/Types.hs @@ -1,17 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} module Data.Morpheus.Types.Types ( GQLQueryRoot(..) , Variables + , Undefined(..) ) where import Data.Map (Map) +import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift (..)) + +-- Morpheus import Data.Morpheus.Types.Internal.AST.Operation (RawOperation) import Data.Morpheus.Types.Internal.AST.RawSelection (FragmentLib) import Data.Morpheus.Types.Internal.Base (Key) import Data.Morpheus.Types.Internal.TH (apply, liftTextMap) import Data.Morpheus.Types.Internal.Value (Value) -import Language.Haskell.TH.Syntax (Lift (..)) + +data Undefined (m :: * -> *) = Undefined deriving (Show, Generic) type Variables = Map Key Value diff --git a/src/Data/Morpheus/Validation/Query/Fragment.hs b/src/Data/Morpheus/Validation/Query/Fragment.hs --- a/src/Data/Morpheus/Validation/Query/Fragment.hs +++ b/src/Data/Morpheus/Validation/Query/Fragment.hs @@ -16,12 +16,13 @@ import Data.Morpheus.Error.Fragment (cannotBeSpreadOnType, cannotSpreadWithinItself, fragmentNameCollision, unknownFragment, unusedFragment) import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..), - RawSelection' (..), Reference (..)) + Reference (..), Selection (..)) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position) import Data.Morpheus.Types.Internal.Data (DataTypeLib) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Validation.Internal.Utils (checkNameCollision, existsObjectType) + validateFragments :: DataTypeLib -> FragmentLib -> [(Text, RawSelection)] -> Validation () validateFragments lib fragments operatorSel = validateNameCollision >> checkLoop >> checkUnusedFragments where @@ -61,8 +62,7 @@ usedFragments fragments = concatMap findAllUses where findAllUses :: (Text, RawSelection) -> [Node] - findAllUses (_, RawSelectionSet RawSelection' {rawSelectionRec}) = concatMap findAllUses rawSelectionRec - findAllUses (_, RawAlias {rawAliasSelection}) = concatMap findAllUses [rawAliasSelection] + findAllUses (_, RawSelectionSet Selection {selectionRec}) = concatMap findAllUses selectionRec findAllUses (_, InlineFragment Fragment {fragmentSelection}) = concatMap findAllUses fragmentSelection findAllUses (_, RawSelectionField {}) = [] findAllUses (_, Spread Reference {referenceName, referencePosition}) = @@ -71,8 +71,7 @@ searchInFragment = maybe [] (concatMap findAllUses . fragmentSelection) (lookup referenceName fragments) scanForSpread :: (Text, RawSelection) -> [Node] -scanForSpread (_, RawSelectionSet RawSelection' {rawSelectionRec = selection'}) = concatMap scanForSpread selection' -scanForSpread (_, RawAlias {rawAliasSelection = selection'}) = concatMap scanForSpread [selection'] +scanForSpread (_, RawSelectionSet Selection {selectionRec }) = concatMap scanForSpread selectionRec scanForSpread (_, InlineFragment Fragment {fragmentSelection = selection'}) = concatMap scanForSpread selection' scanForSpread (_, RawSelectionField {}) = [] scanForSpread (_, Spread Reference {referenceName = name', referencePosition = position'}) = diff --git a/src/Data/Morpheus/Validation/Query/Selection.hs b/src/Data/Morpheus/Validation/Query/Selection.hs --- a/src/Data/Morpheus/Validation/Query/Selection.hs +++ b/src/Data/Morpheus/Validation/Query/Selection.hs @@ -8,12 +8,17 @@ ( validateSelectionSet ) where + +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +-- MORPHEUS import Data.Morpheus.Error.Selection (cannotQueryField, duplicateQuerySelections, hasNoSubfields, subfieldsNotSelected) import Data.Morpheus.Error.Variable (unknownType) import Data.Morpheus.Types.Internal.AST.Operation (ValidVariables) import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawSelection (..), - RawSelection' (..), RawSelectionSet) + RawSelectionSet) import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..)) import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataObject, @@ -25,14 +30,13 @@ import Data.Morpheus.Validation.Query.Fragment (castFragmentType, resolveSpread) import Data.Morpheus.Validation.Query.Utils.Selection (lookupFieldAsSelectionSet, lookupSelectionField, lookupUnionTypes) -import Data.Text (Text) checkDuplicatesOn :: DataObject -> SelectionSet -> Validation SelectionSet checkDuplicatesOn DataTyCon {typeName = name'} keys = checkNameCollision enhancedKeys selError >> pure keys where selError = duplicateQuerySelections name' enhancedKeys = map selToKey keys - selToKey (key', Selection {selectionPosition = position'}) = EnhancedKey key' position' + selToKey (key, Selection {selectionPosition = position' , selectionAlias }) = EnhancedKey (fromMaybe key selectionAlias) position' clusterUnionSelection :: FragmentLib -> Text -> [DataObject] -> (Text, RawSelection) -> Validation ([Fragment], SelectionSet) @@ -42,17 +46,18 @@ typeNames = map typeName possibleTypes' splitFrag :: (Text, RawSelection) -> Validation ([Fragment], SelectionSet) splitFrag (_, Spread ref) = resolveSpread fragments typeNames ref >>= packFragment - splitFrag ("__typename", RawSelectionField RawSelection' {rawSelectionPosition = position'}) = - return - ( [] - , [ ( "__typename" - , Selection {selectionRec = SelectionField, selectionArguments = [], selectionPosition = position'}) - ]) - splitFrag (key, RawSelectionSet RawSelection' {rawSelectionPosition}) = - Left $ cannotQueryField key type' rawSelectionPosition - splitFrag (key, RawSelectionField RawSelection' {rawSelectionPosition}) = - Left $ cannotQueryField key type' rawSelectionPosition - splitFrag (key', RawAlias {rawAliasPosition = position'}) = Left $ cannotQueryField key' type' position' + splitFrag ("__typename", RawSelectionField selection ) = pure ([] ,[ + ( "__typename", + selection { + selectionArguments = [] , + selectionRec = SelectionField} + ) + ]) + splitFrag (key, RawSelectionSet Selection {selectionPosition}) = + Left $ cannotQueryField key type' selectionPosition + splitFrag (key, RawSelectionField Selection {selectionPosition}) = + Left $ cannotQueryField key type' selectionPosition + -- splitFrag (key', RawAlias {rawAliasPosition = position'}) = Left $ cannotQueryField key' type' position' splitFrag (_, InlineFragment fragment') = castFragmentType Nothing (fragmentPosition fragment') typeNames fragment' >>= packFragment @@ -90,8 +95,8 @@ {- get dataField and validated arguments for RawSelection -} - getValidationData key RawSelection' {rawSelectionArguments, rawSelectionPosition} = do - selectionField <- lookupSelectionField rawSelectionPosition key dataType' + getValidationData key Selection {selectionArguments, selectionPosition} = do + selectionField <- lookupSelectionField selectionPosition key dataType' -- validate field Argument ----- arguments <- validateArguments @@ -99,39 +104,28 @@ operatorName variables (key, selectionField) - rawSelectionPosition - rawSelectionArguments + selectionPosition + selectionArguments -- check field Type existence ----- fieldDataType <- lookupType - (unknownType (aliasTyCon $fieldType selectionField) rawSelectionPosition) + (unknownType (aliasTyCon $fieldType selectionField) selectionPosition) (allDataTypes lib) (aliasTyCon $ fieldType selectionField) return (selectionField, fieldDataType, arguments) -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet -- validateSelection :: (Text, RawSelection) -> Validation SelectionSet - validateSelection (key', RawAlias {rawAliasSelection = rawSelection', rawAliasPosition = position'}) = - fmap processSingleSelection <$> validateSelection rawSelection' - where - processSingleSelection (selKey', selection') = - ( key' - , selection' - { selectionRec = SelectionAlias {aliasFieldName = selKey', aliasSelection = selectionRec selection'} - , selectionPosition = position' - }) - validateSelection (key', RawSelectionSet fullRawSelection'@RawSelection' { rawSelectionRec = rawSelectors - , rawSelectionPosition = position' - }) = do - (dataField, dataType, arguments) <- getValidationData key' fullRawSelection' + validateSelection (key', RawSelectionSet fullRawSelection@Selection { selectionRec = rawSelection, selectionPosition }) = do + (dataField, dataType, arguments) <- getValidationData key' fullRawSelection case dataType of Union _ -> do (categories, __typename) <- clusterTypes mapM (validateCluster __typename) categories >>= returnSelection arguments . UnionSelection where clusterTypes = do - unionTypes <- lookupUnionTypes position' key' lib dataField + unionTypes <- lookupUnionTypes selectionPosition key' lib dataField (spreads, __typename) <- - flatTuple <$> mapM (clusterUnionSelection fragments' typeName' unionTypes) rawSelectors + flatTuple <$> mapM (clusterUnionSelection fragments' typeName' unionTypes) rawSelection return (categorizeTypes unionTypes spreads, __typename) -- -- second arguments will be added to every selection cluster @@ -140,35 +134,27 @@ selection' <- __validate type' (concatMap fragmentSelection frags') return (typeName type', sysSelection' ++ selection') OutputObject _ -> do - fieldType' <- lookupFieldAsSelectionSet position' key' lib dataField - __validate fieldType' rawSelectors >>= returnSelection arguments . SelectionSet - -- DataFullType - -- = Leaf DataLeaf - -- | InputObject DataInputObject - -- | InputUnion DataUnion - _ -> Left $ hasNoSubfields key' (aliasTyCon $fieldType dataField) position' + fieldType' <- lookupFieldAsSelectionSet selectionPosition key' lib dataField + __validate fieldType' rawSelection >>= returnSelection arguments . SelectionSet + _ -> Left $ hasNoSubfields key' (aliasTyCon $fieldType dataField) selectionPosition where - returnSelection arguments' selection' = + returnSelection selectionArguments selectionRec = pure [ ( key' - , Selection - {selectionArguments = arguments', selectionRec = selection', selectionPosition = position'}) + , fullRawSelection + { selectionArguments, + selectionRec + } + ) ] - validateSelection (key, RawSelectionField fullRawSelection'@RawSelection' {rawSelectionPosition}) = do - (dataField, datatype, arguments) <- getValidationData key fullRawSelection' + validateSelection (key, RawSelectionField rawSelection@Selection{selectionPosition}) = do + (dataField, datatype, selectionArguments) <- getValidationData key rawSelection isLeaf datatype dataField - pure - [ ( key - , Selection - { selectionArguments = arguments - , selectionRec = SelectionField - , selectionPosition = rawSelectionPosition - }) - ] + pure [( key , rawSelection { selectionArguments , selectionRec = SelectionField })] where isLeaf (Leaf _) _ = Right () isLeaf _ DataField {fieldType = TypeAlias {aliasTyCon}} = - Left $ subfieldsNotSelected key aliasTyCon rawSelectionPosition + Left $ subfieldsNotSelected key aliasTyCon selectionPosition validateSelection (_, Spread reference') = resolveSpread fragments' [typeName'] reference' >>= validateFragment validateSelection (_, InlineFragment fragment') = castFragmentType Nothing (fragmentPosition fragment') [typeName'] fragment' >>= validateFragment diff --git a/src/Data/Morpheus/Validation/Query/Validation.hs b/src/Data/Morpheus/Validation/Query/Validation.hs --- a/src/Data/Morpheus/Validation/Query/Validation.hs +++ b/src/Data/Morpheus/Validation/Query/Validation.hs @@ -10,8 +10,9 @@ import Data.Map (fromList) import Data.Morpheus.Error.Mutation (mutationIsNotDefined) import Data.Morpheus.Error.Subscription (subscriptionIsNotDefined) -import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, ValidOperation) -import Data.Morpheus.Types.Internal.Data (DataObject, DataTypeLib (..), OperationKind (..)) +import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), RawOperation, ValidOperation, + getOperationName) +import Data.Morpheus.Types.Internal.Data (DataObject, DataTypeLib (..), OperationType (..)) import Data.Morpheus.Types.Internal.Validation (Validation) import Data.Morpheus.Types.Types (GQLQueryRoot (..)) import Data.Morpheus.Validation.Internal.Utils (VALIDATION_MODE) @@ -20,12 +21,12 @@ import Data.Morpheus.Validation.Query.Variable (resolveOperationVariables) getOperationDataType :: RawOperation -> DataTypeLib -> Validation DataObject -getOperationDataType Operation {operationKind = Query} lib = pure $ snd $ query lib -getOperationDataType Operation {operationKind = Mutation, operationPosition} lib = +getOperationDataType Operation {operationType = Query} lib = pure $ snd $ query lib +getOperationDataType Operation {operationType = Mutation, operationPosition} lib = case mutation lib of Just (_, mutation') -> pure mutation' Nothing -> Left $ mutationIsNotDefined operationPosition -getOperationDataType Operation {operationKind = Subscription, operationPosition} lib = +getOperationDataType Operation {operationType = Subscription, operationPosition} lib = case subscription lib of Just (_, subscription') -> pure subscription' Nothing -> Left $ subscriptionIsNotDefined operationPosition @@ -34,7 +35,7 @@ validateRequest lib validationMode GQLQueryRoot { fragments , inputVariables , operation = rawOperation@Operation { operationName - , operationKind + , operationType , operationSelection , operationPosition } @@ -42,5 +43,6 @@ operationDataType <- getOperationDataType rawOperation lib variables <- resolveOperationVariables lib fragments (fromList inputVariables) validationMode rawOperation validateFragments lib fragments operationSelection - selection <- validateSelectionSet lib fragments operationName variables operationDataType operationSelection - pure $ Operation {operationName, operationKind, operationArgs = [], operationSelection = selection, operationPosition} + selection <- + validateSelectionSet lib fragments (getOperationName operationName) variables operationDataType operationSelection + pure $ Operation {operationName, operationType, operationArgs = [], operationSelection = selection, operationPosition} diff --git a/src/Data/Morpheus/Validation/Query/Variable.hs b/src/Data/Morpheus/Validation/Query/Variable.hs --- a/src/Data/Morpheus/Validation/Query/Variable.hs +++ b/src/Data/Morpheus/Validation/Query/Variable.hs @@ -7,14 +7,18 @@ import Data.List ((\\)) import qualified Data.Map as M (lookup) import Data.Maybe (maybe) +import Data.Semigroup ((<>)) +import Data.Text (Text) + +--- MORPHEUS import Data.Morpheus.Error.Input (inputErrorMessage) import Data.Morpheus.Error.Variable (uninitializedVariable, unknownType, unusedVariables, variableGotInvalidValue) import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), RawOperation, - ValidVariables, Variable (..)) + ValidVariables, Variable (..), getOperationName) import Data.Morpheus.Types.Internal.AST.RawSelection (Fragment (..), FragmentLib, RawArgument (..), - RawSelection (..), RawSelection' (..), RawSelectionSet, - Reference (..)) + RawSelection (..), RawSelectionSet, Reference (..), + Selection (..)) import Data.Morpheus.Types.Internal.Base (EnhancedKey (..), Position) import Data.Morpheus.Types.Internal.Data (DataKind, DataTypeLib) import Data.Morpheus.Types.Internal.Validation (Validation) @@ -23,8 +27,6 @@ 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.Semigroup ((<>)) -import Data.Text (Text) getVariableType :: Text -> Position -> DataTypeLib -> Validation DataKind getVariableType type' position' lib' = getInputType type' lib' error' @@ -43,15 +45,14 @@ [EnhancedKey referenceName referencePosition] -- | search used variables in every arguments searchReferences :: (Text, RawSelection) -> Validation [EnhancedKey] - searchReferences (_, RawSelectionSet RawSelection' {rawSelectionArguments, rawSelectionRec}) = - getArgs <$> concatMapM searchReferences rawSelectionRec + searchReferences (_, RawSelectionSet Selection {selectionArguments, selectionRec}) = + getArgs <$> concatMapM searchReferences selectionRec where getArgs :: [EnhancedKey] -> [EnhancedKey] - getArgs x = concatMap referencesFromArgument rawSelectionArguments <> x + getArgs x = concatMap referencesFromArgument selectionArguments <> x searchReferences (_, InlineFragment Fragment {fragmentSelection}) = concatMapM searchReferences fragmentSelection - searchReferences (_, RawAlias {rawAliasSelection}) = searchReferences rawAliasSelection - searchReferences (_, RawSelectionField RawSelection' {rawSelectionArguments}) = - return $ concatMap referencesFromArgument rawSelectionArguments + searchReferences (_, RawSelectionField Selection {selectionArguments}) = + return $ concatMap referencesFromArgument selectionArguments searchReferences (_, Spread reference) = getFragment reference fragmentLib >>= concatMapM searchReferences . fragmentSelection @@ -68,7 +69,7 @@ checkUnusedVariables refs = case map varToKey operationArgs \\ refs of [] -> pure () - unused' -> Left $ unusedVariables operationName unused' + unused' -> Left $ unusedVariables (getOperationName operationName) unused' lookupAndValidateValueOnBody :: DataTypeLib -> Variables -> VALIDATION_MODE -> (Text, Variable DefaultValue) -> Validation (Text, Variable Value) diff --git a/test/Feature/Holistic/API.gql b/test/Feature/Holistic/API.gql --- a/test/Feature/Holistic/API.gql +++ b/test/Feature/Holistic/API.gql @@ -43,7 +43,7 @@ } type Mutation { - createUser(userID: String!, userName: String!): User! + createUser(userID: String!, userName: String): User! } type Subscription { diff --git a/test/Feature/Holistic/API.hs b/test/Feature/Holistic/API.hs --- a/test/Feature/Holistic/API.hs +++ b/test/Feature/Holistic/API.hs @@ -17,8 +17,8 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocument) import Data.Morpheus.Kind (SCALAR) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLScalar (..), GQLType (..), - ID (..), IOMutRes, IORes, IOSubRes, ScalarValue (..), SubResolver (..)) +import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLScalar (..), + GQLType (..), ID (..), ScalarValue (..), Resolver (..), constRes ) import Data.Text (Text) import GHC.Generics (Generic) @@ -34,37 +34,35 @@ parseValue _ = pure (TestScalar 1 0) serialize (TestScalar x y) = Int (x * 100 + y) -data EVENT = - EVENT +data Channel = + Channel deriving (Show, Eq) -importGQLDocument "test/Feature/Holistic/API.gql" +type EVENT = Event Channel () -resolveValue :: Monad m => b -> a -> m b -resolveValue = const . return +importGQLDocument "test/Feature/Holistic/API.gql" rootResolver :: - GQLRootResolver IO EVENT () (Query IORes) (Mutation (IOMutRes EVENT ())) (Subscription (IOSubRes EVENT ())) + GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = return Query {user, testUnion = const $ return Nothing} - , mutationResolver = return Mutation {createUser = user} - , subscriptionResolver = - return Subscription {newUser = const SubResolver {subChannels = [EVENT], subResolver = user}} + { queryResolver = Query {user, testUnion = constRes Nothing} + , mutationResolver = Mutation {createUser = user} + , subscriptionResolver = Subscription {newUser = const SubResolver {subChannels = [Channel], subResolver = user}} } where user _ = - return $ + pure User - { name = resolveValue "testName" - , email = resolveValue "" + { name = constRes "testName" + , email = constRes "" , address = resolveAddress , office = resolveAddress - , friend = resolveValue Nothing + , friend = constRes Nothing } where resolveAddress _ = - return Address {city = resolveValue "", houseNumber = resolveValue 0, street = resolveValue Nothing} + pure Address {city = constRes "", houseNumber = constRes 0, street = constRes Nothing} api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver diff --git a/test/Feature/Holistic/cases.json b/test/Feature/Holistic/cases.json --- a/test/Feature/Holistic/cases.json +++ b/test/Feature/Holistic/cases.json @@ -172,7 +172,31 @@ "description": "parses single line comments" }, { - "path": "parsing/multilineComments", - "description": "parses multiline comments" + "path": "parsing/AnonymousOperation/query", + "description": "parse anonymous query" + }, + { + "path": "parsing/AnonymousOperation/mutation", + "description": "parse anonymous mutation" + }, + { + "path": "parsing/AnonymousOperation/subscription", + "description": "parse anonymous subscription" + }, + { + "path": "parsing/directive/operation", + "description": "parse operation directives" + }, + { + "path": "parsing/directive/selection", + "description": "parse directives on selection fields" + }, + { + "path": "parsing/directive/notOnArgument", + "description": "fail when: directives are used in arguments" + }, + { + "path": "parsing/directive/notOnVariable", + "description": "fail when: directive is used in Variable Definition" } ] diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql b/test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql @@ -0,0 +1,5 @@ +mutation { + createUser (userID:"") { + name + } +} diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json b/test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json @@ -0,0 +1,7 @@ +{ + "data": { + "createUser": { + "name": "testName" + } + } +} diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql b/test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql @@ -0,0 +1,5 @@ +query { + user { + name + } +} diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/query/response.json b/test/Feature/Holistic/parsing/AnonymousOperation/query/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/query/response.json @@ -0,0 +1,7 @@ +{ + "data": { + "user": { + "name": "testName" + } + } +} diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql b/test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql @@ -0,0 +1,5 @@ +subscription { + newUser { + name + } +} diff --git a/test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json b/test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json @@ -0,0 +1,3 @@ +{ + "data": null +} diff --git a/test/Feature/Holistic/parsing/directive/notOnArgument/query.gql b/test/Feature/Holistic/parsing/directive/notOnArgument/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/notOnArgument/query.gql @@ -0,0 +1,3 @@ +query Foo { + someField( someArgs: { value: "" } @goo @name(name: {id:1}) ) +} diff --git a/test/Feature/Holistic/parsing/directive/notOnArgument/response.json b/test/Feature/Holistic/parsing/directive/notOnArgument/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/notOnArgument/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', IgnoredTokens, assignment, or white space\n", + "locations": [ + { + "line": 2, + "column": 40 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/parsing/directive/notOnVariable/query.gql b/test/Feature/Holistic/parsing/directive/notOnVariable/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/notOnVariable/query.gql @@ -0,0 +1,5 @@ +query Foo ($name: Int @someDir ) { + user { + name + } +} diff --git a/test/Feature/Holistic/parsing/directive/notOnVariable/response.json b/test/Feature/Holistic/parsing/directive/notOnVariable/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/notOnVariable/response.json @@ -0,0 +1,13 @@ +{ + "errors": [ + { + "message": "offset=22:\nunexpected '@'\nexpecting '!', '#', ')', ',', '=', IgnoredTokens, VariableDefinition, or white space\n", + "locations": [ + { + "line": 1, + "column": 23 + } + ] + } + ] +} diff --git a/test/Feature/Holistic/parsing/directive/operation/query.gql b/test/Feature/Holistic/parsing/directive/operation/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/operation/query.gql @@ -0,0 +1,5 @@ +query Foo @someDirective (name: "testName" ) { + user { + name + } +} diff --git a/test/Feature/Holistic/parsing/directive/operation/response.json b/test/Feature/Holistic/parsing/directive/operation/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/operation/response.json @@ -0,0 +1,7 @@ +{ + "data": { + "user": { + "name": "testName" + } + } +} diff --git a/test/Feature/Holistic/parsing/directive/selection/query.gql b/test/Feature/Holistic/parsing/directive/selection/query.gql new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/selection/query.gql @@ -0,0 +1,6 @@ +query Foo { + user { + name @skip(name:"") @deprecated + email @someDir + } +} diff --git a/test/Feature/Holistic/parsing/directive/selection/response.json b/test/Feature/Holistic/parsing/directive/selection/response.json new file mode 100644 --- /dev/null +++ b/test/Feature/Holistic/parsing/directive/selection/response.json @@ -0,0 +1,8 @@ +{ + "data": { + "user": { + "name": "testName", + "email": "" + } + } +} diff --git a/test/Feature/Holistic/parsing/invalidFields/response.json b/test/Feature/Holistic/parsing/invalidFields/response.json --- a/test/Feature/Holistic/parsing/invalidFields/response.json +++ b/test/Feature/Holistic/parsing/invalidFields/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "offset=26:\nunexpected '<'\nexpecting \"\"\"\"\", '#', ',', '_', '}', body, digit, entry, letter, maybeArguments, or white space\n", + "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Directives, IgnoredTokens, Selection, body, digit, letter, maybeArguments, or white space\n", "locations": [ { "line": 1, diff --git a/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json b/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json --- a/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json +++ b/test/Feature/Holistic/parsing/invalidNotNullOperator/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "offset=20:\nunexpected '@'\nexpecting \"\"\"\"\", '!', '#', ']', '_', digit, letter, or white space\n", + "message": "offset=20:\nunexpected '@'\nexpecting '!', '#', ']', '_', IgnoredTokens, digit, letter, or white space\n", "locations": [ { "line": 1, diff --git a/test/Feature/Holistic/parsing/missingCloseBrace/response.json b/test/Feature/Holistic/parsing/missingCloseBrace/response.json --- a/test/Feature/Holistic/parsing/missingCloseBrace/response.json +++ b/test/Feature/Holistic/parsing/missingCloseBrace/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "offset=66:\nunexpected end of input\nexpecting \"\"\"\"\", '#', ',', '}', entry, or white space\n", + "message": "offset=66:\nunexpected end of input\nexpecting '#', ',', '}', Selection, or white space\n", "locations": [ { "line": 5, diff --git a/test/Feature/Holistic/parsing/multilineComments/query.gql b/test/Feature/Holistic/parsing/multilineComments/query.gql deleted file mode 100644 --- a/test/Feature/Holistic/parsing/multilineComments/query.gql +++ /dev/null @@ -1,131 +0,0 @@ -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - -""" -""" - -""" - - -""" - - -""" - comment with tabs - -""" - - -query -""" -%& -%wer""g ''Comme -""" -GetUsers """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" ( """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" $v: """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - [ """ somejhgja """ Int """ 343 """ ! """ 343 """ ] # starting Comment'' # starting Comment'' -) { - user { - """ %& -%(// - %& ''Comme""" - - email2: """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" email """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - name """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - - address( """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - coordinates: { -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" longitude: 0 # starting Comment'' - latitude: "" # starting Comment'' # starting Comment'' # starting Comment'' - } - ) """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" { - """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - # starting Comment'' - ...City - } - office """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" ( - zipCode: $v # starting Comment'' - cityID: EnumA - ) """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" { - houseNumber """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - - ... on Address { -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - city """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - } - } - """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - } -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme"""} -# starting Comment'' -# starting Comment'' - -fragment City on Address """ %& -%(// - %& %(// -%&%& # startin""g ''Comme""" { -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" - city""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" -} -""" %& -%(// - %& %(// -%&%& # startin""g ''Comme""" diff --git a/test/Feature/Holistic/parsing/multilineComments/response.json b/test/Feature/Holistic/parsing/multilineComments/response.json deleted file mode 100644 --- a/test/Feature/Holistic/parsing/multilineComments/response.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "data": { - "user": { - "email2": "", - "name": "testName", - "address": { - "city": "" - }, - "office": { - "houseNumber": 0, - "city": "" - } - } - } -} diff --git a/test/Feature/Holistic/selection/AliasNameConflict/query.gql b/test/Feature/Holistic/selection/AliasNameConflict/query.gql --- a/test/Feature/Holistic/selection/AliasNameConflict/query.gql +++ b/test/Feature/Holistic/selection/AliasNameConflict/query.gql @@ -1,7 +1,8 @@ { user { - name: name - name: name - name: name + name2: name + name2: name + name2: name + name } } diff --git a/test/Feature/Holistic/selection/AliasNameConflict/response.json b/test/Feature/Holistic/selection/AliasNameConflict/response.json --- a/test/Feature/Holistic/selection/AliasNameConflict/response.json +++ b/test/Feature/Holistic/selection/AliasNameConflict/response.json @@ -1,7 +1,7 @@ { "errors": [ { - "message": "duplicate selection of key \"name\" on type \"User\".", + "message": "duplicate selection of key \"name2\" on type \"User\".", "locations": [ { "line": 4, @@ -10,7 +10,7 @@ ] }, { - "message": "duplicate selection of key \"name\" on type \"User\".", + "message": "duplicate selection of key \"name2\" on type \"User\".", "locations": [ { "line": 5, diff --git a/test/Feature/Holistic/selection/AliasUnknownField/response.json b/test/Feature/Holistic/selection/AliasUnknownField/response.json --- a/test/Feature/Holistic/selection/AliasUnknownField/response.json +++ b/test/Feature/Holistic/selection/AliasUnknownField/response.json @@ -5,7 +5,7 @@ "locations": [ { "line": 3, - "column": 14 + "column": 5 } ] } diff --git a/test/Feature/Input/Enum/API.hs b/test/Feature/Input/Enum/API.hs --- a/test/Feature/Input/Enum/API.hs +++ b/test/Feature/Input/Enum/API.hs @@ -10,7 +10,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (ENUM) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) import GHC.Generics (Generic) data TwoCon @@ -49,22 +49,22 @@ type KIND ThreeCon = ENUM -- query -testRes :: TestArgs a -> IORes a -testRes TestArgs {level} = return level +testRes :: Applicative m => TestArgs a -> m a +testRes TestArgs {level} = pure level -- resolver -data Query = Query - { test :: TestArgs Level -> IORes Level - , test2 :: TestArgs TwoCon -> IORes TwoCon - , test3 :: TestArgs ThreeCon -> IORes ThreeCon +data Query m = Query + { test :: TestArgs Level -> m Level + , test2 :: TestArgs TwoCon -> m TwoCon + , test3 :: TestArgs ThreeCon -> m ThreeCon } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {test = testRes, test2 = testRes, test3 = testRes} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse diff --git a/test/Feature/InputType/API.hs b/test/Feature/InputType/API.hs --- a/test/Feature/InputType/API.hs +++ b/test/Feature/InputType/API.hs @@ -10,7 +10,8 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (OBJECT) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, + Undefined (..)) import Data.Text (Text) import GHC.Generics (Generic) @@ -25,23 +26,23 @@ } deriving (Generic) data A = A - { a1 :: F1Args -> IORes Text - , a2 :: F2Args -> IORes Int + { a1 :: F1Args -> IORes () Text + , a2 :: F2Args -> IORes () Int } deriving (Generic) instance GQLType A where type KIND A = OBJECT -newtype Query = Query +newtype Query (m :: * -> *) = Query { q1 :: A } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {q1 = A {a1 = const $ return "a1Test", a2 = const $ return 1}} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {q1 = A {a1 = const $ return "a1Test", a2 = const $ return 1}} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse diff --git a/test/Feature/Schema/API.hs b/test/Feature/Schema/API.hs --- a/test/Feature/Schema/API.hs +++ b/test/Feature/Schema/API.hs @@ -10,7 +10,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (OBJECT) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..)) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..)) import Data.Text (Text) import qualified Feature.Schema.A2 as A2 (A (..)) import GHC.Generics (Generic) @@ -23,17 +23,17 @@ instance GQLType A where type KIND A = OBJECT -data Query = Query +data Query (m :: * -> * ) = Query { a1 :: A , a2 :: A2.A } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {a1 = A "" 0, a2 = A2.A 0} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse diff --git a/test/Feature/UnionType/API.hs b/test/Feature/UnionType/API.hs --- a/test/Feature/UnionType/API.hs +++ b/test/Feature/UnionType/API.hs @@ -10,7 +10,8 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (OBJECT, UNION) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes) +import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, + Undefined (..)) import Data.Text (Text) import GHC.Generics (Generic) @@ -46,20 +47,20 @@ | B' B deriving (Generic) -data Query = Query - { union :: () -> IORes [AOrB] +data Query m = Query + { union :: () -> m [AOrB] , fc :: C } deriving (Generic, GQLType) -resolveUnion :: () -> IORes [AOrB] +resolveUnion :: () -> IORes () [AOrB] resolveUnion _ = return [A' A {aText = "at", aInt = 1}, B' B {bText = "bt", bInt = 2}] -rootResolver :: GQLRootResolver IO () () Query () () +rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver - { queryResolver = return Query {union = resolveUnion, fc = C {cText = "", cInt = 3}} - , mutationResolver = return () - , subscriptionResolver = return () + { queryResolver = Query {union = resolveUnion, fc = C {cText = "", cInt = 3}} + , mutationResolver = Undefined + , subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse diff --git a/test/Feature/WrappedTypeName/API.hs b/test/Feature/WrappedTypeName/API.hs --- a/test/Feature/WrappedTypeName/API.hs +++ b/test/Feature/WrappedTypeName/API.hs @@ -10,8 +10,8 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Kind (OBJECT) -import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IOMutRes, IORes, - IOSubRes, SubResolver (..)) +import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes, + Resolver (..), constRes) import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -32,39 +32,39 @@ , aInt :: Int } deriving (Generic) -data Query = Query - { a1 :: WA IORes +data Query m = Query + { a1 :: WA m , a2 :: Maybe (Wrapped Int Int) , a3 :: Maybe (Wrapped (Wrapped Text Int) Text) } deriving (Generic, GQLType) -data Mutation = Mutation - { mut1 :: Maybe (WA (IOMutRes EVENT ())) +data Mutation m = Mutation + { mut1 :: Maybe (WA m) , mut2 :: Maybe (Wrapped Int Int) , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text) } deriving (Generic, GQLType) -data EVENT = - EVENT +data Channel = + Channel deriving (Show, Eq) -data Subscription = Subscription - { sub1 :: () -> IOSubRes EVENT () (Maybe (WA IORes)) - , sub2 :: () -> IOSubRes EVENT () (Maybe (Wrapped Int Int)) - , sub3 :: () -> IOSubRes EVENT () (Maybe (Wrapped (Wrapped Text Int) Text)) +type EVENT = Event Channel () + +data Subscription (m :: * -> *) = Subscription + { sub1 :: () -> m (Maybe (WA (IORes EVENT))) + , sub2 :: () -> m (Maybe (Wrapped Int Int)) + , sub3 :: () -> m (Maybe (Wrapped (Wrapped Text Int) Text)) } deriving (Generic, GQLType) -rootResolver :: GQLRootResolver IO EVENT () Query Mutation Subscription +rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver - { queryResolver = return Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing} - , mutationResolver = return Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing} - , subscriptionResolver = - return - Subscription - { sub1 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing} - , sub2 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing} - , sub3 = const SubResolver {subChannels = [EVENT], subResolver = const $ return Nothing} + { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing} + , mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing} + , subscriptionResolver = Subscription + { sub1 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing} + , sub2 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing} + , sub3 = const SubResolver {subChannels = [Channel], subResolver = constRes Nothing} } } diff --git a/test/Rendering/Schema.hs b/test/Rendering/Schema.hs --- a/test/Rendering/Schema.hs +++ b/test/Rendering/Schema.hs @@ -16,8 +16,8 @@ import Data.Morpheus.Document (importGQLDocumentWithNamespace) import Data.Morpheus.Kind (SCALAR) -import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), IORes, - ScalarValue (..)) +import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), ScalarValue (..), + Undefined (..)) import Data.Proxy (Proxy (..)) import Data.Text (Text) import GHC.Generics (Generic) @@ -35,5 +35,5 @@ importGQLDocumentWithNamespace "test/Rendering/schema.gql" -schemaProxy :: Proxy (GQLRootResolver IO () () (Query IORes) () ()) -schemaProxy = Proxy @(GQLRootResolver IO () () (Query IORes) () ()) +schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined) +schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined)