higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-09-11 14:36:01 +03:00
Code Issues Projects Releases Wiki Activity

Use a published GraphQL parser (#256)

Browse Source
This commit is contained in:
Alejandro Serrano 2020-11-12 16:47:12 +01:00 committed by GitHub
parent bf5f605af2
commit 8e0e846fd1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 358 additions and 349 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
graphql/mu-graphql.cabal
View File

@ -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 @@ library
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.*

55
graphql/src/Mu/GraphQL/Annotations.hs
View File

@ -5,7 +5,6 @@
{-# language TupleSections #-}
{-# language TypeApplications #-}
{-# language TypeOperators #-}
{-# language ViewPatterns #-}
{-|
Description : Annotations for GraphQL services
@ -23,12 +22,11 @@ module Mu.GraphQL.Annotations (
, 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 @@ data ValueConst nat symbol
-- 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 @@ fromGQLValueConst _ = empty
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 @@ instance (ReflectValueConst x, ReflectValueConstList xs)
= 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

181
graphql/src/Mu/GraphQL/Quasi.hs
View File

@ -14,19 +14,19 @@ module Mu.GraphQL.Quasi (
, 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 @@ data GQLType =
| 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 @@ defaultDeclToTy (sn, (mn, (an, dv)))
-- | 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

54
graphql/src/Mu/GraphQL/Quasi/LostParser.hs
View File

@ -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)
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)
schemaDefinition :: Parser GQL.SchemaDefinition
schemaDefinition = symbol "schema" *> braces (
GQL.SchemaDefinition
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"
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)

6
graphql/src/Mu/GraphQL/Query/Definition.hs
View File

@ -8,7 +8,7 @@ module Mu.GraphQL.Query.Definition where
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 @@ data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
-- 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))

337
graphql/src/Mu/GraphQL/Query/Parse.hs
View File

@ -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 @@ parseDoc Nothing vmap (GQL.ExecutableDocument defns)
([], _, _) -> 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,21 +246,23 @@ instance
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.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 ]
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 ]
parseQuery ::
forall (p :: Package') (s :: Symbol) pname ss methods f.
@ -259,54 +272,53 @@ parseQuery ::
) =>
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 vmap (GQL.Directive (GQL.unName -> nm) [GQL.Argument (GQL.unName -> i
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 @@ class ParseMethod (p :: Package') (s :: Service') (ms :: [Method']) where
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 @@ instance
, 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 @@ instance ParseArgs p s m '[] where
-- 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 @@ instance ( KnownName aname, ParseMaybeArg p a, ParseArgs p s m as
=> 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 @@ instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
=> 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 @@ parseArg' :: (ParseArg p a, MonadError T.Text f)
-> 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 @@ class ParseArg (p :: Package') (a :: TypeRef Symbol) where
-> 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 @@ parseObjectOrEnum' :: (ObjectOrEnumParser sch t, MonadError T.Text f)
-> 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 @@ class ObjectOrEnumParser (sch :: Schema') (t :: TypeDef Symbol Symbol) where
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 @@ class ObjectParser (sch :: Schema') (args :: [FieldDef Symbol Symbol]) where
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 @@ instance
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 @@ class EnumParser (choices :: [ChoiceDef Symbol]) where
-> 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 @@ valueParser' :: (ValueParser sch v, MonadError T.Text f)
-> 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 @@ class ValueParser (sch :: Schema') (v :: FieldType Symbol) where
-> 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 @@ class ParseDifferentReturn (p :: Package') (r :: Return Symbol (TypeRef Symbol))
=> VariableMap
-> FragmentMap
-> T.Text
-> GQL.SelectionSet
-> [GQL.Selection]
-> f (ReturnQuery p r)
instance ParseDifferentReturn p 'RetNothing where
parseDiffReturn _ _ _ [] = pure RNothing
@ -682,7 +693,7 @@ class ParseReturn (p :: Package') (r :: TypeRef Symbol) where
=> VariableMap
-> FragmentMap
-> T.Text
-> GQL.SelectionSet
-> [GQL.Selection]
-> f (ReturnQuery' p r)
instance ParseReturn p ('PrimitiveRef t) where
@ -714,7 +725,7 @@ class ParseSchema (s :: Schema') (t :: TypeDef Symbol Symbol) where
=> VariableMap
-> FragmentMap
-> T.Text
-> GQL.SelectionSet
-> [GQL.Selection]
-> f (SchemaQuery s t)
instance ParseSchema sch ('DEnum name choices) where
parseSchema _ _ _ []
@ -734,34 +745,34 @@ parseSchemaQuery ::
, 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 @@ class ParseField (sch :: Schema') (fs :: [FieldDef Symbol Symbol]) where
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 @@ class ParseSchemaReturn (sch :: Schema') (r :: FieldType Symbol) where
=> VariableMap
-> FragmentMap
-> T.Text
-> GQL.SelectionSet
-> [GQL.Selection]
-> f (ReturnSchemaQuery sch r)
instance ParseSchemaReturn sch ('TPrimitive t) where
@ -815,3 +826,21 @@ instance ParseSchemaReturn sch r
=> 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

28
graphql/src/Mu/GraphQL/Query/Run.hs
View File

@ -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.Except (MonadError, runExceptT)
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 qualified Data.HashMap.Strict as HM
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 @@ runPipeline
-> 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 @@ runSubscriptionPipeline
-> 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 @@ instance RunSchemaQuery sch (sch :/: l)
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 @@ runIntroSchema path s@(Intro.Schema qr mut sub ts) ss
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 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
= 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 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
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 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
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 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
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

7
graphql/src/Mu/GraphQL/Server.hs
View File

@ -47,8 +47,7 @@ import qualified Data.Text as T
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 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,6 +56,7 @@ import Network.Wai.Handler.Warp (Port, Settings, run, runSetti
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
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)
@ -165,7 +165,7 @@ httpGraphQLAppTrans f server q m s req res =
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
@ -175,6 +175,7 @@ httpGraphQLAppTrans f server q m s req res =
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 )

24
graphql/src/Mu/GraphQL/Subscription/Protocol.hs
View File

@ -11,22 +11,22 @@ import Control.Applicative
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 @@ protocol f conn = start
_ -> 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)

3
stack-14.yaml
View File

@ -36,8 +36,7 @@ extra-deps:
- hw-kafka-conduit-2.7.0
- tracing-control-0.0.6
- wai-middleware-prometheus-1.0.0
- git: https://github.com/hasura/graphql-parser-hs.git
commit: f4a093981ca5626982a17c2bfaad047cc0834a81
- graphql-0.11.0.0
- generic-aeson-0.2.0.11
- parameterized-0.5.0.0
# Not in LTS 14

3
stack-nightly.yaml
View File

@ -36,8 +36,7 @@ extra-deps:
- hw-kafka-conduit-2.7.0
- tracing-control-0.0.6
- wai-middleware-prometheus-1.0.0
- git: https://github.com/hasura/graphql-parser-hs.git
commit: f4a093981ca5626982a17c2bfaad047cc0834a81
- graphql-0.11.0.0
- generic-aeson-0.2.0.11
- parameterized-0.5.0.0
# Dropped in LTS 16

3
stack.yaml
View File

@ -36,8 +36,7 @@ extra-deps:
- hw-kafka-conduit-2.7.0
- tracing-control-0.0.6
- wai-middleware-prometheus-1.0.0
- git: https://github.com/hasura/graphql-parser-hs.git
commit: f4a093981ca5626982a17c2bfaad047cc0834a81
- graphql-0.11.0.0
- generic-aeson-0.2.0.11
- parameterized-0.5.0.0
# Dropped in LTS 16