mu-graphql 0.4.0.0 → 0.4.1.0
raw patch · 9 files changed
+396/−367 lines, 9 filesdep +graphqldep +megaparsecdep −attoparsecdep −graphql-parserdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: graphql, megaparsec
Dependencies removed: attoparsec, graphql-parser
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
- Mu.GraphQL.Annotations: fromGQLValueConst :: forall f. Alternative f => ValueConst -> f (ValueConst Integer String)
+ Mu.GraphQL.Annotations: fromGQLValueConst :: forall f. Alternative f => ConstValue -> f (ValueConst Integer String)
- Mu.GraphQL.Annotations: reflectValueConst :: ReflectValueConst v => proxy v -> ValueConst
+ Mu.GraphQL.Annotations: reflectValueConst :: ReflectValueConst v => proxy v -> ConstValue
Files
- mu-graphql.cabal +5/−5
- src/Mu/GraphQL/Annotations.hs +28/−27
- src/Mu/GraphQL/Quasi.hs +87/−94
- src/Mu/GraphQL/Quasi/LostParser.hs +22/−32
- src/Mu/GraphQL/Query/Definition.hs +3/−3
- src/Mu/GraphQL/Query/Parse.hs +183/−154
- src/Mu/GraphQL/Query/Run.hs +13/−15
- src/Mu/GraphQL/Server.hs +38/−23
- src/Mu/GraphQL/Subscription/Protocol.hs +17/−14
mu-graphql.cabal view
@@ -1,5 +1,5 @@ name: mu-graphql-version: 0.4.0.0+version: 0.4.1.0 synopsis: GraphQL support for Mu description: GraphQL servers and clients for Mu-Haskell cabal-version: >=1.10@@ -31,14 +31,14 @@ build-depends: aeson >=1.4 && <2 , async >=2.2 && <3- , attoparsec >=0.13 && <0.14 , base >=4.12 && <5 , bytestring >=0.10 && <0.11 , conduit >=1.3.2 && <2 , foldl >=1.4 && <2- , graphql-parser+ , graphql >=0.11 , http-types >=0.12 && <0.13 , list-t >=1.0 && <2+ , megaparsec >=8 && <10 , mtl >=2.2 && <2.3 , mu-rpc ==0.4.* , mu-schema ==0.3.*@@ -49,7 +49,7 @@ , stm-chans >=3 && <4 , stm-conduit >=4 && <5 , stm-containers >=1.1 && <2- , template-haskell >=2.14 && <2.16+ , template-haskell >=2.14 && <2.17 , text >=1.2 && <1.3 , unordered-containers >=0.2 && <0.3 , uuid >=1.3 && <2@@ -67,7 +67,7 @@ main-is: Main.hs hs-source-dirs: exe default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -threaded build-depends: base >=4.12 && <5 , conduit >=1.3.2 && <1.4
src/Mu/GraphQL/Annotations.hs view
@@ -5,7 +5,6 @@ {-# language TupleSections #-} {-# language TypeApplications #-} {-# language TypeOperators #-}-{-# language ViewPatterns #-} {-| Description : Annotations for GraphQL services @@ -23,12 +22,11 @@ , module Mu.Rpc.Annotations ) where -import Control.Applicative (Alternative (..))-import Data.Coerce+import Control.Applicative (Alternative (..)) import Data.Proxy-import qualified Data.Text as T+import qualified Data.Text as T import GHC.TypeLits-import qualified Language.GraphQL.Draft.Syntax as GQL+import qualified Language.GraphQL.AST as GQL import Mu.Rpc.Annotations @@ -54,24 +52,24 @@ -- in the annotation data type. Mostly used -- internally to generate Mu schemas from GraphQL schemas. fromGQLValueConst :: forall f. Alternative f- => GQL.ValueConst -> f (ValueConst Integer String)-fromGQLValueConst (GQL.VCInt n)+ => GQL.ConstValue -> f (ValueConst Integer String)+fromGQLValueConst (GQL.ConstInt n) = pure $ VCInt (fromIntegral n)-fromGQLValueConst (GQL.VCString (coerce -> s))+fromGQLValueConst (GQL.ConstString s) = pure $ VCString $ T.unpack s-fromGQLValueConst (GQL.VCBoolean b)+fromGQLValueConst (GQL.ConstBoolean b) = pure $ VCBoolean b-fromGQLValueConst GQL.VCNull+fromGQLValueConst GQL.ConstNull = pure VCNull-fromGQLValueConst (GQL.VCEnum (coerce -> s))+fromGQLValueConst (GQL.ConstEnum s) = pure $ VCEnum $ T.unpack s-fromGQLValueConst (GQL.VCList (coerce -> xs))+fromGQLValueConst (GQL.ConstList xs) = VCList <$> traverse fromGQLValueConst xs-fromGQLValueConst (GQL.VCObject (coerce -> o))+fromGQLValueConst (GQL.ConstObject o) = VCObject <$> traverse fromGQLField o- where fromGQLField :: GQL.ObjectFieldG GQL.ValueConst+ where fromGQLField :: GQL.ObjectField GQL.ConstValue -> f (String, ValueConst Integer String)- fromGQLField (GQL.ObjectFieldG (coerce -> n) v)+ fromGQLField (GQL.ObjectField n (GQL.Node v _) _) = (T.unpack n,) <$> fromGQLValueConst v fromGQLValueConst _ = empty @@ -82,26 +80,26 @@ class ReflectValueConst (v :: ValueConst nat symbol) where -- | Obtain the GraphQL constant corresponding -- to a type-level constant.- reflectValueConst :: proxy v -> GQL.ValueConst+ reflectValueConst :: proxy v -> GQL.ConstValue instance KnownNat n => ReflectValueConst ('VCInt n) where- reflectValueConst _ = GQL.VCInt $ fromInteger $ natVal (Proxy @n)+ reflectValueConst _ = GQL.ConstInt $ fromInteger $ natVal (Proxy @n) instance KnownSymbol s => ReflectValueConst ('VCString s) where- reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @s)+ reflectValueConst _ = GQL.ConstString $ T.pack $ symbolVal (Proxy @s) instance ReflectValueConst ('VCBoolean 'True) where- reflectValueConst _ = GQL.VCBoolean True+ reflectValueConst _ = GQL.ConstBoolean True instance ReflectValueConst ('VCBoolean 'False) where- reflectValueConst _ = GQL.VCBoolean False+ reflectValueConst _ = GQL.ConstBoolean False instance ReflectValueConst 'VCNull where- reflectValueConst _ = GQL.VCNull+ reflectValueConst _ = GQL.ConstNull instance KnownSymbol e => ReflectValueConst ('VCEnum e) where- reflectValueConst _ = GQL.VCString $ coerce $ T.pack $ symbolVal (Proxy @e)+ reflectValueConst _ = GQL.ConstString $ T.pack $ symbolVal (Proxy @e) instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where- reflectValueConst _ = GQL.VCList $ coerce $ reflectValueConstList (Proxy @xs)+ reflectValueConst _ = GQL.ConstList $ reflectValueConstList (Proxy @xs) instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where- reflectValueConst _ = GQL.VCObject $ coerce $ reflectValueConstObject (Proxy @xs)+ reflectValueConst _ = GQL.ConstObject $ reflectValueConstObject (Proxy @xs) class ReflectValueConstList xs where- reflectValueConstList :: proxy xs -> [GQL.ValueConst]+ reflectValueConstList :: proxy xs -> [GQL.ConstValue] instance ReflectValueConstList '[] where reflectValueConstList _ = [] instance (ReflectValueConst x, ReflectValueConstList xs)@@ -110,11 +108,14 @@ = reflectValueConst (Proxy @x) : reflectValueConstList (Proxy @xs) class ReflectValueConstObject xs where- reflectValueConstObject :: proxy xs -> [GQL.ObjectFieldG GQL.ValueConst]+ reflectValueConstObject :: proxy xs -> [GQL.ObjectField GQL.ConstValue] instance ReflectValueConstObject '[] where reflectValueConstObject _ = [] instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs) => ReflectValueConstObject ( '(a, x) ': xs) where reflectValueConstObject _- = GQL.ObjectFieldG (coerce $ T.pack $ symbolVal (Proxy @a)) (reflectValueConst (Proxy @x))+ = GQL.ObjectField (T.pack $ symbolVal (Proxy @a))+ (GQL.Node (reflectValueConst (Proxy @x)) zl)+ zl : reflectValueConstObject (Proxy @xs)+ where zl = GQL.Location 0 0
src/Mu/GraphQL/Quasi.hs view
@@ -14,19 +14,19 @@ , graphql' ) where -import Control.Monad.IO.Class (liftIO)-import Data.Coerce (coerce)-import qualified Data.HashMap.Strict as HM-import Data.List (foldl')-import Data.Maybe (catMaybes)-import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import Data.UUID (UUID)-import qualified Language.GraphQL.Draft.Syntax as GQL+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (toList)+import qualified Data.HashMap.Strict as HM+import Data.List (foldl')+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.UUID (UUID)+import qualified Language.GraphQL.AST as GQL import Language.Haskell.TH import Mu.GraphQL.Annotations-import Mu.GraphQL.Quasi.LostParser (parseTypeSysDefinition)+import Mu.GraphQL.Quasi.LostParser (parseTypeSysDefinition) import Mu.Rpc import Mu.Schema.Definition @@ -62,38 +62,39 @@ | InputObject | Other -classifySchema :: [GQL.SchemaDefinition] -> SchemaMap+classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap classifySchema = foldl' schemaToMap HM.empty where- schemaToMap :: SchemaMap -> GQL.SchemaDefinition -> SchemaMap- schemaToMap mp (GQL.SchemaDefinition _ ops) = foldl' operationToKeyValue mp ops- operationToKeyValue :: SchemaMap -> GQL.RootOperationTypeDefinition -> SchemaMap- operationToKeyValue mp (GQL.RootOperationTypeDefinition opType (coerce -> name)) = HM.insert name opType mp+ schemaToMap :: SchemaMap -> GQL.TypeSystemDefinition -> SchemaMap+ schemaToMap mp (GQL.SchemaDefinition _ (toList -> ops)) = foldl' operationToKeyValue mp ops+ schemaToMap _ _ = error "this should have been taken care by graphqlToDecls"+ operationToKeyValue :: SchemaMap -> GQL.OperationTypeDefinition -> SchemaMap+ operationToKeyValue mp (GQL.OperationTypeDefinition opType name) = HM.insert name opType mp classify :: [GQL.TypeDefinition] -> TypeMap classify = HM.fromList . (typeToKeyValue <$>) where typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType)- typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ name _))- = (coerce name, Scalar)- typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition _ name _ _ _))- = (coerce name, Object)- typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition _ name _ _))- = (coerce name, Other)- typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition _ name _ _))- = (coerce name, Other)- typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition _ name _ _))- = (coerce name, Enum)- typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition _ name _ _))- = (coerce name, InputObject)+ typeToKeyValue (GQL.ScalarTypeDefinition _ name _)+ = (name, Scalar)+ typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _)+ = (name, Object)+ typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _)+ = (name, Other)+ typeToKeyValue (GQL.UnionTypeDefinition _ name _ _)+ = (name, Other)+ typeToKeyValue (GQL.EnumTypeDefinition _ name _ _)+ = (name, Enum)+ typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _)+ = (name, InputObject) -- | Constructs the GraphQL tree splitting between Schemas and Services. graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec] graphqlToDecls schemaName serviceName allTypes = do let schemaName' = mkName schemaName serviceName' = mkName serviceName- types = [t | GQL.TypeSystemDefinitionType t <- allTypes]- schTypes = [t | GQL.TypeSystemDefinitionSchema t <- allTypes]+ types = [t | GQL.TypeDefinition t <- allTypes]+ schTypes = [t | t@GQL.SchemaDefinition {} <- allTypes] typeMap = classify types schMap = classifySchema schTypes rs <- traverse (typeToDec schemaName' typeMap schMap) types@@ -114,108 +115,100 @@ -- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'. typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result-typeToDec _ _ _ (GQL.TypeDefinitionInterface _)+typeToDec _ _ _ GQL.InterfaceTypeDefinition {} = fail "interface types are not supported"-typeToDec _ _ _ (GQL.TypeDefinitionUnion _)+typeToDec _ _ _ GQL.UnionTypeDefinition {} = fail "union types are not supported"-typeToDec schemaName tm _ (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ s _)) =+typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = GQLScalar <$ gqlTypeToType s tm schemaName-typeToDec schemaName tm sm (GQL.TypeDefinitionObject objs) = objToDec objs+typeToDec schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do+ (fieldInfos, defaults) <- unzip <$> traverse (gqlFieldToType nm) flds+ GQLService <$> [t| 'Service $(textToStrLit nm)+ $(pure $ typesToList fieldInfos) |]+ <*> pure ((nm,) <$> concat defaults) where- objToDec :: GQL.ObjectTypeDefinition -> Q Result- objToDec (GQL.ObjectTypeDefinition _ (coerce -> nm) _ _ flds) = do- (fieldInfos, defaults) <- unzip <$> traverse (gqlFieldToType nm) flds- GQLService <$> [t| 'Service $(textToStrLit nm)- $(pure $ typesToList fieldInfos) |]- <*> pure ((nm,) <$> concat defaults) gqlFieldToType :: T.Text -> GQL.FieldDefinition -> Q (Type, [(T.Text, (T.Text, Type))])- gqlFieldToType sn (GQL.FieldDefinition _ (coerce -> fnm) args ftyp _) = do+ gqlFieldToType sn (GQL.FieldDefinition _ fnm (GQL.ArgumentsDefinition args) ftyp _) = do (argInfos, defaults) <- unzip <$> traverse argToType args (,) <$> [t| 'Method $(textToStrLit fnm) $(pure $ typesToList argInfos) $(returnType sn ftyp) |] <*> pure ((fnm,) <$> catMaybes defaults)- returnType :: T.Text -> GQL.GType -> Q Type+ returnType :: T.Text -> GQL.Type -> Q Type returnType serviceName typ = case HM.lookup serviceName sm of- Just GQL.OperationTypeSubscription -> [t|'RetStream $(retToType typ)|]- _ -> [t|'RetSingle $(retToType typ)|]+ Just GQL.Subscription -> [t|'RetStream $(retToType typ)|]+ _ -> [t|'RetSingle $(retToType typ)|] argToType :: GQL.InputValueDefinition -> Q (Type, Maybe (T.Text, Type))- argToType (GQL.InputValueDefinition _ (coerce -> aname) atype Nothing) =+ argToType (GQL.InputValueDefinition _ aname atype Nothing _) = (, Nothing) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |]- argToType (GQL.InputValueDefinition _ (coerce -> aname) atype (Just defs)) =+ argToType (GQL.InputValueDefinition _ aname atype (Just (GQL.Node defs _)) _) = (,) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |] <*> (Just . (aname,) <$> [t| 'DefaultValue $( defToVConst defs ) |])- defToVConst :: GQL.DefaultValue -> Q Type- defToVConst (GQL.VCBoolean _) = [t| 'VCBoolean|]- defToVConst GQL.VCNull = [t| 'VCNull |]- defToVConst (GQL.VCInt _) = [t| 'VCInt |]- defToVConst (GQL.VCFloat _)+ defToVConst :: GQL.ConstValue -> Q Type+ defToVConst (GQL.ConstBoolean _) = [t| 'VCBoolean|]+ defToVConst GQL.ConstNull = [t| 'VCNull |]+ defToVConst (GQL.ConstInt _) = [t| 'VCInt |]+ defToVConst (GQL.ConstFloat _) = fail "floats as default arguments are not supported"- defToVConst (GQL.VCString (coerce -> s))+ defToVConst (GQL.ConstString s) = [t| 'VCString $(textToStrLit s) |]- defToVConst (GQL.VCEnum (coerce -> e))+ defToVConst (GQL.ConstEnum e) = [t| 'VCEnum $(textToStrLit e) |]- defToVConst (GQL.VCList (GQL.ListValueG xs))+ defToVConst (GQL.ConstList xs) = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |]- defToVConst (GQL.VCObject (GQL.ObjectValueG obj))+ defToVConst (GQL.ConstObject obj) = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]- fromGQLField :: GQL.ObjectFieldG GQL.ValueConst -> Q Type- fromGQLField (GQL.ObjectFieldG (coerce -> n) v) = [t| ($(textToStrLit n), $(defToVConst v)) |]- retToType :: GQL.GType -> Q Type- retToType (GQL.TypeNamed (coerce -> False) (coerce -> a)) =+ fromGQLField :: GQL.ObjectField GQL.ConstValue -> Q Type+ fromGQLField (GQL.ObjectField n (GQL.Node v _) _) = [t| ($(textToStrLit n), $(defToVConst v)) |]+ retToType :: GQL.Type -> Q Type+ retToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = [t| $(gqlTypeToType a tm schemaName) |]- retToType (GQL.TypeNamed (coerce -> True) (coerce -> a)) =- [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |]- retToType (GQL.TypeList (coerce -> False) (coerce -> a)) =+ retToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) = [t| 'ListRef $(retToType a) |]- retToType (GQL.TypeList (coerce -> True) (coerce -> a)) =+ retToType (GQL.TypeNamed a) =+ [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |]+ retToType (GQL.TypeList a) = [t| 'OptionalRef ('ListRef $(retToType a)) |]- retToType _ = fail "this should not happen, please, file an issue"-typeToDec _ _ _ (GQL.TypeDefinitionEnum enums) = enumToDecl enums+typeToDec _ _ _ (GQL.EnumTypeDefinition _ name _ symbols) =+ GQLSchema <$> [t|'DEnum $(textToStrLit name)+ $(typesToList <$> traverse gqlChoiceToType symbols)|] where- enumToDecl :: GQL.EnumTypeDefinition -> Q Result- enumToDecl (GQL.EnumTypeDefinition _ (coerce -> name) _ symbols) =- GQLSchema <$> [t|'DEnum $(textToStrLit name)- $(typesToList <$> traverse gqlChoiceToType symbols)|] gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type- gqlChoiceToType (GQL.EnumValueDefinition _ (coerce -> c) _) =+ gqlChoiceToType (GQL.EnumValueDefinition _ c _) = [t|'ChoiceDef $(textToStrLit c)|]-typeToDec _ _ _ (GQL.TypeDefinitionInputObject inpts) = inputObjToDec inpts+typeToDec _ _ _ (GQL.InputObjectTypeDefinition _ name _ fields) =+ GQLSchema <$> [t|'DRecord $(textToStrLit name)+ $(typesToList <$> traverse gqlFieldToType fields)|] where- inputObjToDec :: GQL.InputObjectTypeDefinition -> Q Result- inputObjToDec (GQL.InputObjectTypeDefinition _ (coerce -> name) _ fields) =- GQLSchema <$> [t|'DRecord $(textToStrLit name)- $(typesToList <$> traverse gqlFieldToType fields)|] gqlFieldToType :: GQL.InputValueDefinition -> Q Type- gqlFieldToType (GQL.InputValueDefinition _ (coerce -> fname) ftype _) =+ gqlFieldToType (GQL.InputValueDefinition _ fname ftype _ _) = [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|]- ginputTypeToType :: GQL.GType -> Q Type- ginputTypeToType (GQL.TypeNamed (coerce -> False) (coerce -> a)) =+ ginputTypeToType :: GQL.Type -> Q Type+ ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = [t| $(typeToPrimType a) |]- ginputTypeToType (GQL.TypeNamed (coerce -> True) (coerce -> a)) =- [t| 'OptionalRef $(typeToPrimType a) |]- ginputTypeToType (GQL.TypeList (coerce -> False) (coerce -> a)) =+ ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) = [t| 'ListRef $(ginputTypeToType a) |]- ginputTypeToType (GQL.TypeList (coerce -> True) (coerce -> a)) =+ ginputTypeToType (GQL.TypeNamed a) =+ [t| 'OptionalRef $(typeToPrimType a) |]+ ginputTypeToType (GQL.TypeList a) = [t| 'OptionalRef ('ListRef $(ginputTypeToType a)) |]- ginputTypeToType _ = fail "this should not happen, please, file an issue" typeToPrimType :: GQL.Name -> Q Type- typeToPrimType (GQL.unName -> "Int") = [t|'TPrimitive Integer|]- typeToPrimType (GQL.unName -> "Float") = [t|'TPrimitive Double|]- typeToPrimType (GQL.unName -> "String") = [t|'TPrimitive T.Text|]- typeToPrimType (GQL.unName -> "Boolean") = [t|'TPrimitive Bool|]- typeToPrimType (GQL.unName -> "ID") = [t|'TPrimitive UUID|]- typeToPrimType (coerce -> name) = [t|'TSchematic $(textToStrLit name)|]+ typeToPrimType "Int" = [t|'TPrimitive Integer|]+ typeToPrimType "Float" = [t|'TPrimitive Double|]+ typeToPrimType "String" = [t|'TPrimitive T.Text|]+ typeToPrimType "Boolean" = [t|'TPrimitive Bool|]+ typeToPrimType "ID" = [t|'TPrimitive UUID|]+ typeToPrimType nm = [t|'TSchematic $(textToStrLit nm)|] gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type-gqlTypeToType (GQL.unName -> "Int") _ _ = [t|'PrimitiveRef Integer|]-gqlTypeToType (GQL.unName -> "Float") _ _ = [t|'PrimitiveRef Double|]-gqlTypeToType (GQL.unName -> "String") _ _ = [t|'PrimitiveRef T.Text|]-gqlTypeToType (GQL.unName -> "Boolean") _ _ = [t|'PrimitiveRef Bool|]-gqlTypeToType (GQL.unName -> "ID") _ _ = [t|'PrimitiveRef UUID|]-gqlTypeToType (coerce -> name) tm schemaName =+gqlTypeToType "Int" _ _ = [t|'PrimitiveRef Integer|]+gqlTypeToType "Float" _ _ = [t|'PrimitiveRef Double|]+gqlTypeToType "String" _ _ = [t|'PrimitiveRef T.Text|]+gqlTypeToType "Boolean" _ _ = [t|'PrimitiveRef Bool|]+gqlTypeToType "ID" _ _ = [t|'PrimitiveRef UUID|]+gqlTypeToType name tm schemaName = let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] in case HM.lookup name tm of Just Enum -> schemaRef
src/Mu/GraphQL/Quasi/LostParser.hs view
@@ -1,38 +1,28 @@+{-# language OverloadedStrings #-}+{-# language ViewPatterns #-} module Mu.GraphQL.Quasi.LostParser (- -- * The Lost 'Parser'™️- parseTypeSysDefinition+ parseTypeSysDefinition, parseDoc ) where -import Control.Applicative ((<|>))-import Data.Attoparsec.Text (Parser, many1)-import qualified Data.Text as T-import Language.GraphQL.Draft.Parser (nameParser, runParser, schemaDocument)-import qualified Language.GraphQL.Draft.Syntax as GQL-import Text.Parser.Token (braces, symbol, whiteSpace)--schemaDefinition :: Parser GQL.SchemaDefinition-schemaDefinition = symbol "schema" *> braces (- GQL.SchemaDefinition- <$> pure Nothing -- ignore [Directive]- <*> many1 rootOperationParser- )--rootOperationParser :: Parser GQL.RootOperationTypeDefinition-rootOperationParser =- GQL.RootOperationTypeDefinition- <$> (operationTypeParser <* symbol ":")- <*> (GQL.NamedType <$> nameParser)--operationTypeParser :: Parser GQL.OperationType-operationTypeParser =- GQL.OperationTypeQuery <$ symbol "query"- <|> GQL.OperationTypeMutation <$ symbol "mutation"- <|> GQL.OperationTypeSubscription <$ symbol "subscription"+import Data.Foldable (toList)+import qualified Data.Text as T+import Language.GraphQL.AST (document)+import qualified Language.GraphQL.AST as GQL+import Text.Megaparsec (runParser) -typeSystemDefinition :: Parser [GQL.TypeSystemDefinition]-typeSystemDefinition = whiteSpace *> (concat <$> many1 (- (\(GQL.SchemaDocument d) -> GQL.TypeSystemDefinitionType <$> d) <$> schemaDocument- <|> (: []) . GQL.TypeSystemDefinitionSchema <$> schemaDefinition ))+parseDoc :: T.Text -> Either T.Text [GQL.Definition]+parseDoc s =+ case runParser document "<doc>" s of+ Right d -> Right (toList d)+ Left e -> Left (T.pack $ show e) parseTypeSysDefinition :: T.Text -> Either T.Text [GQL.TypeSystemDefinition]-parseTypeSysDefinition = runParser typeSystemDefinition+parseTypeSysDefinition s =+ case runParser document "<doc>" s of+ Right (toList -> d)+ -> let tds = [td | GQL.TypeSystemDefinition td _ <- d]+ in if length d == length tds+ then Right tds+ else Left "unexpected query or type system extension"+ Left e+ -> Left (T.pack $ show e)
src/Mu/GraphQL/Query/Definition.hs view
@@ -8,7 +8,7 @@ import Data.SOP.NP import Data.SOP.NS import Data.Text-import qualified Language.GraphQL.Draft.Syntax as GQL+import qualified Language.GraphQL.AST as GQL import Mu.Rpc import Mu.Schema @@ -44,12 +44,12 @@ -- introspection fields SchemaQuery :: Maybe Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> OneMethodQuery p ('Service nm ms) TypeQuery :: Maybe Text -> Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> OneMethodQuery p ('Service nm ms) data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm))
src/Mu/GraphQL/Query/Parse.hs view
@@ -15,52 +15,51 @@ module Mu.GraphQL.Query.Parse where import Control.Monad.Except-import qualified Data.Aeson as A-import Data.Coerce (coerce)-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM-import Data.Int (Int32)-import Data.List (find)+import qualified Data.Aeson as A+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import Data.Int (Int32)+import Data.List (find) import Data.Maybe import Data.Proxy-import Data.Scientific (Scientific, floatingOrInteger, toRealFloat) import Data.SOP.NS-import qualified Data.Text as T+import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)+import qualified Data.Text as T import GHC.TypeLits-import qualified Language.GraphQL.Draft.Syntax as GQL+import qualified Language.GraphQL.AST as GQL import Mu.GraphQL.Annotations import Mu.GraphQL.Query.Definition import Mu.Rpc import Mu.Schema -type VariableMapC = HM.HashMap T.Text GQL.ValueConst+type VariableMapC = HM.HashMap T.Text GQL.ConstValue type VariableMap = HM.HashMap T.Text GQL.Value type FragmentMap = HM.HashMap T.Text GQL.FragmentDefinition -instance A.FromJSON GQL.ValueConst where- parseJSON A.Null = pure GQL.VCNull- parseJSON (A.Bool b) = pure $ GQL.VCBoolean b- parseJSON (A.String s) = pure $ GQL.VCString $ coerce s- parseJSON (A.Number n)- | (Right i :: Either Double Integer) <- floatingOrInteger n- = pure $ GQL.VCInt i- | otherwise = pure $ GQL.VCFloat n- parseJSON (A.Array xs) = GQL.VCList . GQL.ListValueG . F.toList <$> traverse A.parseJSON xs- parseJSON (A.Object o) = GQL.VCObject . GQL.ObjectValueG . fmap toObjFld . HM.toList <$> traverse A.parseJSON o+instance A.FromJSON GQL.ConstValue where+ parseJSON A.Null = pure GQL.ConstNull+ parseJSON (A.Bool b) = pure $ GQL.ConstBoolean b+ parseJSON (A.String s) = pure $ GQL.ConstString s+ parseJSON (A.Number n) = case floatingOrInteger n :: Either Double Int32 of+ Right i -> pure $ GQL.ConstInt i+ Left m -> pure $ GQL.ConstFloat m+ parseJSON (A.Array xs) = GQL.ConstList . F.toList <$> traverse A.parseJSON xs+ parseJSON (A.Object o) = GQL.ConstObject . fmap toObjFld . HM.toList <$> traverse A.parseJSON o where- toObjFld :: (T.Text, GQL.ValueConst) -> GQL.ObjectFieldG GQL.ValueConst- toObjFld (k, v) = GQL.ObjectFieldG (coerce k) v+ toObjFld :: (T.Text, GQL.ConstValue) -> GQL.ObjectField GQL.ConstValue+ toObjFld (k, v) = GQL.ObjectField k (GQL.Node v zl) zl+ zl = GQL.Location 0 0 parseDoc :: forall qr mut sub p f. ( MonadError T.Text f, ParseTypedDoc p qr mut sub ) => Maybe T.Text -> VariableMapC ->- GQL.ExecutableDocument ->+ [GQL.Definition] -> f (Document p qr mut sub) -- If there's no operation name, there must be only one query-parseDoc Nothing vmap (GQL.ExecutableDocument defns)- = case GQL.partitionExDefs defns of+parseDoc Nothing vmap defns+ = case partitionExDefs defns of ([unnamed], [], frs) -> parseTypedDocQuery HM.empty (fragmentsToMap frs) unnamed ([], [named], frs)@@ -70,52 +69,64 @@ ([], _, _) -> throwError "more than one named operation but no 'operationName' given" (_, _, _) -> throwError "both named and unnamed queries, but no 'operationName' given" -- If there's an operation name, look in the named queries-parseDoc (Just operationName) vmap (GQL.ExecutableDocument defns)- = case GQL.partitionExDefs defns of- (_, named, frs) -> maybe notFound (parseTypedDoc vmap (fragmentsToMap frs)) (find isThis named)- where isThis (GQL._todName -> Just nm)- = GQL.unName nm == operationName+parseDoc (Just operationName) vmap defns+ = case partitionExDefs defns of+ (_, named, frs) -> maybe notFound+ (parseTypedDoc vmap (fragmentsToMap frs))+ (find isThis named)+ where isThis (GQL.OperationDefinition _ (Just nm) _ _ _ _)+ = nm == operationName isThis _ = False notFound :: MonadError T.Text f => f a notFound = throwError $ "operation '" <> operationName <> "' was not found" -fragmentsToMap :: [GQL.FragmentDefinition] -> FragmentMap-fragmentsToMap = HM.fromList . map fragmentToThingy- where fragmentToThingy :: GQL.FragmentDefinition -> (T.Text, GQL.FragmentDefinition)- fragmentToThingy f = (GQL.unName $ GQL._fdName f, f)+partitionExDefs+ :: [GQL.Definition]+ -> ([[GQL.Selection]], [GQL.OperationDefinition], [GQL.FragmentDefinition])+partitionExDefs defs+ = ( [ F.toList ss+ | GQL.ExecutableDefinition (GQL.DefinitionOperation (GQL.SelectionSet ss _)) <- defs ]+ , [ od+ | GQL.ExecutableDefinition (GQL.DefinitionOperation od@GQL.OperationDefinition {}) <- defs ]+ , [ fr+ | GQL.ExecutableDefinition (GQL.DefinitionFragment fr) <- defs ]) parseTypedDoc :: (MonadError T.Text f, ParseTypedDoc p qr mut sub) => VariableMapC -> FragmentMap ->- GQL.TypedOperationDefinition ->+ GQL.OperationDefinition -> f (Document p qr mut sub)-parseTypedDoc vmap frmap tod- = let defVmap = parseVariableMap (GQL._todVariableDefinitions tod)+parseTypedDoc _ _ GQL.SelectionSet {}+ = error "this should have been handled in parseDoc"+parseTypedDoc vmap frmap (GQL.OperationDefinition typ _ vdefs _ (F.toList -> ss) _)+ = let defVmap = parseVariableMap vdefs finalVmap = constToValue <$> HM.union vmap defVmap -- first one takes precedence- in case GQL._todType tod of- GQL.OperationTypeQuery- -> parseTypedDocQuery finalVmap frmap (GQL._todSelectionSet tod)- GQL.OperationTypeMutation- -> parseTypedDocMutation finalVmap frmap (GQL._todSelectionSet tod)- GQL.OperationTypeSubscription- -> parseTypedDocSubscription finalVmap frmap (GQL._todSelectionSet tod)+ in case typ of+ GQL.Query -> parseTypedDocQuery finalVmap frmap ss+ GQL.Mutation -> parseTypedDocMutation finalVmap frmap ss+ GQL.Subscription -> parseTypedDocSubscription finalVmap frmap ss +fragmentsToMap :: [GQL.FragmentDefinition] -> FragmentMap+fragmentsToMap = HM.fromList . map fragmentToThingy+ where fragmentToThingy :: GQL.FragmentDefinition -> (T.Text, GQL.FragmentDefinition)+ fragmentToThingy f = (fdName f, f)+ class ParseTypedDoc (p :: Package') (qr :: Maybe Symbol) (mut :: Maybe Symbol) (sub :: Maybe Symbol) where parseTypedDocQuery :: MonadError T.Text f => VariableMap -> FragmentMap ->- GQL.SelectionSet ->+ [GQL.Selection] -> f (Document p qr mut sub) parseTypedDocMutation :: MonadError T.Text f => VariableMap -> FragmentMap ->- GQL.SelectionSet ->+ [GQL.Selection] -> f (Document p qr mut sub) parseTypedDocSubscription :: MonadError T.Text f => VariableMap -> FragmentMap ->- GQL.SelectionSet ->+ [GQL.Selection] -> f (Document p qr mut sub) instance@@ -235,22 +246,24 @@ parseVariableMap :: [GQL.VariableDefinition] -> VariableMapC parseVariableMap vmap- = HM.fromList [(GQL.unName (GQL.unVariable v), def)- | GQL.VariableDefinition v _ (Just def) <- vmap]+ = HM.fromList [(v, def)+ | GQL.VariableDefinition v _ (Just (GQL.Node def _)) _ <- vmap] -constToValue :: GQL.ValueConst -> GQL.Value-constToValue (GQL.VCInt n) = GQL.VInt n-constToValue (GQL.VCFloat n) = GQL.VFloat n-constToValue (GQL.VCString n) = GQL.VString n-constToValue (GQL.VCBoolean n) = GQL.VBoolean n-constToValue GQL.VCNull = GQL.VNull-constToValue (GQL.VCEnum n) = GQL.VEnum n-constToValue (GQL.VCList (GQL.ListValueG n))- = GQL.VList $ GQL.ListValueG $ constToValue <$> n-constToValue (GQL.VCObject (GQL.ObjectValueG n))- = GQL.VObject $ GQL.ObjectValueG- [ GQL.ObjectFieldG a (constToValue v) | GQL.ObjectFieldG a v <- n ]+constToValue :: GQL.ConstValue -> GQL.Value+constToValue (GQL.ConstInt n) = GQL.Int n+constToValue (GQL.ConstFloat n) = GQL.Float n+constToValue (GQL.ConstString n) = GQL.String n+constToValue (GQL.ConstBoolean n) = GQL.Boolean n+constToValue GQL.ConstNull = GQL.Null+constToValue (GQL.ConstEnum n) = GQL.Enum n+constToValue (GQL.ConstList n)+ = GQL.List $ constToValue <$> n+constToValue (GQL.ConstObject n)+ = GQL.Object+ [ GQL.ObjectField a (GQL.Node (constToValue v) m) l+ | GQL.ObjectField a (GQL.Node v m) l <- n ] + parseQuery :: forall (p :: Package') (s :: Symbol) pname ss methods f. ( MonadError T.Text f, p ~ 'Package pname ss,@@ -259,54 +272,53 @@ ) => Proxy p -> Proxy s ->- VariableMap -> FragmentMap -> GQL.SelectionSet ->+ VariableMap -> FragmentMap -> [GQL.Selection] -> f (ServiceQuery p (LookupService ss s)) parseQuery _ _ _ _ [] = pure []-parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)+parseQuery pp ps vmap frmap (GQL.FieldSelection fld : ss) = (++) <$> (maybeToList <$> fieldToMethod fld) <*> parseQuery pp ps vmap frmap ss where fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))- fieldToMethod f@(GQL.Field alias name args dirs sels)+ fieldToMethod f@(GQL.Field alias name args dirs sels _) | any (shouldSkip vmap) dirs = pure Nothing- | GQL.unName name == "__typename"+ | name == "__typename" = case (args, sels) of- ([], []) -> pure $ Just $ TypeNameQuery $ GQL.unName . GQL.unAlias <$> alias+ ([], []) -> pure $ Just $ TypeNameQuery alias _ -> throwError "__typename does not admit arguments nor selection of subfields"- | GQL.unName name == "__schema"+ | name == "__schema" = case args of- [] -> Just . SchemaQuery (GQL.unName . GQL.unAlias <$> alias) <$> unFragment frmap sels+ [] -> Just . SchemaQuery alias <$> unFragment frmap (F.toList sels) _ -> throwError "__schema does not admit selection of subfields"- | GQL.unName name == "__type"- = let alias' = GQL.unName . GQL.unAlias <$> alias- getString (GQL.VString s) = Just $ coerce s- getString (GQL.VVariable v) = HM.lookup (coerce v) vmap >>= getString- getString _ = Nothing+ | name == "__type"+ = let getString (GQL.String s) = Just s+ getString (GQL.Variable v) = HM.lookup v vmap >>= getString+ getString _ = Nothing in case args of- [GQL.Argument _ val]+ [GQL.Argument _ (GQL.Node val _) _] -> case getString val of- Just s -> Just . TypeQuery alias' s <$> unFragment frmap sels+ Just s -> Just . TypeQuery alias s <$> unFragment frmap sels _ -> throwError "__type requires a string argument" _ -> throwError "__type requires one single argument" | otherwise- = Just . OneMethodQuery (GQL.unName . GQL.unAlias <$> alias)+ = Just . OneMethodQuery alias <$> selectMethod (Proxy @('Service s methods)) (T.pack $ nameVal (Proxy @s)) vmap frmap f-parseQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss)- | Just fr <- HM.lookup (GQL.unName nm) frmap- = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr)- then (++) <$> parseQuery pp ps vmap frmap (GQL._fdSelectionSet fr)+parseQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)+ | Just fr <- HM.lookup nm frmap+ = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)+ then (++) <$> parseQuery pp ps vmap frmap (fdSelectionSet fr) <*> parseQuery pp ps vmap frmap ss else parseQuery pp ps vmap frmap ss | otherwise -- the fragment definition was not found- = throwError $ "fragment '" <> GQL.unName nm <> "' was not found"+ = throwError $ "fragment '" <> nm <> "' was not found" parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported = throwError "inline fragments are not (yet) supported" shouldSkip :: VariableMap -> GQL.Directive -> Bool-shouldSkip vmap (GQL.Directive (GQL.unName -> nm) [GQL.Argument (GQL.unName -> ifn) v])+shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _) | nm == "skip", ifn == "if" = case valueParser' @'[] @('TPrimitive Bool) vmap "" v of Right (FPrimitive b) -> b@@ -318,16 +330,17 @@ shouldSkip _ _ = False unFragment :: MonadError T.Text f- => FragmentMap -> GQL.SelectionSet -> f GQL.SelectionSet+ => FragmentMap -> [GQL.Selection] -> f [GQL.Selection] unFragment _ [] = pure []-unFragment frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm _) : ss)- | Just fr <- HM.lookup (GQL.unName nm) frmap- = (++) <$> unFragment frmap (GQL._fdSelectionSet fr)+unFragment frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm _ _) : ss)+ | Just fr <- HM.lookup nm frmap+ = (++) <$> unFragment frmap (fdSelectionSet fr) <*> unFragment frmap ss | otherwise -- the fragment definition was not found- = throwError $ "fragment '" <> GQL.unName nm <> "' was not found"-unFragment frmap (GQL.SelectionField (GQL.Field al nm args dir innerss) : ss)- = (:) <$> (GQL.SelectionField . GQL.Field al nm args dir <$> unFragment frmap innerss)+ = throwError $ "fragment '" <> nm <> "' was not found"+unFragment frmap (GQL.FieldSelection (GQL.Field al nm args dir innerss loc) : ss)+ = (:) <$> (GQL.FieldSelection . flip (GQL.Field al nm args dir) loc+ <$> unFragment frmap innerss) <*> unFragment frmap ss unFragment _ _ = throwError "inline fragments are not (yet) supported"@@ -346,7 +359,7 @@ f (NS (ChosenMethodQuery p) ms) instance ParseMethod p s '[] where- selectMethod _ tyName _ _ (GQL.unName . GQL._fName -> wanted)+ selectMethod _ tyName _ _ (fName -> wanted) = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" instance ( KnownSymbol mname, ParseMethod p s ms@@ -354,7 +367,7 @@ , ParseDifferentReturn p r) => ParseMethod p s ('Method mname args r ': ms) where- selectMethod s tyName vmap frmap f@(GQL.Field _ (GQL.unName -> wanted) args _ sels)+ selectMethod s tyName vmap frmap f@(GQL.Field _ wanted args _ sels _) | wanted == mname = Z <$> (ChosenMethodQuery f <$> parseArgs (Proxy @s) (Proxy @('Method mname args r)) vmap args@@ -376,13 +389,13 @@ -- one single argument without name instance ParseArg p a => ParseArgs p s m '[ 'ArgSingle 'Nothing a ] where- parseArgs _ _ vmap [GQL.Argument _ x]+ parseArgs _ _ vmap [GQL.Argument _ (GQL.Node x _) _] = (\v -> ArgumentValue v :* Nil) <$> parseArg' vmap "arg" x parseArgs _ _ _ _ = throwError "this field receives one single argument" instance ParseArg p a => ParseArgs p s m '[ 'ArgStream 'Nothing a ] where- parseArgs _ _ vmap [GQL.Argument _ x]+ parseArgs _ _ vmap [GQL.Argument _ (GQL.Node x _) _] = (\v -> ArgumentStream v :* Nil) <$> parseArg' vmap "arg" x parseArgs _ _ _ _ = throwError "this field receives one single argument"@@ -394,14 +407,13 @@ => ParseArgs p s m ('ArgSingle ('Just aname) a ': as) where parseArgs ps pm vmap args = let aname = T.pack $ nameVal (Proxy @aname)- in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of- Just (GQL.Argument _ x)+ in case find ((== nameVal (Proxy @aname)) . T.unpack . argName) args of+ Just (GQL.Argument _ (GQL.Node x _) _) -> (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname (Just x)) <*> parseArgs ps pm vmap args Nothing -> do let x = findDefaultArgValue (Proxy @ann)- (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname- (constToValue <$> x))+ (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname (constToValue <$> x)) <*> parseArgs ps pm vmap args instance ( KnownName aname, ParseArg p a, ParseArgs p s m as , s ~ 'Service snm sms, m ~ 'Method mnm margs mr@@ -410,19 +422,18 @@ => ParseArgs p s m ('ArgStream ('Just aname) a ': as) where parseArgs ps pm vmap args = let aname = T.pack $ nameVal (Proxy @aname)- in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of- Just (GQL.Argument _ x)+ in case find ((== nameVal (Proxy @aname)) . T.unpack . argName) args of+ Just (GQL.Argument _ (GQL.Node x _) _) -> (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname (Just x)) <*> parseArgs ps pm vmap args Nothing -> do let x = findDefaultArgValue (Proxy @ann)- (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname- (constToValue <$> x))+ (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname (constToValue <$> x)) <*> parseArgs ps pm vmap args class FindDefaultArgValue (vs :: Maybe DefaultValue) where findDefaultArgValue :: Proxy vs- -> Maybe GQL.ValueConst+ -> Maybe GQL.ConstValue instance FindDefaultArgValue 'Nothing where findDefaultArgValue _ = Nothing instance ReflectValueConst v@@ -462,7 +473,7 @@ -> T.Text -> GQL.Value -> f (ArgumentValue' p a)-parseArg' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x))+parseArg' vmap aname (GQL.Variable x) = case HM.lookup x vmap of Nothing -> throwError $ "variable '" <> x <> "' was not found" Just v -> parseArg vmap aname v@@ -476,47 +487,47 @@ -> f (ArgumentValue' p a) instance (ParseArg p r) => ParseArg p ('ListRef r) where- parseArg vmap aname (GQL.VList (GQL.ListValueG xs))+ parseArg vmap aname (GQL.List xs) = ArgList <$> traverse (parseArg' vmap aname) xs parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Bool) where- parseArg _ _ (GQL.VBoolean b)+ parseArg _ _ (GQL.Boolean b) = pure $ ArgPrimitive b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Int32) where- parseArg _ _ (GQL.VInt b)+ parseArg _ _ (GQL.Int b) = pure $ ArgPrimitive $ fromIntegral b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Integer) where- parseArg _ _ (GQL.VInt b)- = pure $ ArgPrimitive b+ parseArg _ _ (GQL.Int b)+ = pure $ ArgPrimitive (toInteger b) parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Scientific) where- parseArg _ _ (GQL.VFloat b)- = pure $ ArgPrimitive b+ parseArg _ _ (GQL.Float b)+ = pure $ ArgPrimitive $ fromFloatDigits b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Double) where- parseArg _ _ (GQL.VFloat b)- = pure $ ArgPrimitive $ toRealFloat b+ parseArg _ _ (GQL.Float b)+ = pure $ ArgPrimitive b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef T.Text) where- parseArg _ _ (GQL.VString (GQL.StringValue b))+ parseArg _ _ (GQL.String b) = pure $ ArgPrimitive b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef String) where- parseArg _ _ (GQL.VString (GQL.StringValue b))+ parseArg _ _ (GQL.String b) = pure $ ArgPrimitive $ T.unpack b parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef ()) where- parseArg _ _ GQL.VNull = pure $ ArgPrimitive ()+ parseArg _ _ GQL.Null = pure $ ArgPrimitive () parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance (ObjectOrEnumParser sch (sch :/: sty))@@ -529,7 +540,7 @@ -> T.Text -> GQL.Value -> f (Term sch t)-parseObjectOrEnum' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x))+parseObjectOrEnum' vmap aname (GQL.Variable x) = case HM.lookup x vmap of Nothing -> throwError $ "variable '" <> x <> "' was not found" Just v -> parseObjectOrEnum vmap aname v@@ -545,13 +556,13 @@ instance (ObjectParser sch args, KnownName name) => ObjectOrEnumParser sch ('DRecord name args) where- parseObjectOrEnum vmap _ (GQL.VObject (GQL.ObjectValueG vs))+ parseObjectOrEnum vmap _ (GQL.Object vs) = TRecord <$> objectParser vmap (T.pack $ nameVal (Proxy @name)) vs parseObjectOrEnum _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance (EnumParser choices, KnownName name) => ObjectOrEnumParser sch ('DEnum name choices) where- parseObjectOrEnum _ _ (GQL.VEnum (GQL.EnumValue nm))+ parseObjectOrEnum _ _ (GQL.Enum nm) = TEnum <$> enumParser (T.pack $ nameVal (Proxy @name)) nm parseObjectOrEnum _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type"@@ -560,7 +571,7 @@ objectParser :: MonadError T.Text f => VariableMap -> T.Text- -> [GQL.ObjectFieldG GQL.Value]+ -> [GQL.ObjectField GQL.Value] -> f (NP (Field sch) args) instance ObjectParser sch '[] where@@ -571,8 +582,8 @@ where objectParser vmap tyName args = let wanted = T.pack $ nameVal (Proxy @nm)- in case find ((== wanted) . GQL.unName . GQL._ofName) args of- Just (GQL.ObjectFieldG _ v)+ in case find ((== wanted) . GQL.name) args of+ Just (GQL.ObjectField _ (GQL.Node v _) _) -> (:*) <$> (Field <$> valueParser' vmap wanted v) <*> objectParser vmap tyName args Nothing -> throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" @@ -582,13 +593,13 @@ -> f (NS Proxy choices) instance EnumParser '[] where- enumParser tyName (GQL.unName -> wanted)+ enumParser tyName wanted = throwError $ "value '" <> wanted <> "' was not found on enum '" <> tyName <> "'" instance (KnownName name, EnumParser choices) => EnumParser ('ChoiceDef name ': choices) where- enumParser tyName w@(GQL.unName -> wanted)+ enumParser tyName wanted | wanted == mname = pure (Z Proxy)- | otherwise = S <$> enumParser tyName w+ | otherwise = S <$> enumParser tyName wanted where mname = T.pack $ nameVal (Proxy @name) @@ -597,7 +608,7 @@ -> T.Text -> GQL.Value -> f (FieldValue sch v)-valueParser' vmap aname (GQL.VVariable (GQL.unName . GQL.unVariable -> x))+valueParser' vmap aname (GQL.Variable x) = case HM.lookup x vmap of Nothing -> throwError $ "variable '" <> x <> "' was not found" Just v -> valueParser vmap aname v@@ -611,46 +622,46 @@ -> f (FieldValue sch v) instance ValueParser sch 'TNull where- valueParser _ _ GQL.VNull = pure FNull+ valueParser _ _ GQL.Null = pure FNull valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive Bool) where- valueParser _ _ (GQL.VBoolean b) = pure $ FPrimitive b+ valueParser _ _ (GQL.Boolean b) = pure $ FPrimitive b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive Int32) where- valueParser _ _ (GQL.VInt b) = pure $ FPrimitive $ fromIntegral b+ valueParser _ _ (GQL.Int b) = pure $ FPrimitive $ fromIntegral b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive Integer) where- valueParser _ _ (GQL.VInt b) = pure $ FPrimitive b+ valueParser _ _ (GQL.Int b) = pure $ FPrimitive $ toInteger b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive Scientific) where- valueParser _ _ (GQL.VFloat b) = pure $ FPrimitive b+ valueParser _ _ (GQL.Float b) = pure $ FPrimitive $ fromFloatDigits b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive Double) where- valueParser _ _ (GQL.VFloat b) = pure $ FPrimitive $ toRealFloat b+ valueParser _ _ (GQL.Float b) = pure $ FPrimitive b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive T.Text) where- valueParser _ _ (GQL.VString (GQL.StringValue b))+ valueParser _ _ (GQL.String b) = pure $ FPrimitive b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance ValueParser sch ('TPrimitive String) where- valueParser _ _ (GQL.VString (GQL.StringValue b))+ valueParser _ _ (GQL.String b) = pure $ FPrimitive $ T.unpack b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance (ValueParser sch r) => ValueParser sch ('TList r) where- valueParser vmap fname (GQL.VList (GQL.ListValueG xs))+ valueParser vmap fname (GQL.List xs) = FList <$> traverse (valueParser' vmap fname) xs valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance (ValueParser sch r) => ValueParser sch ('TOption r) where- valueParser _ _ GQL.VNull+ valueParser _ _ GQL.Null = pure $ FOption Nothing valueParser vmap fname v = FOption . Just <$> valueParser' vmap fname v@@ -664,7 +675,7 @@ => VariableMap -> FragmentMap -> T.Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> f (ReturnQuery p r) instance ParseDifferentReturn p 'RetNothing where parseDiffReturn _ _ _ [] = pure RNothing@@ -682,7 +693,7 @@ => VariableMap -> FragmentMap -> T.Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> f (ReturnQuery' p r) instance ParseReturn p ('PrimitiveRef t) where@@ -714,7 +725,7 @@ => VariableMap -> FragmentMap -> T.Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> f (SchemaQuery s t) instance ParseSchema sch ('DEnum name choices) where parseSchema _ _ _ []@@ -734,34 +745,34 @@ , ParseField sch fields ) => Proxy sch -> Proxy t ->- VariableMap -> FragmentMap -> GQL.SelectionSet ->+ VariableMap -> FragmentMap -> [GQL.Selection] -> f [OneFieldQuery sch fields] parseSchemaQuery _ _ _ _ [] = pure []-parseSchemaQuery pp ps vmap frmap (GQL.SelectionField fld : ss)+parseSchemaQuery pp ps vmap frmap (GQL.FieldSelection fld : ss) = (++) <$> (maybeToList <$> fieldToMethod fld) <*> parseSchemaQuery pp ps vmap frmap ss where fieldToMethod :: GQL.Field -> f (Maybe (OneFieldQuery sch fields))- fieldToMethod (GQL.Field alias name args dirs sels)+ fieldToMethod (GQL.Field alias name args dirs sels _) | any (shouldSkip vmap) dirs = pure Nothing- | GQL.unName name == "__typename"+ | name == "__typename" = case (args, sels) of- ([], []) -> pure $ Just $ TypeNameFieldQuery $ GQL.unName . GQL.unAlias <$> alias+ ([], []) -> pure $ Just $ TypeNameFieldQuery alias _ -> throwError "__typename does not admit arguments nor selection of subfields" | _:_ <- args = throwError "this field does not support arguments" | otherwise- = Just . OneFieldQuery (GQL.unName . GQL.unAlias <$> alias)+ = Just . OneFieldQuery alias <$> selectField (T.pack $ nameVal (Proxy @rname)) vmap frmap name sels-parseSchemaQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss)- | Just fr <- HM.lookup (GQL.unName nm) frmap- = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr)- then (++) <$> parseSchemaQuery pp ps vmap frmap (GQL._fdSelectionSet fr)+parseSchemaQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)+ | Just fr <- HM.lookup nm frmap+ = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)+ then (++) <$> parseSchemaQuery pp ps vmap frmap (fdSelectionSet fr) <*> parseSchemaQuery pp ps vmap frmap ss else parseSchemaQuery pp ps vmap frmap ss | otherwise -- the fragment definition was not found- = throwError $ "fragment '" <> GQL.unName nm <> "' was not found"+ = throwError $ "fragment '" <> nm <> "' was not found" parseSchemaQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported = throwError "inline fragments are not (yet) supported" @@ -772,21 +783,21 @@ VariableMap -> FragmentMap -> GQL.Name ->- GQL.SelectionSet ->+ [GQL.Selection] -> f (NS (ChosenFieldQuery sch) fs) instance ParseField sch '[] where- selectField tyName _ _ (GQL.unName -> wanted) _+ selectField tyName _ _ wanted _ = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" instance (KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) => ParseField sch ('FieldDef fname r ': fs) where- selectField tyName vmap frmap w@(GQL.unName -> wanted) sels+ selectField tyName vmap frmap wanted sels | wanted == mname = Z <$> (ChosenFieldQuery <$> parseSchemaReturn vmap frmap wanted sels) | otherwise- = S <$> selectField tyName vmap frmap w sels+ = S <$> selectField tyName vmap frmap wanted sels where mname = T.pack $ nameVal (Proxy @fname) @@ -795,7 +806,7 @@ => VariableMap -> FragmentMap -> T.Text- -> GQL.SelectionSet+ -> [GQL.Selection] -> f (ReturnSchemaQuery sch r) instance ParseSchemaReturn sch ('TPrimitive t) where@@ -815,3 +826,21 @@ => ParseSchemaReturn sch ('TOption r) where parseSchemaReturn vmap frmap fname s = RetSchOptional <$> parseSchemaReturn vmap frmap fname s++-- some useful field accessors++fdName :: GQL.FragmentDefinition -> GQL.Name+fdName (GQL.FragmentDefinition nm _ _ _ _) = nm++fdDirectives :: GQL.FragmentDefinition -> [GQL.Directive]+fdDirectives (GQL.FragmentDefinition _ _ ds _ _) = ds++fdSelectionSet :: GQL.FragmentDefinition -> [GQL.Selection]+fdSelectionSet (GQL.FragmentDefinition _ _ _ ss _)+ = F.toList ss++argName :: GQL.Argument -> GQL.Name+argName (GQL.Argument nm _ _) = nm++fName :: GQL.Field -> GQL.Name+fName (GQL.Field _ nm _ _ _ _) = nm
src/Mu/GraphQL/Query/Run.hs view
@@ -13,7 +13,6 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-}-{-# language ViewPatterns #-} {-# OPTIONS_GHC -fprint-explicit-foralls #-} module Mu.GraphQL.Query.Run ( GraphQLApp@@ -31,7 +30,6 @@ import Control.Monad.Writer import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson-import Data.Coerce (coerce) import Data.Conduit import Data.Conduit.Combinators (sinkList, yieldMany) import Data.Conduit.TQueue@@ -39,7 +37,7 @@ import Data.Maybe import qualified Data.Text as T import GHC.TypeLits-import qualified Language.GraphQL.Draft.Syntax as GQL+import qualified Language.GraphQL.AST as GQL import Network.HTTP.Types.Header import Mu.GraphQL.Query.Definition@@ -61,7 +59,7 @@ -> RequestHeaders -> ServerT chn GQL.Field p m hs -> Proxy qr -> Proxy mut -> Proxy sub- -> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument+ -> Maybe T.Text -> VariableMapC -> [GQL.Definition] -> IO Aeson.Value runPipeline f req svr _ _ _ opName vmap doc = case parseDoc @qr @mut @sub opName vmap doc of@@ -78,7 +76,7 @@ -> RequestHeaders -> ServerT chn GQL.Field p m hs -> Proxy qr -> Proxy mut -> Proxy sub- -> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument+ -> Maybe T.Text -> VariableMapC -> [GQL.Definition] -> ConduitT Aeson.Value Void IO () -> IO () runSubscriptionPipeline f req svr _ _ _ opName vmap doc sink@@ -601,13 +599,13 @@ runIntroSchema- :: [T.Text] -> Intro.Schema -> GQL.SelectionSet+ :: [T.Text] -> Intro.Schema -> [GQL.Selection] -> WriterT [GraphQLError] IO Aeson.Value runIntroSchema path s@(Intro.Schema qr mut sub ts) ss = do things <- catMaybes <$> traverse runOne ss pure $ Aeson.object things where- runOne (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss))+ runOne (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) = let realName :: T.Text = fromMaybe nm alias path' = path ++ [realName] in fmap (realName,) <$> case nm of@@ -639,7 +637,7 @@ runOne _ = pure Nothing runIntroType- :: [T.Text] -> Intro.Schema -> Intro.Type -> GQL.SelectionSet+ :: [T.Text] -> Intro.Schema -> Intro.Type -> [GQL.Selection] -> WriterT [GraphQLError] IO (Maybe Aeson.Value) runIntroType path s@(Intro.Schema _ _ _ ts) (Intro.TypeRef t) ss = case HM.lookup t ts of@@ -649,7 +647,7 @@ = do things <- catMaybes <$> traverse runOne ss pure $ Just $ Aeson.object things where- runOne (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss))+ runOne (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) = let realName :: T.Text = fromMaybe nm alias path' = path ++ [realName] in fmap (realName,) <$> case (nm, innerss) of@@ -696,14 +694,14 @@ runOne _ = pure Nothing runIntroFields- :: [T.Text] -> Intro.Field -> GQL.SelectionSet+ :: [T.Text] -> Intro.Field -> [GQL.Selection] -> WriterT [GraphQLError] IO (Maybe Aeson.Value) runIntroFields fpath fld fss = do things <- catMaybes <$> traverse (runIntroField fpath fld) fss pure $ Just $ Aeson.object things runIntroField fpath (Intro.Field fnm fargs fty)- (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss))+ (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) = let realName :: T.Text = fromMaybe nm alias fpath' = fpath ++ [realName] in fmap (realName,) <$> case (nm, innerss) of@@ -737,14 +735,14 @@ runIntroField _ _ _ = pure Nothing runIntroEnums- :: [T.Text] -> Intro.EnumValue -> GQL.SelectionSet+ :: [T.Text] -> Intro.EnumValue -> [GQL.Selection] -> WriterT [GraphQLError] IO (Maybe Aeson.Value) runIntroEnums epath enm ess = do things <- catMaybes <$> traverse (runIntroEnum epath enm) ess pure $ Just $ Aeson.object things runIntroEnum epath (Intro.EnumValue enm)- (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss))+ (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) = let realName :: T.Text = fromMaybe nm alias in fmap (realName,) <$> case (nm, innerss) of ("name", [])@@ -765,14 +763,14 @@ runIntroEnum _ _ _ = pure Nothing runIntroInputs- :: [T.Text] -> Intro.Input -> GQL.SelectionSet+ :: [T.Text] -> Intro.Input -> [GQL.Selection] -> WriterT [GraphQLError] IO (Maybe Aeson.Value) runIntroInputs ipath inm iss = do things <- catMaybes <$> traverse (runIntroInput ipath inm) iss pure $ Just $ Aeson.object things runIntroInput ipath (Intro.Input inm def ty)- (GQL.SelectionField (GQL.Field (coerce -> alias) (coerce -> nm) _ _ innerss))+ (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) = let realName :: T.Text = fromMaybe nm alias ipath' = ipath ++ [realName] in fmap (realName,) <$> case (nm, innerss) of
src/Mu/GraphQL/Server.hs view
@@ -36,19 +36,18 @@ import Control.Applicative ((<|>)) import Control.Exception (throw)-import Control.Monad.Except+import Control.Monad.Except (MonadIO (..), join, runExceptT) import qualified Data.Aeson as A import Data.Aeson.Text (encodeToLazyText) import Data.ByteString.Lazy (fromStrict, toStrict)-import Data.Conduit+import Data.Conduit (ConduitT, transPipe) import qualified Data.HashMap.Strict as HM-import Data.Proxy+import Data.Proxy (Proxy (..)) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding (decodeUtf8')+import Data.Text.Encoding.Error (UnicodeException (..)) import qualified Data.Text.Lazy.Encoding as T-import Language.GraphQL.Draft.Parser (parseExecutableDoc)-import qualified Language.GraphQL.Draft.Syntax as GQL-import Mu.Adapter.Json ()+import qualified Language.GraphQL.AST as GQL import Network.HTTP.Types.Header (hContentType) import Network.HTTP.Types.Method (StdMethod (..), parseMethod) import Network.HTTP.Types.Status (ok200)@@ -57,10 +56,11 @@ import qualified Network.Wai.Handler.WebSockets as WS import qualified Network.WebSockets as WS -import Mu.GraphQL.Query.Parse-import Mu.GraphQL.Query.Run-import Mu.GraphQL.Subscription.Protocol-import Mu.Server+import Mu.GraphQL.Quasi.LostParser (parseDoc)+import Mu.GraphQL.Query.Parse (VariableMapC)+import Mu.GraphQL.Query.Run (GraphQLApp, runPipeline, runSubscriptionPipeline)+import Mu.GraphQL.Subscription.Protocol (protocol)+import Mu.Server (ServerErrorIO, ServerT) data GraphQLInput = GraphQLInput T.Text VariableMapC (Maybe T.Text) @@ -133,17 +133,22 @@ -> Application httpGraphQLAppTrans f server q m s req res = case parseMethod (requestMethod req) of- Left err -> toError $ decodeUtf8 err- Right GET -> do+ Left err -> toError $ either unpackUnicodeException id (decodeUtf8' err)+ Right GET -> do let qst = queryString req- opN = decodeUtf8 <$> join (lookup "operationName" qst)- case (fmap decodeUtf8 <$> lookup "query" qst, lookup "variables" qst) of- (Just (Just qry), Just (Just vars)) ->+ opN = decodeUtf8' <$> join (lookup "operationName" qst)+ decodedQuery = fmap decodeUtf8' =<< lookup "query" qst+ case (decodedQuery, lookup "variables" qst) of+ (Just (Right qry), Just (Just vars)) -> case A.eitherDecode $ fromStrict vars of Left err -> toError $ T.pack err- Right vrs -> execQuery opN vrs qry- (Just (Just qry), _) -> execQuery opN HM.empty qry- _ -> toError "Error parsing query"+ Right vrs -> case sequence opN of+ Left err -> toError $ "Could not parse operation name: " <> unpackUnicodeException err+ Right opName -> execQuery opName vrs qry+ (Just (Right qry), _) -> case sequence opN of+ Left err -> toError $ "Could not parse query: " <> unpackUnicodeException err+ Right opName -> execQuery opName HM.empty qry+ _ -> toError "Error parsing query" Right POST -> do body <- strictRequestBody req case lookup hContentType $ requestHeaders req of@@ -152,13 +157,15 @@ Left err -> toError $ T.pack err Right (GraphQLInput qry vars opName) -> execQuery opName vars qry Just "application/graphql" ->- execQuery Nothing HM.empty (decodeUtf8 $ toStrict body)+ case decodeUtf8' $ toStrict body of+ Left err -> toError $ "Could not decode utf8 from body: " <> unpackUnicodeException err+ Right msg -> execQuery Nothing HM.empty msg _ -> toError "No `Content-Type` header found!" _ -> toError "Unsupported method" where execQuery :: Maybe T.Text -> VariableMapC -> T.Text -> IO ResponseReceived execQuery opn vals qry =- case parseExecutableDoc qry of+ case parseDoc qry of Left err -> toError err Right doc -> runPipeline f (requestHeaders req) server q m s opn vals doc >>= toResponse@@ -166,6 +173,9 @@ toError err = toResponse $ A.object [ ("errors", A.Array [ A.object [ ("message", A.String err) ] ])] toResponse :: A.Value -> IO ResponseReceived toResponse = res . responseBuilder ok200 [] . T.encodeUtf8Builder . encodeToLazyText+ unpackUnicodeException :: UnicodeException -> T.Text+ unpackUnicodeException (DecodeError str _) = T.pack str+ unpackUnicodeException _ = error "EncodeError is deprecated" wsGraphQLAppTrans :: ( GraphQLApp p qr mut sub m chn hs )@@ -177,8 +187,13 @@ -> WS.ServerApp wsGraphQLAppTrans f server q m s conn = do let headers = WS.requestHeaders $ WS.pendingRequest conn- conn' <- WS.acceptRequest conn- flip protocol conn' $ runSubscriptionPipeline f headers server q m s+ case lookup "Sec-WebSocket-Protocol" headers of+ Just v+ | v == "graphql-ws" || v == "graphql-transport-ws"+ -> do conn' <- WS.acceptRequestWith conn (WS.AcceptRequest (Just v) [])+ flip protocol conn' $+ runSubscriptionPipeline f headers server q m s+ _ -> WS.rejectRequest conn "unsupported protocol" -- | Run a Mu 'graphQLApp' using the given 'Settings'. --
src/Mu/GraphQL/Subscription/Protocol.hs view
@@ -11,22 +11,22 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Monad (forM_)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.Aeson ((.:), (.:?), (.=))-import qualified Data.Aeson as A+import Control.Monad (forM_)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Aeson ((.:), (.:?), (.=))+import qualified Data.Aeson as A import Data.Conduit-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T-import Language.GraphQL.Draft.Parser (parseExecutableDoc)-import Language.GraphQL.Draft.Syntax (ExecutableDocument)-import qualified ListT as L+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Language.GraphQL.AST+import qualified ListT as L import Network.WebSockets-import qualified StmContainers.Map as M+import qualified StmContainers.Map as M +import qualified Mu.GraphQL.Quasi.LostParser as P import Mu.GraphQL.Query.Parse -protocol :: ( Maybe T.Text -> VariableMapC -> ExecutableDocument+protocol :: ( Maybe T.Text -> VariableMapC -> [Definition] -> ConduitT A.Value Void IO () -> IO () ) -> Connection -> IO ()@@ -71,7 +71,7 @@ _ -> listen ka vars -- Keep going -- Handle a single query handle i q v o- = case parseExecutableDoc q of+ = case P.parseDoc q of Left err -> sendJSON conn (GQLError i (A.toJSON err)) Right d -> do f o v d (cndt i)@@ -119,6 +119,9 @@ | GQLKeepAlive deriving Show +-- NOTE: using https://github.com/apollographql/subscriptions-transport-ws/blob/master/src/message-types.ts+-- as source of truth for the message types+ instance A.FromJSON ClientMessage where parseJSON = A.withObject "ClientMessage" $ \v -> do ty :: String <- v .: "type"@@ -147,7 +150,7 @@ toJSON (GQLConnectionError e) = A.object [theType "connection_error", "payload" .= e] toJSON GQLConnectionAck- = A.object [theType "connection_acl"]+ = A.object [theType "connection_ack"] toJSON (GQLData i p) = A.object [theType "data", "id" .= i, "payload" .= p] toJSON (GQLError i p)@@ -155,4 +158,4 @@ toJSON (GQLComplete i) = A.object [theType "complete", "id" .= i] toJSON GQLKeepAlive- = A.object [theType "connection_keep_alive"]+ = A.object [theType "ka"]