mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Use a published GraphQL parser (#256)
This commit is contained in:
parent
bf5f605af2
commit
8e0e846fd1
@ -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.*
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 )
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user