mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-10-26 15:49:00 +03:00
GraphQL introspection (#153)
This commit is contained in:
parent
8eb8947bf1
commit
5954d26cb8
@ -39,7 +39,7 @@ main = do
|
||||
("Access-Control-Allow-Origin", "*")
|
||||
, ("Access-Control-Allow-Headers", "Content-Type")
|
||||
]
|
||||
run 8000 $ hm $ graphQLApp libraryServer
|
||||
run 8000 $ {- hm $ -} graphQLApp libraryServer
|
||||
(Proxy @('Just "Query")) (Proxy @'Nothing) (Proxy @('Just "Subscription"))
|
||||
|
||||
type ServiceDefinition
|
||||
|
@ -20,6 +20,7 @@ library
|
||||
|
||||
other-modules:
|
||||
Mu.GraphQL.Query.Definition
|
||||
Mu.GraphQL.Query.Introspection
|
||||
Mu.GraphQL.Query.Parse
|
||||
Mu.GraphQL.Query.Run
|
||||
Mu.GraphQL.Subscription.Protocol
|
||||
|
@ -8,6 +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 Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
@ -34,9 +35,20 @@ data OneMethodQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm) where
|
||||
:: Maybe Text
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-- the special '__typename' field
|
||||
TypeNameQuery
|
||||
:: Maybe Text
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-- introspection fields
|
||||
SchemaQuery
|
||||
:: Maybe Text
|
||||
-> GQL.SelectionSet
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
TypeQuery
|
||||
:: Maybe Text
|
||||
-> Text
|
||||
-> GQL.SelectionSet
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
|
||||
data ChosenMethodQuery (p :: Package snm mnm anm) (m :: Method snm mnm anm) where
|
||||
ChosenMethodQuery
|
||||
@ -83,6 +95,9 @@ data OneFieldQuery (sch :: Schema tn fn) (fs :: [FieldDef tn fn]) where
|
||||
:: Maybe Text
|
||||
-> NS (ChosenFieldQuery sch) fs
|
||||
-> OneFieldQuery sch fs
|
||||
TypeNameFieldQuery
|
||||
:: Maybe Text
|
||||
-> OneFieldQuery sch fs
|
||||
|
||||
data ChosenFieldQuery (sch :: Schema tn fn) (f :: FieldDef tn fn) where
|
||||
ChosenFieldQuery
|
||||
|
311
graphql/src/Mu/GraphQL/Query/Introspection.hs
Normal file
311
graphql/src/Mu/GraphQL/Query/Introspection.hs
Normal file
@ -0,0 +1,311 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
module Mu.GraphQL.Query.Introspection where
|
||||
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Int (Int32)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy
|
||||
import Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import Mu.Rpc
|
||||
import qualified Mu.Schema as Mu
|
||||
|
||||
type TypeMap = HM.HashMap T.Text Type
|
||||
|
||||
data Schema
|
||||
= Schema { queryType :: Maybe T.Text
|
||||
, mutationType :: Maybe T.Text
|
||||
, subscriptionType :: Maybe T.Text
|
||||
, types :: TypeMap }
|
||||
deriving Show
|
||||
|
||||
data Type
|
||||
= Type { kind :: TypeKind
|
||||
, typeName :: Maybe T.Text
|
||||
, fields :: [Field]
|
||||
, enumValues :: [EnumValue]
|
||||
, ofType :: Maybe Type }
|
||||
| TypeRef { to :: T.Text }
|
||||
deriving Show
|
||||
|
||||
data Field
|
||||
= Field { fieldName :: T.Text
|
||||
, args :: [Input]
|
||||
, fieldType :: Type }
|
||||
deriving Show
|
||||
|
||||
data Input
|
||||
= Input { inputName :: T.Text
|
||||
, inputDefaultValue :: Maybe T.Text
|
||||
, inputType :: Type }
|
||||
deriving Show
|
||||
|
||||
newtype EnumValue
|
||||
= EnumValue { enumValueName :: T.Text }
|
||||
deriving Show
|
||||
|
||||
data TypeKind
|
||||
= SCALAR
|
||||
| OBJECT
|
||||
| INTERFACE
|
||||
| UNION
|
||||
| ENUM
|
||||
| INPUT_OBJECT
|
||||
| LIST
|
||||
| NON_NULL
|
||||
deriving Show
|
||||
|
||||
tSimple :: T.Text -> Type
|
||||
tSimple t = Type SCALAR (Just t) [] [] Nothing
|
||||
|
||||
tList :: Type -> Type
|
||||
tList = Type LIST Nothing [] [] . Just
|
||||
|
||||
tNonNull :: Type -> Type
|
||||
tNonNull = Type NON_NULL Nothing [] [] . Just
|
||||
|
||||
unwrapNonNull :: Type -> Maybe Type
|
||||
unwrapNonNull (Type NON_NULL _ _ _ x) = x
|
||||
unwrapNonNull _ = Nothing
|
||||
|
||||
-- BUILD INTROSPECTION DATA
|
||||
-- ========================
|
||||
|
||||
class Introspect (p :: Package')
|
||||
(qr :: Maybe Symbol)
|
||||
(mut :: Maybe Symbol)
|
||||
(sub :: Maybe Symbol) where
|
||||
introspect
|
||||
:: Proxy p -> Proxy qr -> Proxy mut -> Proxy sub -> Schema
|
||||
|
||||
instance ( IntrospectServices ss sub
|
||||
, KnownMaybeSymbol qr
|
||||
, KnownMaybeSymbol mut
|
||||
, KnownMaybeSymbol sub)
|
||||
=> Introspect ('Package nm ss) qr mut sub where
|
||||
introspect _ _ _ _
|
||||
= let (_, ts) = runWriter $
|
||||
introspectServices (Proxy @ss) (Proxy @sub) >>
|
||||
tell (HM.fromList ((\i -> (i, tSimple i)) <$> ["Int", "Float", "String", "Boolean", "ID"]))
|
||||
in Schema (maybeSymbolVal (Proxy @qr))
|
||||
(maybeSymbolVal (Proxy @mut))
|
||||
(maybeSymbolVal (Proxy @sub))
|
||||
ts
|
||||
|
||||
class KnownMaybeSymbol (s :: Maybe Symbol) where
|
||||
maybeSymbolVal :: Proxy s -> Maybe T.Text
|
||||
instance KnownSymbol s => KnownMaybeSymbol ('Just s) where
|
||||
maybeSymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
|
||||
instance KnownMaybeSymbol 'Nothing where
|
||||
maybeSymbolVal _ = Nothing
|
||||
|
||||
type family IsSub (sname :: Symbol) (sub :: Maybe Symbol) :: Bool where
|
||||
IsSub sname 'Nothing = 'False
|
||||
IsSub sname ('Just sname) = 'True
|
||||
IsSub sname ('Just other) = 'False
|
||||
|
||||
class IntrospectServices (ss :: [Service']) (sub :: Maybe Symbol) where
|
||||
introspectServices
|
||||
:: Proxy ss -> Proxy sub -> Writer TypeMap ()
|
||||
instance IntrospectServices '[] sub where
|
||||
introspectServices _ _ = pure ()
|
||||
instance ( KnownSymbol sname
|
||||
, IntrospectFields smethods (IsSub sname sub)
|
||||
, IntrospectServices ss sub )
|
||||
=> IntrospectServices ('Service sname sanns smethods ': ss) sub where
|
||||
introspectServices _ psub
|
||||
= do let name = T.pack $ symbolVal (Proxy @sname)
|
||||
fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub))
|
||||
let t = Type OBJECT (Just name) fs [] Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
introspectServices (Proxy @ss) psub
|
||||
|
||||
class IntrospectFields (fs :: [Method']) (isSub :: Bool) where
|
||||
introspectFields
|
||||
:: Proxy fs -> Proxy isSub -> Writer TypeMap [Field]
|
||||
instance IntrospectFields '[] isSub where
|
||||
introspectFields _ _ = pure []
|
||||
instance ( KnownSymbol mname
|
||||
, IntrospectInputs margs
|
||||
, IntrospectReturn mret isSub
|
||||
, IntrospectFields fs isSub)
|
||||
=> IntrospectFields ('Method mname manns margs mret ': fs) isSub where
|
||||
introspectFields _ pIsSub
|
||||
= do let name = T.pack $ symbolVal (Proxy @mname)
|
||||
inputs <- introspectInputs (Proxy @margs)
|
||||
ret <- introspectReturn (Proxy @mret) pIsSub
|
||||
let this = Field name inputs ret
|
||||
(this :) <$> introspectFields (Proxy @fs) pIsSub
|
||||
|
||||
class IntrospectInputs (args :: [Argument']) where
|
||||
introspectInputs
|
||||
:: Proxy args -> Writer TypeMap [Input]
|
||||
instance IntrospectInputs '[] where
|
||||
introspectInputs _ = pure []
|
||||
instance ( KnownMaybeSymbol nm
|
||||
, IntrospectTypeRef r
|
||||
, IntrospectInputs args )
|
||||
=> IntrospectInputs ('ArgSingle nm anns r ': args) where
|
||||
introspectInputs _
|
||||
= do let nm = maybeSymbolVal (Proxy @nm)
|
||||
t <- introspectTypeRef (Proxy @r) False
|
||||
-- TODO Find default value
|
||||
let this = Input (fromMaybe "arg" nm) Nothing t
|
||||
(this :) <$> introspectInputs (Proxy @args)
|
||||
instance ( KnownMaybeSymbol nm
|
||||
, IntrospectTypeRef r
|
||||
, IntrospectInputs args )
|
||||
=> IntrospectInputs ('ArgStream nm anns r ': args) where
|
||||
introspectInputs _
|
||||
= do let nm = maybeSymbolVal (Proxy @nm)
|
||||
t <- tList <$> introspectTypeRef (Proxy @r) False
|
||||
-- TODO Find default value
|
||||
let this = Input (fromMaybe "arg" nm) Nothing t
|
||||
(this :) <$> introspectInputs (Proxy @args)
|
||||
|
||||
class IntrospectReturn (r :: Return Symbol) (isSub :: Bool) where
|
||||
introspectReturn
|
||||
:: Proxy r -> Proxy isSub -> Writer TypeMap Type
|
||||
|
||||
instance IntrospectReturn 'RetNothing isSub where
|
||||
introspectReturn _ _ = pure $ tSimple "Null"
|
||||
instance IntrospectTypeRef t
|
||||
=> IntrospectReturn ('RetSingle t) isSub where
|
||||
introspectReturn _ _ = introspectTypeRef (Proxy @t) True
|
||||
instance IntrospectTypeRef t
|
||||
=> IntrospectReturn ('RetStream t) 'False where
|
||||
introspectReturn _ _ = tList <$> introspectTypeRef (Proxy @t) True
|
||||
instance IntrospectTypeRef t
|
||||
=> IntrospectReturn ('RetStream t) 'True where
|
||||
introspectReturn _ _ = introspectTypeRef (Proxy @t) True
|
||||
|
||||
class IntrospectTypeRef (tr :: TypeRef Symbol) where
|
||||
introspectTypeRef
|
||||
:: Proxy tr -> Bool -> Writer TypeMap Type
|
||||
|
||||
instance IntrospectTypeRef ('PrimitiveRef Bool) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Boolean"
|
||||
instance IntrospectTypeRef ('PrimitiveRef Int32) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int"
|
||||
instance IntrospectTypeRef ('PrimitiveRef Integer) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int"
|
||||
instance IntrospectTypeRef ('PrimitiveRef Double) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Float"
|
||||
instance IntrospectTypeRef ('PrimitiveRef String) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String"
|
||||
instance IntrospectTypeRef ('PrimitiveRef Text) where
|
||||
introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String"
|
||||
|
||||
instance (IntrospectTypeRef r)
|
||||
=> IntrospectTypeRef ('ListRef r) where
|
||||
introspectTypeRef _ isRet = tList <$> introspectTypeRef (Proxy @r) isRet
|
||||
instance (IntrospectTypeRef r)
|
||||
=> IntrospectTypeRef ('OptionalRef r) where
|
||||
introspectTypeRef _ isRet = do
|
||||
r <- introspectTypeRef (Proxy @r) isRet
|
||||
pure $ fromMaybe r (unwrapNonNull r)
|
||||
|
||||
instance (KnownSymbol o)
|
||||
=> IntrospectTypeRef ('ObjectRef o) where
|
||||
introspectTypeRef _ _
|
||||
= pure $ TypeRef $ T.pack $ symbolVal (Proxy @o)
|
||||
|
||||
instance (IntrospectSchema sch, KnownSymbol t)
|
||||
=> IntrospectTypeRef ('SchemaRef sch t) where
|
||||
introspectTypeRef _ isRet
|
||||
= do let (k, suffix) = if isRet then (OBJECT, "R") else (INPUT_OBJECT, "")
|
||||
introspectSchema k suffix (Proxy @sch)
|
||||
pure $ TypeRef $ T.pack (symbolVal (Proxy @t)) <> suffix
|
||||
|
||||
class IntrospectSchema (ts :: [Mu.TypeDef Symbol Symbol]) where
|
||||
introspectSchema
|
||||
:: TypeKind -> Text -> Proxy ts -> Writer TypeMap ()
|
||||
instance IntrospectSchema '[] where
|
||||
introspectSchema _ _ _ = pure ()
|
||||
instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts)
|
||||
=> IntrospectSchema ('Mu.DRecord name fields ': ts) where
|
||||
introspectSchema k suffix _
|
||||
= do let name = T.pack (symbolVal (Proxy @name)) <> suffix
|
||||
fs = introspectSchemaFields suffix (Proxy @fields)
|
||||
t = Type k (Just name) fs [] Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
introspectSchema k suffix (Proxy @ts)
|
||||
instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts)
|
||||
=> IntrospectSchema ('Mu.DEnum name choices ': ts) where
|
||||
introspectSchema k suffix _
|
||||
= do let name = T.pack (symbolVal (Proxy @name)) <> suffix
|
||||
cs = introspectSchemaEnum (Proxy @choices)
|
||||
t = Type ENUM (Just name) [] cs Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
introspectSchema k suffix (Proxy @ts)
|
||||
|
||||
class IntrospectSchemaFields (fs :: [Mu.FieldDef Symbol Symbol]) where
|
||||
introspectSchemaFields
|
||||
:: T.Text -> Proxy fs -> [Field]
|
||||
instance IntrospectSchemaFields '[] where
|
||||
introspectSchemaFields _ _ = []
|
||||
instance (KnownSymbol fname,IntrospectSchemaFieldType r, IntrospectSchemaFields fs)
|
||||
=> IntrospectSchemaFields ('Mu.FieldDef fname r ': fs) where
|
||||
introspectSchemaFields suffix _
|
||||
= let name = T.pack $ symbolVal (Proxy @fname)
|
||||
ret = introspectSchemaFieldType suffix (Proxy @r)
|
||||
this = Field name [] ret
|
||||
in this : introspectSchemaFields suffix (Proxy @fs)
|
||||
|
||||
class IntrospectSchemaFieldType (t :: Mu.FieldType Symbol) where
|
||||
introspectSchemaFieldType
|
||||
:: T.Text -> Proxy t -> Type
|
||||
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive Bool) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "Boolean"
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive Int32) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int"
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive Integer) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int"
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive Double) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "Float"
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive String) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "String"
|
||||
instance IntrospectSchemaFieldType ('Mu.TPrimitive Text) where
|
||||
introspectSchemaFieldType _ _ = tNonNull $ tSimple "String"
|
||||
|
||||
instance (IntrospectSchemaFieldType r)
|
||||
=> IntrospectSchemaFieldType ('Mu.TList r) where
|
||||
introspectSchemaFieldType suffix _
|
||||
= tList $ introspectSchemaFieldType suffix (Proxy @r)
|
||||
instance (IntrospectSchemaFieldType r)
|
||||
=> IntrospectSchemaFieldType ('Mu.TOption r) where
|
||||
introspectSchemaFieldType suffix _
|
||||
= let r = introspectSchemaFieldType suffix (Proxy @r)
|
||||
in fromMaybe r (unwrapNonNull r)
|
||||
|
||||
instance (KnownSymbol nm)
|
||||
=> IntrospectSchemaFieldType ('Mu.TSchematic nm) where
|
||||
introspectSchemaFieldType suffix _
|
||||
= TypeRef $ T.pack (symbolVal (Proxy @nm)) <> suffix
|
||||
|
||||
class IntrospectSchemaEnum (c :: [Mu.ChoiceDef Symbol]) where
|
||||
introspectSchemaEnum :: Proxy c -> [EnumValue]
|
||||
instance IntrospectSchemaEnum '[] where
|
||||
introspectSchemaEnum _ = []
|
||||
instance (KnownSymbol nm, IntrospectSchemaEnum cs)
|
||||
=> IntrospectSchemaEnum ('Mu.ChoiceDef nm ': cs) where
|
||||
introspectSchemaEnum _
|
||||
= let this = EnumValue $ T.pack $ symbolVal (Proxy @nm)
|
||||
in this : introspectSchemaEnum (Proxy @cs)
|
@ -269,9 +269,24 @@ parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
|
||||
| any (shouldSkip vmap) dirs
|
||||
= pure Nothing
|
||||
| GQL.unName name == "__typename"
|
||||
= case sels of
|
||||
[] -> pure $ Just $ TypeNameQuery $ GQL.unName . GQL.unAlias <$> alias
|
||||
_ -> throwError "__typename does not admit selection of subfields"
|
||||
= case (args, sels) of
|
||||
([], []) -> pure $ Just $ TypeNameQuery $ GQL.unName . GQL.unAlias <$> alias
|
||||
_ -> throwError "__typename does not admit arguments nor selection of subfields"
|
||||
| GQL.unName name == "__schema"
|
||||
= case args of
|
||||
[] -> Just . SchemaQuery (GQL.unName . GQL.unAlias <$> alias) <$> unFragment frmap 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
|
||||
in case args of
|
||||
[GQL.Argument _ val]
|
||||
-> case getString val of
|
||||
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)
|
||||
<$> selectMethod (T.pack $ nameVal (Proxy @s)) vmap frmap name args sels
|
||||
@ -298,6 +313,21 @@ shouldSkip vmap (GQL.Directive (GQL.unName -> nm) [GQL.Argument (GQL.unName -> i
|
||||
_ -> False
|
||||
shouldSkip _ _ = False
|
||||
|
||||
unFragment :: MonadError T.Text f
|
||||
=> FragmentMap -> GQL.SelectionSet -> f GQL.SelectionSet
|
||||
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 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)
|
||||
<*> unFragment frmap ss
|
||||
unFragment _ _
|
||||
= throwError "inline fragments are not (yet) supported"
|
||||
|
||||
class ParseMethod (p :: Package') (ms :: [Method']) where
|
||||
selectMethod ::
|
||||
MonadError T.Text f =>
|
||||
@ -666,6 +696,10 @@ parseSchemaQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
|
||||
fieldToMethod (GQL.Field alias name args dirs sels)
|
||||
| any (shouldSkip vmap) dirs
|
||||
= pure Nothing
|
||||
| GQL.unName name == "__typename"
|
||||
= case (args, sels) of
|
||||
([], []) -> pure $ Just $ TypeNameFieldQuery $ GQL.unName . GQL.unAlias <$> alias
|
||||
_ -> throwError "__typename does not admit arguments nor selection of subfields"
|
||||
| _:_ <- args
|
||||
= throwError "this field does not support arguments"
|
||||
| otherwise
|
||||
|
@ -13,6 +13,7 @@
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fprint-explicit-foralls #-}
|
||||
module Mu.GraphQL.Query.Run (
|
||||
GraphQLApp
|
||||
@ -32,14 +33,16 @@ import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators (sinkList, yieldMany)
|
||||
import Data.Conduit.Internal (ConduitT (..), Pipe (..))
|
||||
import Data.Conduit.TQueue
|
||||
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 Data.Coerce (coerce)
|
||||
import Mu.GraphQL.Query.Definition
|
||||
import qualified Mu.GraphQL.Query.Introspection as Intro
|
||||
import Mu.GraphQL.Query.Parse
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
@ -134,13 +137,17 @@ instance
|
||||
, KnownSymbol sub
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs
|
||||
, MappingRight chn sub ~ ()
|
||||
, Intro.Introspect p ('Just qr) ('Just mut) ('Just sub)
|
||||
) => RunDocument p ('Just qr) ('Just mut) ('Just sub) m chn hs where
|
||||
runDocument f svr (QueryDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument f svr (MutationDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument _ _ (SubscriptionDoc _)
|
||||
= pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocument f svr d
|
||||
= let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @('Just sub))
|
||||
in case d of
|
||||
QueryDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
MutationDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
SubscriptionDoc _
|
||||
-> pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocumentSubscription f svr (SubscriptionDoc d)
|
||||
= runSubscription f svr [] () d
|
||||
runDocumentSubscription f svr d = yieldDocument f svr d
|
||||
@ -153,11 +160,15 @@ instance
|
||||
, KnownSymbol mut
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs
|
||||
, MappingRight chn mut ~ ()
|
||||
, Intro.Introspect p ('Just qr) ('Just mut) 'Nothing
|
||||
) => RunDocument p ('Just qr) ('Just mut) 'Nothing m chn hs where
|
||||
runDocument f svr (QueryDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument f svr (MutationDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument f svr d
|
||||
= let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @'Nothing)
|
||||
in case d of
|
||||
QueryDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
MutationDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
runDocumentSubscription = yieldDocument
|
||||
|
||||
instance
|
||||
@ -168,11 +179,15 @@ instance
|
||||
, KnownSymbol sub
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs
|
||||
, MappingRight chn sub ~ ()
|
||||
, Intro.Introspect p ('Just qr) 'Nothing ('Just sub)
|
||||
) => RunDocument p ('Just qr) 'Nothing ('Just sub) m chn hs where
|
||||
runDocument f svr (QueryDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument _ _ (SubscriptionDoc _)
|
||||
= pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocument f svr d
|
||||
= let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @('Just sub))
|
||||
in case d of
|
||||
QueryDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
SubscriptionDoc _
|
||||
-> pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocumentSubscription f svr (SubscriptionDoc d)
|
||||
= runSubscription f svr [] () d
|
||||
runDocumentSubscription f svr d = yieldDocument f svr d
|
||||
@ -182,51 +197,18 @@ instance
|
||||
, KnownSymbol qr
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs
|
||||
, MappingRight chn qr ~ ()
|
||||
, Intro.Introspect p ('Just qr) 'Nothing 'Nothing
|
||||
) => RunDocument p ('Just qr) 'Nothing 'Nothing m chn hs where
|
||||
runDocument f svr (QueryDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument f svr d
|
||||
= let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing)
|
||||
in case d of
|
||||
QueryDoc q
|
||||
-> runQuery f i svr [] () q
|
||||
runDocumentSubscription = yieldDocument
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss
|
||||
, KnownSymbol mut
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs
|
||||
, MappingRight chn mut ~ ()
|
||||
, KnownSymbol sub
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs
|
||||
, MappingRight chn sub ~ ()
|
||||
) => RunDocument p 'Nothing ('Just mut) ('Just sub) m chn hs where
|
||||
runDocument f svr (MutationDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocument _ _ (SubscriptionDoc _)
|
||||
= pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocumentSubscription f svr (SubscriptionDoc d)
|
||||
= runSubscription f svr [] () d
|
||||
runDocumentSubscription f svr d = yieldDocument f svr d
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss
|
||||
, KnownSymbol mut
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs
|
||||
, MappingRight chn mut ~ ()
|
||||
) => RunDocument p 'Nothing ('Just mut) 'Nothing m chn hs where
|
||||
runDocument f svr (MutationDoc q)
|
||||
= runQuery f svr [] () q
|
||||
runDocumentSubscription = yieldDocument
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss
|
||||
, KnownSymbol sub
|
||||
, RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs
|
||||
, MappingRight chn sub ~ ()
|
||||
) => RunDocument p 'Nothing 'Nothing ('Just sub) m chn hs where
|
||||
runDocument _ _ (SubscriptionDoc _)
|
||||
= pure $ singleErrValue "cannot execute subscriptions in this wire"
|
||||
runDocumentSubscription f svr (SubscriptionDoc d)
|
||||
= runSubscription f svr [] () d
|
||||
|
||||
instance
|
||||
RunDocument p 'Nothing 'Nothing 'Nothing m chn hs where
|
||||
( TypeError ('Text "you need to have a query in your schema")
|
||||
) => RunDocument p 'Nothing mut sub m chn hs where
|
||||
runDocument _ = error "this should never be called"
|
||||
runDocumentSubscription _ = error "this should never be called"
|
||||
|
||||
@ -253,12 +235,12 @@ runQuery
|
||||
, s ~ 'Service sname sanns ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m hs
|
||||
-> Intro.Schema -> ServerT chn p m hs
|
||||
-> [T.Text]
|
||||
-> inh
|
||||
-> ServiceQuery p s
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runQuery f whole@(Services ss) path = runQueryFindHandler f whole path ss
|
||||
runQuery f sch whole@(Services ss) path = runQueryFindHandler f sch whole path ss
|
||||
|
||||
runSubscription
|
||||
:: forall m p s pname ss hs sname sanns ms chn inh.
|
||||
@ -282,7 +264,7 @@ class RunQueryFindHandler m p whole chn ss s hs where
|
||||
, s ~ 'Service sname sanns ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m whole
|
||||
-> Intro.Schema -> ServerT chn p m whole
|
||||
-> [T.Text]
|
||||
-> ServicesT chn ss m hs
|
||||
-> inh
|
||||
@ -308,13 +290,13 @@ instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s)
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
RunQueryFindHandler m p whole chn ss s hs
|
||||
=> RunQueryFindHandler m p whole chn (other ': ss) s (h ': hs) where
|
||||
runQueryFindHandler f whole path (_ :<&>: that)
|
||||
= runQueryFindHandler f whole path that
|
||||
runQueryFindHandler f sch whole path (_ :<&>: that)
|
||||
= runQueryFindHandler f sch whole path that
|
||||
runSubscriptionFindHandler f whole path (_ :<&>: that)
|
||||
= runSubscriptionFindHandler f whole path that
|
||||
instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMethod m p whole chn sname ms h)
|
||||
=> RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where
|
||||
runQueryFindHandler f whole path (this :<&>: _) inh queries
|
||||
runQueryFindHandler f sch whole path (this :<&>: _) inh queries
|
||||
= Aeson.object . catMaybes <$> mapM runOneQuery queries
|
||||
where
|
||||
-- if we include the signature we have to write
|
||||
@ -325,6 +307,21 @@ instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMet
|
||||
runOneQuery (TypeNameQuery nm)
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
in pure $ Just (realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))
|
||||
-- handle __schema
|
||||
runOneQuery (SchemaQuery nm ss)
|
||||
= do let realName = fromMaybe "__schema" nm
|
||||
Just . (realName, ) <$> runIntroSchema path sch ss
|
||||
-- handle __type
|
||||
runOneQuery (TypeQuery nm ty ss)
|
||||
= do let realName = fromMaybe "__schema" nm
|
||||
res <- runIntroType path sch (Intro.TypeRef ty) ss
|
||||
case res of
|
||||
Just val -> pure $ Just (realName, val)
|
||||
Nothing -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "cannot find type '" <> T.unpack ty <> "'")
|
||||
path]
|
||||
pure $ Just (realName, Aeson.Null)
|
||||
-- subscriptions should only have one element
|
||||
runSubscriptionFindHandler f whole path (this :<&>: _) inh (OneMethodQuery nm args) sink
|
||||
= runMethodSubscription f whole (Proxy @sname) path nm inh this args sink
|
||||
@ -332,6 +329,11 @@ instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMet
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))]
|
||||
in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink
|
||||
runSubscriptionFindHandler _ _ _ _ _ _ sink
|
||||
= runConduit $ yieldMany
|
||||
([singleErrValue "__schema and __type are not supported in subscriptions"]
|
||||
:: [Aeson.Value])
|
||||
.| sink
|
||||
|
||||
class RunMethod m p whole chn sname ms hs where
|
||||
runMethod
|
||||
@ -464,19 +466,6 @@ instance (MonadIO m, MonadError ServerError m, ResultConversion m p whole chn r
|
||||
_ -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_)
|
||||
, ("errors", Aeson.listValue errValue errors) ]
|
||||
|
||||
mapInputM :: Monad m
|
||||
=> (i1 -> m i2) -- ^ map initial input to new input
|
||||
-> (i2 -> m (Maybe i1)) -- ^ map new leftovers to initial leftovers
|
||||
-> ConduitT i2 o m r
|
||||
-> ConduitT i1 o m r
|
||||
mapInputM f f' (ConduitT c0) = ConduitT $ \rest -> let
|
||||
go (HaveOutput p o) = HaveOutput (go p) o
|
||||
go (NeedInput p c) = NeedInput (\i -> PipeM $ go . p <$> f i) (go . c)
|
||||
go (Done r) = rest r
|
||||
go (PipeM mp) = PipeM $ fmap go mp
|
||||
go (Leftover p i) = PipeM $ (\x -> maybe id (flip Leftover) x (go p)) <$> f' i
|
||||
in go (c0 Done)
|
||||
|
||||
class FromRef chn ref t
|
||||
=> ArgumentConversion chn ref t where
|
||||
convertArg :: Proxy chn -> ArgumentValue' p ref -> t
|
||||
@ -512,7 +501,9 @@ instance ( MappingRight chn ref ~ t
|
||||
, RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname sanns ms) whole)
|
||||
=> ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where
|
||||
convertResult f whole path (RetObject q) h
|
||||
= Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f whole path h q
|
||||
= Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f
|
||||
(error "cannot inspect schema inside a field")
|
||||
whole path h q
|
||||
instance ResultConversion m p whole chn r s
|
||||
=> ResultConversion m p whole chn ('OptionalRef r) (Maybe s) where
|
||||
convertResult _ _ _ _ Nothing
|
||||
@ -532,7 +523,7 @@ class RunSchemaQuery sch r where
|
||||
instance ( Aeson.ToJSON (Term sch ('DEnum name choices)) )
|
||||
=> RunSchemaQuery sch ('DEnum name choices) where
|
||||
runSchemaQuery t _ = Aeson.toJSON t
|
||||
instance ( RunSchemaField sch fields )
|
||||
instance ( KnownName rname, RunSchemaField sch fields )
|
||||
=> RunSchemaQuery sch ('DRecord rname fields) where
|
||||
runSchemaQuery (TRecord args) (QueryRecord rs)
|
||||
= Aeson.object $ mapMaybe runOneQuery rs
|
||||
@ -541,6 +532,11 @@ instance ( RunSchemaField sch fields )
|
||||
= let (val, fname) = runSchemaField args choice
|
||||
realName = fromMaybe fname nm
|
||||
in (realName,) <$> val
|
||||
runOneQuery (TypeNameFieldQuery nm)
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
-- add the 'R' because it's on return position
|
||||
in pure (realName, Aeson.String $ T.pack $ nameVal (Proxy @rname) ++ "R")
|
||||
|
||||
|
||||
class RunSchemaField sch args where
|
||||
runSchemaField
|
||||
@ -578,3 +574,192 @@ instance RunSchemaQuery sch (sch :/: l)
|
||||
=> RunSchemaType sch ('TSchematic l) where
|
||||
runSchemaType (FSchematic t) (RetSchSchema r)
|
||||
= Just $ runSchemaQuery t r
|
||||
|
||||
|
||||
runIntroSchema
|
||||
:: [T.Text] -> Intro.Schema -> GQL.SelectionSet
|
||||
-> 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))
|
||||
= let realName :: T.Text = fromMaybe nm alias
|
||||
path' = path ++ [realName]
|
||||
in fmap (realName,) <$> case nm of
|
||||
"description"
|
||||
-> pure $ Just Aeson.Null
|
||||
"directives"
|
||||
-> pure $ Just $ Aeson.Array []
|
||||
"queryType"
|
||||
-> case qr >>= flip HM.lookup ts of
|
||||
Nothing -> pure Nothing
|
||||
Just ty -> runIntroType path' s ty innerss
|
||||
"mutationType"
|
||||
-> case mut >>= flip HM.lookup ts of
|
||||
Nothing -> pure Nothing
|
||||
Just ty -> runIntroType path' s ty innerss
|
||||
"subscriptionType"
|
||||
-> case sub >>= flip HM.lookup ts of
|
||||
Nothing -> pure Nothing
|
||||
Just ty -> runIntroType path' s ty innerss
|
||||
"types"
|
||||
-> do tys <- catMaybes <$> mapM (\t -> runIntroType path' s t innerss) (HM.elems ts)
|
||||
pure $ Just $ Aeson.toJSON tys
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "field '" <> T.unpack nm <> "' was not found on type '__Schema'")
|
||||
path]
|
||||
pure Nothing
|
||||
-- we do not support spreads here
|
||||
runOne _ = pure Nothing
|
||||
|
||||
runIntroType
|
||||
:: [T.Text] -> Intro.Schema -> Intro.Type -> GQL.SelectionSet
|
||||
-> WriterT [GraphQLError] IO (Maybe Aeson.Value)
|
||||
runIntroType path s@(Intro.Schema _ _ _ ts) (Intro.TypeRef t) ss
|
||||
= case HM.lookup t ts of
|
||||
Nothing -> pure Nothing
|
||||
Just ty -> runIntroType path s ty ss
|
||||
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))
|
||||
= let realName :: T.Text = fromMaybe nm alias
|
||||
path' = path ++ [realName]
|
||||
in fmap (realName,) <$> case (nm, innerss) of
|
||||
("kind", [])
|
||||
-> pure $ Just $ Aeson.String $ T.pack (show k)
|
||||
("name", [])
|
||||
-> pure $ Just $ maybe Aeson.Null Aeson.String tnm
|
||||
("description", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
|
||||
("fields", _)
|
||||
-> case k of
|
||||
Intro.OBJECT
|
||||
-> do things <- mapM (\f -> runIntroFields path' f innerss) fs
|
||||
pure $ Just $ Aeson.toJSON things
|
||||
_ -> pure $ Just Aeson.Null
|
||||
("inputFields", _)
|
||||
-> case k of
|
||||
Intro.INPUT_OBJECT
|
||||
-> do things <- mapM (\f -> runIntroFields path' f innerss) fs
|
||||
pure $ Just $ Aeson.toJSON things
|
||||
_ -> pure $ Just Aeson.Null
|
||||
("enumValues", _)
|
||||
-> do things <- mapM (\e -> runIntroEnums path' e innerss) vals
|
||||
pure $ Just $ Aeson.toJSON things
|
||||
|
||||
("ofType", _)
|
||||
-> case ofT of
|
||||
Nothing -> pure $ Just Aeson.Null
|
||||
Just o -> runIntroType path' s o innerss
|
||||
|
||||
-- unions and interfaces are not supported
|
||||
("interfaces", _)
|
||||
-> pure $ Just $ Aeson.Array []
|
||||
("possibleTypes", _)
|
||||
-> pure $ Just $ Aeson.Array []
|
||||
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "field '" <> T.unpack nm <> "' was not found on type '__Type'")
|
||||
path]
|
||||
pure Nothing
|
||||
-- we do not support spreads here
|
||||
runOne _ = pure Nothing
|
||||
|
||||
runIntroFields
|
||||
:: [T.Text] -> Intro.Field -> GQL.SelectionSet
|
||||
-> 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))
|
||||
= let realName :: T.Text = fromMaybe nm alias
|
||||
fpath' = fpath ++ [realName]
|
||||
in fmap (realName,) <$> case (nm, innerss) of
|
||||
("name", [])
|
||||
-> pure $ Just $ Aeson.String fnm
|
||||
("description", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
("isDeprecated", [])
|
||||
-> pure $ Just $ Aeson.Bool False
|
||||
("deprecationReason", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
|
||||
("type", _)
|
||||
-> runIntroType fpath' s fty innerss
|
||||
("args", _)
|
||||
-> do things <- mapM (\i -> runIntroInputs fpath' i innerss) fargs
|
||||
pure $ Just $ Aeson.toJSON things
|
||||
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "field '" <> T.unpack nm <> "' was not found on type '__Field'")
|
||||
fpath]
|
||||
pure Nothing
|
||||
-- we do not support spreads here
|
||||
runIntroField _ _ _ = pure Nothing
|
||||
|
||||
runIntroEnums
|
||||
:: [T.Text] -> Intro.EnumValue -> GQL.SelectionSet
|
||||
-> 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))
|
||||
= let realName :: T.Text = fromMaybe nm alias
|
||||
in fmap (realName,) <$> case (nm, innerss) of
|
||||
("name", [])
|
||||
-> pure $ Just $ Aeson.String enm
|
||||
("description", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
("isDeprecated", [])
|
||||
-> pure $ Just $ Aeson.Bool False
|
||||
("deprecationReason", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "field '" <> T.unpack nm <> "' was not found on type '__EnumValue'")
|
||||
epath]
|
||||
pure Nothing
|
||||
-- we do not support spreads here
|
||||
runIntroEnum _ _ _ = pure Nothing
|
||||
|
||||
runIntroInputs
|
||||
:: [T.Text] -> Intro.Input -> GQL.SelectionSet
|
||||
-> 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))
|
||||
= let realName :: T.Text = fromMaybe nm alias
|
||||
ipath' = ipath ++ [realName]
|
||||
in fmap (realName,) <$> case (nm, innerss) of
|
||||
("name", [])
|
||||
-> pure $ Just $ Aeson.String inm
|
||||
("description", [])
|
||||
-> pure $ Just Aeson.Null
|
||||
("defaultValue", [])
|
||||
-> pure $ Just $ maybe Aeson.Null Aeson.String def
|
||||
|
||||
("type", _)
|
||||
-> runIntroType ipath' s ty innerss
|
||||
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
$ "field '" <> T.unpack nm <> "' was not found on type '__Field'")
|
||||
ipath]
|
||||
pure Nothing
|
||||
-- we do not support spreads here
|
||||
runIntroInput _ _ _ = pure Nothing
|
||||
|
@ -21,6 +21,7 @@ packages:
|
||||
- compendium-client
|
||||
|
||||
extra-deps:
|
||||
- conduit-1.3.2
|
||||
- http2-client-0.9.0.0
|
||||
- http2-grpc-types-0.5.0.0
|
||||
- proto3-wire-1.1.0
|
||||
|
@ -21,6 +21,7 @@ packages:
|
||||
- compendium-client
|
||||
|
||||
extra-deps:
|
||||
- conduit-1.3.2
|
||||
- http2-client-0.9.0.0
|
||||
- http2-grpc-types-0.5.0.0
|
||||
- proto3-wire-1.1.0
|
||||
|
Loading…
Reference in New Issue
Block a user