morpheus-graphql 0.4.0 → 0.5.0
raw patch · 90 files changed
+2035/−1411 lines, 90 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.Morpheus.Types: SubResolver :: [e] -> (Event e c -> Resolver m a) -> SubResolver m e c a
- Data.Morpheus.Types: [subChannels] :: SubResolver m e c a -> [e]
- Data.Morpheus.Types: [subResolver] :: SubResolver m e c a -> Event e c -> Resolver m a
- Data.Morpheus.Types: data SubResolver m e c a
- Data.Morpheus.Types: mutResolver :: Monad m => [Event e c] -> StreamT m (Event e c) (Either String a) -> MutResolver m e c a
- Data.Morpheus.Types: resolver :: m (Either String a) -> Resolver m a
- Data.Morpheus.Types: toMutResolver :: Monad m => [Event e c] -> Resolver m a -> MutResolver m e c a
- Data.Morpheus.Types: type Resolver = ExceptT String
- Data.Morpheus.Types: type SubRootRes m e sub = Resolver (SubscribeStream m e) sub
+ Data.Morpheus.Kind: ResContext :: ResContext event value
+ Data.Morpheus.Kind: data ResContext (kind :: GQL_KIND) (operation :: OperationType) (m :: * -> *) event value
+ Data.Morpheus.Types: Undefined :: Undefined
+ Data.Morpheus.Types: [FailedResolver] :: {unFailedResolver :: String} -> Resolver o m event value
+ Data.Morpheus.Types: [MutResolver] :: {mutEvents :: [event], mutResolver :: ExceptT String m value} -> Resolver MUTATION m event value
+ Data.Morpheus.Types: [QueryResolver] :: {unQueryResolver :: ExceptT String m value} -> Resolver QUERY m event value
+ Data.Morpheus.Types: [SubResolver] :: {subChannels :: [StreamChannel event], subResolver :: event -> Resolver QUERY m event value} -> Resolver SUBSCRIPTION m event value
+ Data.Morpheus.Types: constMutRes :: Monad m => [e] -> a -> args -> MutRes m e a
+ Data.Morpheus.Types: data Resolver (o :: OperationType) (m :: * -> *) event value
+ Data.Morpheus.Types: data Undefined (m :: * -> *)
+ Data.Morpheus.Types: type MUTATION = 'Mutation
+ Data.Morpheus.Types: type MutRes = Resolver MUTATION
+ Data.Morpheus.Types: type QUERY = 'Query
+ Data.Morpheus.Types: type Res = Resolver QUERY
+ Data.Morpheus.Types: type SUBSCRIPTION = 'Subscription
+ Data.Morpheus.Types: type SubRes = Resolver SUBSCRIPTION
- Data.Morpheus: class Interpreter k m e c
+ Data.Morpheus: class Interpreter k m e
- Data.Morpheus: interpreter :: (Interpreter k m e c, Monad m) => RootResCon m e c que mut sub => GQLRootResolver m e c que mut sub -> k
+ Data.Morpheus: interpreter :: (Interpreter k m e, Monad m) => RootResCon m e query mut sub => GQLRootResolver m e query mut sub -> k
- Data.Morpheus.Document: toGraphQLDocument :: RootResCon m e c query mut sub => proxy (GQLRootResolver m e c query mut sub) -> ByteString
+ Data.Morpheus.Document: toGraphQLDocument :: RootResCon m event query mut sub => proxy (GQLRootResolver m event query mut sub) -> ByteString
- Data.Morpheus.Server: gqlSocketApp :: RootResCon IO e c que mut sub => GQLRootResolver IO e c que mut sub -> GQLState IO e c -> ServerApp
+ Data.Morpheus.Server: gqlSocketApp :: RootResCon IO e que mut sub => GQLRootResolver IO e que mut sub -> GQLState IO e -> ServerApp
- Data.Morpheus.Server: initGQLState :: IO (GQLState m e c)
+ Data.Morpheus.Server: initGQLState :: IO (GQLState m e)
- Data.Morpheus.Server: type GQLState m e c = MVar (ClientRegister m e c)
+ Data.Morpheus.Server: type GQLState m e = MVar (ClientRegister m e)
- Data.Morpheus.Types: GQLRootResolver :: Resolver m query -> Resolver (PublishStream m e c) mut -> SubRootRes m e sub -> GQLRootResolver m e c query mut sub
+ Data.Morpheus.Types: GQLRootResolver :: query (Resolver QUERY m event) -> mut (Resolver MUTATION m event) -> sub (Resolver SUBSCRIPTION m event) -> GQLRootResolver event
- Data.Morpheus.Types: [mutationResolver] :: GQLRootResolver m e c query mut sub -> Resolver (PublishStream m e c) mut
+ Data.Morpheus.Types: [mutationResolver] :: GQLRootResolver event -> mut (Resolver MUTATION m event)
- Data.Morpheus.Types: [queryResolver] :: GQLRootResolver m e c query mut sub -> Resolver m query
+ Data.Morpheus.Types: [queryResolver] :: GQLRootResolver event -> query (Resolver QUERY m event)
- Data.Morpheus.Types: [subscriptionResolver] :: GQLRootResolver m e c query mut sub -> SubRootRes m e sub
+ Data.Morpheus.Types: [subscriptionResolver] :: GQLRootResolver event -> sub (Resolver SUBSCRIPTION m event)
- Data.Morpheus.Types: constRes :: Monad m => b -> a -> m b
+ Data.Morpheus.Types: constRes :: (PureOperation o, Monad m) => b -> a -> Resolver o m e b
- Data.Morpheus.Types: data GQLRootResolver m e c query mut sub
+ Data.Morpheus.Types: data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *)
- Data.Morpheus.Types: type IOMutRes e c = MutResolver IO e c
+ Data.Morpheus.Types: type IOMutRes = MutRes IO
- Data.Morpheus.Types: type IORes = Resolver IO
+ Data.Morpheus.Types: type IORes = Res IO
- Data.Morpheus.Types: type IOSubRes e c = SubResolver IO e c
+ Data.Morpheus.Types: type IOSubRes = SubRes IO
Files
- README.md +47/−42
- assets/simple.gql +35/−1
- changelog.md +61/−0
- examples/Client/Client.hs +7/−2
- examples/Main.hs +2/−2
- examples/Mythology/API.hs +10/−10
- examples/Sophisticated/API.hs +42/−56
- examples/Sophisticated/api.gql +39/−12
- examples/Subscription/SimpleSubscription.hs +41/−21
- examples/Subscription/api.gql +11/−0
- examples/TH/Simple.hs +7/−3
- morpheus-graphql.cabal +113/−99
- src/Data/Morpheus/Document.hs +1/−1
- src/Data/Morpheus/Error/Internal.hs +7/−3
- src/Data/Morpheus/Execution/Client/Fetch.hs +9/−1
- src/Data/Morpheus/Execution/Client/Selection.hs +32/−41
- src/Data/Morpheus/Execution/Document/Convert.hs +1/−1
- src/Data/Morpheus/Execution/Document/Encode.hs +24/−21
- src/Data/Morpheus/Execution/Internal/Declare.hs +1/−1
- src/Data/Morpheus/Execution/Server/Encode.hs +80/−122
- src/Data/Morpheus/Execution/Server/Interpreter.hs +20/−20
- src/Data/Morpheus/Execution/Server/Resolve.hs +44/−53
- src/Data/Morpheus/Execution/Subscription/ClientRegister.hs +16/−16
- src/Data/Morpheus/Kind.hs +6/−0
- src/Data/Morpheus/Parsing/Document/DataType.hs +0/−124
- src/Data/Morpheus/Parsing/Document/Parser.hs +7/−7
- src/Data/Morpheus/Parsing/Document/TypeSystem.hs +218/−0
- src/Data/Morpheus/Parsing/Internal/Pattern.hs +100/−0
- src/Data/Morpheus/Parsing/Internal/Terms.hs +98/−13
- src/Data/Morpheus/Parsing/Internal/Value.hs +8/−1
- src/Data/Morpheus/Parsing/Request/Arguments.hs +14/−3
- src/Data/Morpheus/Parsing/Request/Body.hs +0/−69
- src/Data/Morpheus/Parsing/Request/Fragment.hs +0/−27
- src/Data/Morpheus/Parsing/Request/Operation.hs +50/−31
- src/Data/Morpheus/Parsing/Request/Parser.hs +5/−5
- src/Data/Morpheus/Parsing/Request/Selection.hs +120/−0
- src/Data/Morpheus/Schema/Schema.hs +1/−1
- src/Data/Morpheus/Schema/SchemaAPI.hs +10/−13
- src/Data/Morpheus/Server.hs +9/−10
- src/Data/Morpheus/Types.hs +33/−24
- src/Data/Morpheus/Types/Custom.hs +2/−2
- src/Data/Morpheus/Types/GQLType.hs +21/−23
- src/Data/Morpheus/Types/IO.hs +7/−1
- src/Data/Morpheus/Types/Internal/AST/Operation.hs +14/−6
- src/Data/Morpheus/Types/Internal/AST/RawSelection.hs +9/−22
- src/Data/Morpheus/Types/Internal/AST/Selection.hs +9/−7
- src/Data/Morpheus/Types/Internal/Base.hs +20/−7
- src/Data/Morpheus/Types/Internal/Data.hs +15/−3
- src/Data/Morpheus/Types/Internal/Resolver.hs +273/−0
- src/Data/Morpheus/Types/Internal/Stream.hs +45/−47
- src/Data/Morpheus/Types/Internal/TH.hs +4/−0
- src/Data/Morpheus/Types/Internal/Validation.hs +0/−7
- src/Data/Morpheus/Types/Internal/WebSocket.hs +6/−6
- src/Data/Morpheus/Types/Resolver.hs +0/−110
- src/Data/Morpheus/Types/Types.hs +9/−1
- src/Data/Morpheus/Validation/Query/Fragment.hs +4/−5
- src/Data/Morpheus/Validation/Query/Selection.hs +41/−55
- src/Data/Morpheus/Validation/Query/Validation.hs +10/−8
- src/Data/Morpheus/Validation/Query/Variable.hs +13/−12
- test/Feature/Holistic/API.gql +1/−1
- test/Feature/Holistic/API.hs +15/−17
- test/Feature/Holistic/cases.json +26/−2
- test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql +5/−0
- test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json +7/−0
- test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql +5/−0
- test/Feature/Holistic/parsing/AnonymousOperation/query/response.json +7/−0
- test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql +5/−0
- test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json +3/−0
- test/Feature/Holistic/parsing/directive/notOnArgument/query.gql +3/−0
- test/Feature/Holistic/parsing/directive/notOnArgument/response.json +13/−0
- test/Feature/Holistic/parsing/directive/notOnVariable/query.gql +5/−0
- test/Feature/Holistic/parsing/directive/notOnVariable/response.json +13/−0
- test/Feature/Holistic/parsing/directive/operation/query.gql +5/−0
- test/Feature/Holistic/parsing/directive/operation/response.json +7/−0
- test/Feature/Holistic/parsing/directive/selection/query.gql +6/−0
- test/Feature/Holistic/parsing/directive/selection/response.json +8/−0
- test/Feature/Holistic/parsing/invalidFields/response.json +1/−1
- test/Feature/Holistic/parsing/invalidNotNullOperator/response.json +1/−1
- test/Feature/Holistic/parsing/missingCloseBrace/response.json +1/−1
- test/Feature/Holistic/parsing/multilineComments/query.gql +0/−131
- test/Feature/Holistic/parsing/multilineComments/response.json +0/−15
- test/Feature/Holistic/selection/AliasNameConflict/query.gql +4/−3
- test/Feature/Holistic/selection/AliasNameConflict/response.json +2/−2
- test/Feature/Holistic/selection/AliasUnknownField/response.json +1/−1
- test/Feature/Input/Enum/API.hs +11/−11
- test/Feature/InputType/API.hs +9/−8
- test/Feature/Schema/API.hs +6/−6
- test/Feature/UnionType/API.hs +9/−8
- test/Feature/WrappedTypeName/API.hs +21/−21
- test/Rendering/Schema.hs +4/−4
README.md view
@@ -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 ```
assets/simple.gql view
@@ -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
changelog.md view
@@ -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
examples/Client/Client.hs view
@@ -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
examples/Main.hs view
@@ -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)
examples/Mythology/API.hs view
@@ -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
examples/Sophisticated/API.hs view
@@ -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 }
examples/Sophisticated/api.gql view
@@ -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
examples/Subscription/SimpleSubscription.hs view
@@ -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+ }
+ examples/Subscription/api.gql view
@@ -0,0 +1,11 @@+type Query {+ deity: Deity+}++type Mutation {+ createDeity: Deity+}++type Subscription {+ newDeity: Deity+}
examples/TH/Simple.hs view
@@ -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
morpheus-graphql.cabal view
@@ -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
src/Data/Morpheus/Document.hs view
@@ -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)
src/Data/Morpheus/Error/Internal.hs view
@@ -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
src/Data/Morpheus/Execution/Client/Fetch.hs view
@@ -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
src/Data/Morpheus/Execution/Client/Selection.hs view
@@ -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
src/Data/Morpheus/Execution/Document/Convert.hs view
@@ -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)
src/Data/Morpheus/Execution/Document/Encode.hs view
@@ -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 _ (<Object> 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 (<Type> (SubResolver m e c)) or (<Type> (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 <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where- appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) [mainType, result]+ appHead = instanceHeadMultiT ''ObjectResolvers (conT ''TRUE) (mainType: instanceArgs) ------------------------------------------------------------------ -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...] methods = [funD 'objectResolvers [clause argsE (normalB body) []]]
src/Data/Morpheus/Execution/Internal/Declare.hs view
@@ -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 = (->)
src/Data/Morpheus/Execution/Server/Encode.hs view
@@ -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
src/Data/Morpheus/Execution/Server/Interpreter.hs view
@@ -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)
src/Data/Morpheus/Execution/Server/Resolve.hs view
@@ -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
src/Data/Morpheus/Execution/Subscription/ClientRegister.hs view
@@ -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
src/Data/Morpheus/Kind.hs view
@@ -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
− src/Data/Morpheus/Parsing/Document/DataType.hs
@@ -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)
src/Data/Morpheus/Parsing/Document/Parser.hs view
@@ -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 =
+ src/Data/Morpheus/Parsing/Document/TypeSystem.hs view
@@ -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)
+ src/Data/Morpheus/Parsing/Internal/Pattern.hs view
@@ -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
src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -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)
src/Data/Morpheus/Parsing/Internal/Value.hs view
@@ -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
src/Data/Morpheus/Parsing/Request/Arguments.hs view
@@ -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
− src/Data/Morpheus/Parsing/Request/Body.hs
@@ -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})
− src/Data/Morpheus/Parsing/Request/Fragment.hs
@@ -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})
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -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
src/Data/Morpheus/Parsing/Request/Parser.hs view
@@ -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
+ src/Data/Morpheus/Parsing/Request/Selection.hs view
@@ -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})
src/Data/Morpheus/Schema/Schema.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances , FlexibleContexts #-} module Data.Morpheus.Schema.Schema ( Root(..)
src/Data/Morpheus/Schema/SchemaAPI.hs view
@@ -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
src/Data/Morpheus/Server.hs view
@@ -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 <-
src/Data/Morpheus/Types.hs view
@@ -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
src/Data/Morpheus/Types/Custom.hs view
@@ -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
src/Data/Morpheus/Types/GQLType.hs view
@@ -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
src/Data/Morpheus/Types/IO.hs view
@@ -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
src/Data/Morpheus/Types/Internal/AST/Operation.hs view
@@ -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
src/Data/Morpheus/Types/Internal/AST/RawSelection.hs view
@@ -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)
src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -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)
src/Data/Morpheus/Types/Internal/Base.hs view
@@ -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
src/Data/Morpheus/Types/Internal/Data.hs view
@@ -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
+ src/Data/Morpheus/Types/Internal/Resolver.hs view
@@ -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)+ }
src/Data/Morpheus/Types/Internal/Stream.hs view
@@ -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
src/Data/Morpheus/Types/Internal/TH.hs view
@@ -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))
src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -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
src/Data/Morpheus/Types/Internal/WebSocket.hs view
@@ -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 <> "}"
− src/Data/Morpheus/Types/Resolver.hs
@@ -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- }
src/Data/Morpheus/Types/Types.hs view
@@ -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
src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -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'}) =
src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -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
src/Data/Morpheus/Validation/Query/Validation.hs view
@@ -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}
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -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)
test/Feature/Holistic/API.gql view
@@ -43,7 +43,7 @@ } type Mutation {- createUser(userID: String!, userName: String!): User!+ createUser(userID: String!, userName: String): User! } type Subscription {
test/Feature/Holistic/API.hs view
@@ -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
test/Feature/Holistic/cases.json view
@@ -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" } ]
+ test/Feature/Holistic/parsing/AnonymousOperation/mutation/query.gql view
@@ -0,0 +1,5 @@+mutation {+ createUser (userID:"") {+ name+ }+}
+ test/Feature/Holistic/parsing/AnonymousOperation/mutation/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "createUser": {+ "name": "testName"+ }+ }+}
+ test/Feature/Holistic/parsing/AnonymousOperation/query/query.gql view
@@ -0,0 +1,5 @@+query {+ user {+ name+ }+}
+ test/Feature/Holistic/parsing/AnonymousOperation/query/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "user": {+ "name": "testName"+ }+ }+}
+ test/Feature/Holistic/parsing/AnonymousOperation/subscription/query.gql view
@@ -0,0 +1,5 @@+subscription {+ newUser {+ name+ }+}
+ test/Feature/Holistic/parsing/AnonymousOperation/subscription/response.json view
@@ -0,0 +1,3 @@+{+ "data": null+}
+ test/Feature/Holistic/parsing/directive/notOnArgument/query.gql view
@@ -0,0 +1,3 @@+query Foo {+ someField( someArgs: { value: "" } @goo @name(name: {id:1}) )+}
+ test/Feature/Holistic/parsing/directive/notOnArgument/response.json view
@@ -0,0 +1,13 @@+{+ "errors": [+ {+ "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', IgnoredTokens, assignment, or white space\n",+ "locations": [+ {+ "line": 2,+ "column": 40+ }+ ]+ }+ ]+}
+ test/Feature/Holistic/parsing/directive/notOnVariable/query.gql view
@@ -0,0 +1,5 @@+query Foo ($name: Int @someDir ) {+ user {+ name+ }+}
+ test/Feature/Holistic/parsing/directive/notOnVariable/response.json view
@@ -0,0 +1,13 @@+{+ "errors": [+ {+ "message": "offset=22:\nunexpected '@'\nexpecting '!', '#', ')', ',', '=', IgnoredTokens, VariableDefinition, or white space\n",+ "locations": [+ {+ "line": 1,+ "column": 23+ }+ ]+ }+ ]+}
+ test/Feature/Holistic/parsing/directive/operation/query.gql view
@@ -0,0 +1,5 @@+query Foo @someDirective (name: "testName" ) {+ user {+ name+ }+}
+ test/Feature/Holistic/parsing/directive/operation/response.json view
@@ -0,0 +1,7 @@+{+ "data": {+ "user": {+ "name": "testName"+ }+ }+}
+ test/Feature/Holistic/parsing/directive/selection/query.gql view
@@ -0,0 +1,6 @@+query Foo {+ user {+ name @skip(name:"") @deprecated+ email @someDir+ }+}
+ test/Feature/Holistic/parsing/directive/selection/response.json view
@@ -0,0 +1,8 @@+{+ "data": {+ "user": {+ "name": "testName",+ "email": ""+ }+ }+}
test/Feature/Holistic/parsing/invalidFields/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "offset=26:\nunexpected '<'\nexpecting \"\"\"\"\", '#', ',', '_', '}', body, digit, entry, letter, maybeArguments, or white space\n",+ "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Directives, IgnoredTokens, Selection, body, digit, letter, maybeArguments, or white space\n", "locations": [ { "line": 1,
test/Feature/Holistic/parsing/invalidNotNullOperator/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "offset=20:\nunexpected '@'\nexpecting \"\"\"\"\", '!', '#', ']', '_', digit, letter, or white space\n",+ "message": "offset=20:\nunexpected '@'\nexpecting '!', '#', ']', '_', IgnoredTokens, digit, letter, or white space\n", "locations": [ { "line": 1,
test/Feature/Holistic/parsing/missingCloseBrace/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "offset=66:\nunexpected end of input\nexpecting \"\"\"\"\", '#', ',', '}', entry, or white space\n",+ "message": "offset=66:\nunexpected end of input\nexpecting '#', ',', '}', Selection, or white space\n", "locations": [ { "line": 5,
− test/Feature/Holistic/parsing/multilineComments/query.gql
@@ -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"""
− test/Feature/Holistic/parsing/multilineComments/response.json
@@ -1,15 +0,0 @@-{- "data": {- "user": {- "email2": "",- "name": "testName",- "address": {- "city": ""- },- "office": {- "houseNumber": 0,- "city": ""- }- }- }-}
test/Feature/Holistic/selection/AliasNameConflict/query.gql view
@@ -1,7 +1,8 @@ { user {- name: name- name: name- name: name+ name2: name+ name2: name+ name2: name+ name } }
test/Feature/Holistic/selection/AliasNameConflict/response.json view
@@ -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,
test/Feature/Holistic/selection/AliasUnknownField/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 3,- "column": 14+ "column": 5 } ] }
test/Feature/Input/Enum/API.hs view
@@ -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
test/Feature/InputType/API.hs view
@@ -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
test/Feature/Schema/API.hs view
@@ -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
test/Feature/UnionType/API.hs view
@@ -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
test/Feature/WrappedTypeName/API.hs view
@@ -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} } }
test/Rendering/Schema.hs view
@@ -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)