From 5954d26cb85835298760981c19594f8704b0b7b3 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Wed, 25 Mar 2020 13:37:30 +0100 Subject: [PATCH] GraphQL introspection (#153) --- graphql/exe/Main.hs | 2 +- graphql/mu-graphql.cabal | 1 + graphql/src/Mu/GraphQL/Query/Definition.hs | 15 + graphql/src/Mu/GraphQL/Query/Introspection.hs | 311 ++++++++++++++++ graphql/src/Mu/GraphQL/Query/Parse.hs | 40 ++- graphql/src/Mu/GraphQL/Query/Run.hs | 339 ++++++++++++++---- stack-nightly.yaml | 1 + stack.yaml | 1 + 8 files changed, 629 insertions(+), 81 deletions(-) create mode 100644 graphql/src/Mu/GraphQL/Query/Introspection.hs diff --git a/graphql/exe/Main.hs b/graphql/exe/Main.hs index 3d334ac..47a008e 100644 --- a/graphql/exe/Main.hs +++ b/graphql/exe/Main.hs @@ -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 diff --git a/graphql/mu-graphql.cabal b/graphql/mu-graphql.cabal index ab56811..61748fd 100644 --- a/graphql/mu-graphql.cabal +++ b/graphql/mu-graphql.cabal @@ -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 diff --git a/graphql/src/Mu/GraphQL/Query/Definition.hs b/graphql/src/Mu/GraphQL/Query/Definition.hs index e4b509e..c4e87f4 100644 --- a/graphql/src/Mu/GraphQL/Query/Definition.hs +++ b/graphql/src/Mu/GraphQL/Query/Definition.hs @@ -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 diff --git a/graphql/src/Mu/GraphQL/Query/Introspection.hs b/graphql/src/Mu/GraphQL/Query/Introspection.hs new file mode 100644 index 0000000..7064128 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Query/Introspection.hs @@ -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) diff --git a/graphql/src/Mu/GraphQL/Query/Parse.hs b/graphql/src/Mu/GraphQL/Query/Parse.hs index 87dd543..880d88b 100644 --- a/graphql/src/Mu/GraphQL/Query/Parse.hs +++ b/graphql/src/Mu/GraphQL/Query/Parse.hs @@ -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 diff --git a/graphql/src/Mu/GraphQL/Query/Run.hs b/graphql/src/Mu/GraphQL/Query/Run.hs index fb43ff9..d6081a5 100644 --- a/graphql/src/Mu/GraphQL/Query/Run.hs +++ b/graphql/src/Mu/GraphQL/Query/Run.hs @@ -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 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 18a96ac..d750502 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -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 diff --git a/stack.yaml b/stack.yaml index 084f16a..ccad065 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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