GraphQL introspection (#153)

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

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

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

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)

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

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

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

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