mu-graphql 0.4.1.0 → 0.5.0.0
raw patch · 9 files changed
+371/−168 lines, 9 filesdep ~mu-rpcsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: mu-rpc
API changes (from Hackage documentation)
Files
- Setup.hs +1/−1
- exe/Main.hs +44/−14
- exe/schema.graphql +10/−1
- mu-graphql.cabal +6/−5
- src/Mu/GraphQL/Quasi.hs +31/−19
- src/Mu/GraphQL/Query/Definition.hs +16/−6
- src/Mu/GraphQL/Query/Introspection.hs +47/−14
- src/Mu/GraphQL/Query/Parse.hs +114/−80
- src/Mu/GraphQL/Query/Run.hs +102/−28
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
exe/Main.hs view
@@ -1,6 +1,7 @@ {-# language CPP #-} {-# language DataKinds #-} {-# language FlexibleContexts #-}+{-# language LambdaCase #-} {-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} {-# language PolyKinds #-}@@ -14,6 +15,7 @@ module Main where +import qualified Data.Aeson as JSON import Data.Conduit import Data.Conduit.Combinators (yieldMany) import Data.List (find)@@ -51,50 +53,78 @@ (Proxy @'Nothing) (Proxy @('Just "Subscription")) +data WritingMapping+ = ABook (Integer, Integer) | AnArticle (Integer, Integer)+ type ServiceMapping = '[- "Book" ':-> (Integer, Integer)- , "Author" ':-> Integer+ "Book" ':-> (Integer, Integer)+ , "Article" ':-> (Integer, Integer)+ , "Author" ':-> Integer+ , "Writing" ':-> WritingMapping ] -library :: [(Integer, T.Text, [(Integer, T.Text)])]+library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])] library- = [ (1, "Robert Louis Stevenson", [(1, "Treasure Island"), (2, "Strange Case of Dr Jekyll and Mr Hyde")])- , (2, "Immanuel Kant", [(3, "Critique of Pure Reason")])- , (3, "Michael Ende", [(4, "The Neverending Story"), (5, "Momo")])+ = [ (1, "Robert Louis Stevenson", [(1, ("Treasure Island", 4)), (2, ("Strange Case of Dr Jekyll and Mr Hyde", 4))])+ , (2, "Immanuel Kant", [(3, ("Critique of Pure Reason", 1))])+ , (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))]) ] +articles :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]+articles+ = [ (1, "Fuencislo Robles", [(6, ("On Warm Chocolate", 4)), (2, ("On Cold Chocolate", 4))]) ]+ libraryServer :: forall m i. (MonadServer m) => ServerT ServiceMapping i ServiceDefinition m _ libraryServer- = resolver ( object @"Book" ( field @"id" bookId+ = resolver ( object @"Book" ( field @"id" bookOrArticleId , field @"title" bookTitle- , field @"author" bookAuthor )+ , field @"author" bookOrArticleAuthor+ , field @"info" bookInfo )+ , object @"Article" ( field @"id" bookOrArticleId+ , field @"title" articleTitle+ , field @"author" bookOrArticleAuthor ) , object @"Author" ( field @"id" authorId , field @"name" authorName- , field @"books" authorBooks )+ , field @"writings" authorBooks ) , object @"Query" ( method @"author" findAuthor , method @"book" findBookTitle , method @"authors" allAuthors , method @"books" allBooks' ) , object @"Subscription" ( method @"books" allBooksConduit )+ , union @"Writing" (\case (ABook x) -> pure $ unionChoice @"Book" x+ (AnArticle x) -> pure $ unionChoice @"Article" x) ) where findBook i = find ((==i) . fst3) library+ findArticle i = find ((==i) . fst3) articles - bookId (_, bid) = pure bid- bookTitle (aid, bid) = pure $ maybe "" (fromMaybe "" . lookup bid . thd3) (findBook aid)- bookAuthor (aid, _) = pure aid+ bookOrArticleId (_, bid) = pure bid+ bookOrArticleAuthor (aid, _) = pure aid+ bookTitle (aid, bid) = pure $ fromMaybe "" $ do+ bk <- findBook aid+ ev <- lookup bid (thd3 bk)+ pure (fst ev)+ bookInfo (aid, bid) = pure $ do+ bk <- findBook aid+ ev <- lookup bid (thd3 bk)+ pure $ JSON.object ["score" JSON..= snd ev]+ articleTitle (aid, bid) = pure $ fromMaybe "" $ do+ bk <- findArticle aid+ ev <- lookup bid (thd3 bk)+ pure (fst ev) authorId = pure authorName aid = pure $ maybe "" snd3 (findBook aid)- authorBooks aid = pure $ maybe [] (map ((aid,) . fst) . thd3) (findBook aid)+ authorBooks aid = pure $ maybe [] (map (ABook . (aid,) . fst) . thd3) (findBook aid)+ <> maybe [] (map (AnArticle . (aid,) . fst) . thd3) (findArticle aid) findAuthor rx = pure $ listToMaybe [aid | (aid, name, _) <- library, name =~ rx] findBookTitle rx = pure $ listToMaybe [(aid, bid) | (aid, _, books) <- library- , (bid, title) <- books+ , (bid, (title, _)) <- books , title =~ rx] allAuthors = pure $ fst3 <$> library
exe/schema.graphql view
@@ -2,12 +2,21 @@ id: Int! title: String! author: Author!+ info: JSON } +type Article {+ id: Int!+ title: String!+ author: Author!+}++union Writing = Book | Article+ type Author { id: Int! name: String!- books: [Book!]!+ writings: [Writing!]! } type Query {
mu-graphql.cabal view
@@ -1,5 +1,5 @@ name: mu-graphql-version: 0.4.1.0+version: 0.5.0.0 synopsis: GraphQL support for Mu description: GraphQL servers and clients for Mu-Haskell cabal-version: >=1.10@@ -40,8 +40,8 @@ , list-t >=1.0 && <2 , megaparsec >=8 && <10 , mtl >=2.2 && <2.3- , mu-rpc ==0.4.*- , mu-schema ==0.3.*+ , mu-rpc >=0.5 && <0.6+ , mu-schema >=0.3 && <0.4 , parsers >=0.12 && <0.13 , scientific >=0.3 && <0.4 , sop-core >=0.5 && <0.6@@ -70,10 +70,11 @@ ghc-options: -Wall -threaded build-depends: base >=4.12 && <5+ , aeson >=1.4 && <2 , conduit >=1.3.2 && <1.4 , mu-graphql- , mu-rpc ==0.4.*- , mu-schema ==0.3.*+ , mu-rpc >=0.5 && <0.6+ , mu-schema >=0.3 && <0.4 , regex-tdfa >=1.3 && <2 , text >=1.2 && <2 , wai-extra >=3 && <4
src/Mu/GraphQL/Quasi.hs view
@@ -15,6 +15,7 @@ ) where import Control.Monad.IO.Class (liftIO)+import qualified Data.Aeson as JSON import Data.Foldable (toList) import qualified Data.HashMap.Strict as HM import Data.List (foldl')@@ -60,7 +61,8 @@ | Object | Scalar | InputObject- | Other+ | Union+ | Interface classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap classifySchema = foldl' schemaToMap HM.empty@@ -80,9 +82,9 @@ typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _) = (name, Object) typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _)- = (name, Other)+ = (name, Interface) typeToKeyValue (GQL.UnionTypeDefinition _ name _ _)- = (name, Other)+ = (name, Union) typeToKeyValue (GQL.EnumTypeDefinition _ name _ _) = (name, Enum) typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _)@@ -117,8 +119,11 @@ typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result typeToDec _ _ _ GQL.InterfaceTypeDefinition {} = fail "interface types are not supported"-typeToDec _ _ _ GQL.UnionTypeDefinition {}- = fail "union types are not supported"+typeToDec _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do+ selts <- mapM textToStrLit elts+ GQLService <$> [t| 'OneOf $(textToStrLit nm)+ $(pure $ typesToList selts) |]+ <*> pure [] typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = GQLScalar <$ gqlTypeToType s tm schemaName typeToDec schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do@@ -189,25 +194,32 @@ ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = [t| $(typeToPrimType a) |] ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) =- [t| 'ListRef $(ginputTypeToType a) |]+ [t| 'TList $(ginputTypeToType a) |] ginputTypeToType (GQL.TypeNamed a) =- [t| 'OptionalRef $(typeToPrimType a) |]+ [t| 'TOption $(typeToPrimType a) |] ginputTypeToType (GQL.TypeList a) =- [t| 'OptionalRef ('ListRef $(ginputTypeToType a)) |]+ [t| 'TOption ('TList $(ginputTypeToType a)) |] typeToPrimType :: GQL.Name -> Q Type- typeToPrimType "Int" = [t|'TPrimitive Integer|]- typeToPrimType "Float" = [t|'TPrimitive Double|]- typeToPrimType "String" = [t|'TPrimitive T.Text|]- typeToPrimType "Boolean" = [t|'TPrimitive Bool|]- typeToPrimType "ID" = [t|'TPrimitive UUID|]- typeToPrimType nm = [t|'TSchematic $(textToStrLit nm)|]+ typeToPrimType "Int" = [t|'TPrimitive Integer|]+ typeToPrimType "Float" = [t|'TPrimitive Double|]+ typeToPrimType "String" = [t|'TPrimitive T.Text|]+ typeToPrimType "Boolean" = [t|'TPrimitive Bool|]+ typeToPrimType "ID" = [t|'TPrimitive UUID|]+ typeToPrimType "JSON" = [t|'TPrimitive JSON.Value|]+ typeToPrimType "JSONObject" = [t|'TPrimitive JSON.Object|]+ typeToPrimType nm = [t|'TSchematic $(textToStrLit nm)|] +-- For the JSON scalar we follow+-- https://github.com/taion/graphql-type-json+ gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type-gqlTypeToType "Int" _ _ = [t|'PrimitiveRef Integer|]-gqlTypeToType "Float" _ _ = [t|'PrimitiveRef Double|]-gqlTypeToType "String" _ _ = [t|'PrimitiveRef T.Text|]-gqlTypeToType "Boolean" _ _ = [t|'PrimitiveRef Bool|]-gqlTypeToType "ID" _ _ = [t|'PrimitiveRef UUID|]+gqlTypeToType "Int" _ _ = [t|'PrimitiveRef Integer|]+gqlTypeToType "Float" _ _ = [t|'PrimitiveRef Double|]+gqlTypeToType "String" _ _ = [t|'PrimitiveRef T.Text|]+gqlTypeToType "Boolean" _ _ = [t|'PrimitiveRef Bool|]+gqlTypeToType "ID" _ _ = [t|'PrimitiveRef UUID|]+gqlTypeToType "JSON" _ _ = [t|'PrimitiveRef JSON.Value|]+gqlTypeToType "JSONObject" _ _ = [t|'PrimitiveRef JSON.Object|] gqlTypeToType name tm schemaName = let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] in case HM.lookup name tm of
src/Mu/GraphQL/Query/Definition.hs view
@@ -8,6 +8,7 @@ import Data.SOP.NP import Data.SOP.NS import Data.Text+import Data.Typeable import qualified Language.GraphQL.AST as GQL import Mu.Rpc import Mu.Schema@@ -27,9 +28,12 @@ => OneMethodQuery ('Package pname ss) (LookupService ss sub) -> Document ('Package pname ss) qr mut ('Just sub) -type ServiceQuery (p :: Package snm mnm anm (TypeRef snm))- (s :: Service snm mnm anm (TypeRef snm))- = [OneMethodQuery p s]+data ServiceQuery (p :: Package snm mnm anm (TypeRef snm))+ (s :: Service snm mnm anm (TypeRef snm)) where+ ServiceQuery :: [OneMethodQuery p ('Service nm ms)]+ -> ServiceQuery p ('Service nm ms)+ OneOfQuery :: NP (ChosenOneOfQuery p) elts+ -> ServiceQuery p ('OneOf nm elts) data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm)) (s :: Service snm mnm anm (TypeRef snm)) where@@ -40,17 +44,23 @@ -- the special '__typename' field TypeNameQuery :: Maybe Text- -> OneMethodQuery p ('Service nm ms)+ -> OneMethodQuery p s -- introspection fields SchemaQuery :: Maybe Text -> [GQL.Selection]- -> OneMethodQuery p ('Service nm ms)+ -> OneMethodQuery p s TypeQuery :: Maybe Text -> Text -> [GQL.Selection]- -> OneMethodQuery p ('Service nm ms)+ -> OneMethodQuery p s++data ChosenOneOfQuery p elt where+ ChosenOneOfQuery+ :: Typeable elt => Proxy elt+ -> ServiceQuery ('Package pname ss) (LookupService ss elt)+ -> ChosenOneOfQuery ('Package pname ss) elt data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm)) (m :: Method snm mnm anm (TypeRef snm)) where
src/Mu/GraphQL/Query/Introspection.hs view
@@ -11,6 +11,7 @@ module Mu.GraphQL.Query.Introspection where import Control.Monad.Writer+import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as S import Data.Int (Int32)@@ -32,11 +33,12 @@ data Type = Type- { kind :: TypeKind- , typeName :: Maybe T.Text- , fields :: [Field]- , enumValues :: [EnumValue]- , ofType :: Maybe Type+ { kind :: TypeKind+ , typeName :: Maybe T.Text+ , fields :: [Field]+ , enumValues :: [EnumValue]+ , possibleTypes :: [Type]+ , ofType :: Maybe Type } | TypeRef { to :: T.Text } deriving Show@@ -73,17 +75,17 @@ deriving Show tSimple :: T.Text -> Type-tSimple t = Type SCALAR (Just t) [] [] Nothing+tSimple t = Type SCALAR (Just t) [] [] [] Nothing tList :: Type -> Type-tList = Type LIST Nothing [] [] . Just+tList = Type LIST Nothing [] [] [] . Just tNonNull :: Type -> Type-tNonNull = Type NON_NULL Nothing [] [] . Just+tNonNull = Type NON_NULL Nothing [] [] [] . Just unwrapNonNull :: Type -> Maybe Type-unwrapNonNull (Type NON_NULL _ _ _ x) = x-unwrapNonNull _ = Nothing+unwrapNonNull (Type NON_NULL _ _ _ _ x) = x+unwrapNonNull _ = Nothing -- BUILD INTROSPECTION DATA -- ========================@@ -104,7 +106,10 @@ = let (_, ts) = runWriter $ introspectServices (Proxy @ss) (Proxy @sub) >> tell (HM.fromList (- (\i -> (i, tSimple i)) <$> ["Null", "Int", "Float", "String", "Boolean", "ID"]))+ (\i -> (i, tSimple i))+ <$> [ "Null", "Int", "Float"+ , "String", "Boolean", "ID"+ , "JSON", "JSONObject" ] )) -- return only reachable types qrS = maybeSymbolVal (Proxy @qr) mutS = maybeSymbolVal (Proxy @mut)@@ -171,12 +176,32 @@ 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+ 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 +instance ( KnownSymbol sname, KnownSymbols elts+ , IntrospectServices ss sub )+ => IntrospectServices ('OneOf sname elts ': ss) sub where+ introspectServices _ psub = do+ let name = T.pack $ symbolVal (Proxy @sname)+ tys = map tSimple (symbolsVal (Proxy @elts))+ t = Type UNION (Just name) [] [] tys Nothing+ -- add this one to the mix+ tell (HM.singleton name t)+ -- continue with the rest+ introspectServices (Proxy @ss) psub++class KnownSymbols (ss :: [Symbol]) where+ symbolsVal :: Proxy ss -> [T.Text]+instance KnownSymbols '[] where+ symbolsVal _ = []+instance (KnownSymbol s, KnownSymbols ss)+ => KnownSymbols (s ': ss) where+ symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)+ class IntrospectFields (fs :: [Method']) (isSub :: Bool) where introspectFields :: Proxy fs -> Proxy isSub -> Writer TypeMap [Field]@@ -252,6 +277,10 @@ introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String" instance IntrospectTypeRef ('PrimitiveRef T.Text) where introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String"+instance IntrospectTypeRef ('PrimitiveRef JSON.Value) where+ introspectTypeRef _ _ = pure $ tNonNull $ tSimple "JSON"+instance IntrospectTypeRef ('PrimitiveRef JSON.Object) where+ introspectTypeRef _ _ = pure $ tNonNull $ tSimple "JSONObject" instance (IntrospectTypeRef r) => IntrospectTypeRef ('ListRef r) where@@ -284,7 +313,7 @@ introspectSchema k suffix _ = do let name = T.pack (symbolVal (Proxy @name)) <> suffix fs = introspectSchemaFields suffix (Proxy @fields)- t = Type k (Just name) fs [] Nothing+ t = Type k (Just name) fs [] [] Nothing -- add this one to the mix tell (HM.singleton name t) -- continue with the rest@@ -294,7 +323,7 @@ introspectSchema k suffix _ = do let name = T.pack (symbolVal (Proxy @name)) <> suffix cs = introspectSchemaEnum (Proxy @choices)- t = Type ENUM (Just name) [] cs Nothing+ t = Type ENUM (Just name) [] cs [] Nothing -- add this one to the mix tell (HM.singleton name t) -- continue with the rest@@ -329,6 +358,10 @@ introspectSchemaFieldType _ _ = tNonNull $ tSimple "String" instance IntrospectSchemaFieldType ('Mu.TPrimitive T.Text) where introspectSchemaFieldType _ _ = tNonNull $ tSimple "String"+instance IntrospectSchemaFieldType ('Mu.TPrimitive JSON.Value) where+ introspectSchemaFieldType _ _ = tNonNull $ tSimple "JSON"+instance IntrospectSchemaFieldType ('Mu.TPrimitive JSON.Object) where+ introspectSchemaFieldType _ _ = tNonNull $ tSimple "JSONObject" instance (IntrospectSchemaFieldType r) => IntrospectSchemaFieldType ('Mu.TList r) where
src/Mu/GraphQL/Query/Parse.hs view
@@ -139,14 +139,15 @@ KnownName sub, ParseMethod p ('Service sub smethods) smethods ) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where parseTypedDocQuery vmap frmap sset- = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset parseTypedDocMutation vmap frmap sset- = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset parseTypedDocSubscription vmap frmap sset- = do q <- parseQuery Proxy Proxy vmap frmap sset+ = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset case q of- [one] -> pure $ SubscriptionDoc one- _ -> throwError "subscriptions may only have one field"+ ServiceQuery [one]+ -> pure $ SubscriptionDoc one+ _ -> throwError "subscriptions may only have one field" instance ( p ~ 'Package pname ss,@@ -156,9 +157,9 @@ KnownName mut, ParseMethod p ('Service mut mmethods) mmethods ) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where parseTypedDocQuery vmap frmap sset- = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset parseTypedDocMutation vmap frmap sset- = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset parseTypedDocSubscription _ _ _ = throwError "no subscriptions are defined in the schema" @@ -170,14 +171,15 @@ KnownName sub, ParseMethod p ('Service sub smethods) smethods ) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where parseTypedDocQuery vmap frmap sset- = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset parseTypedDocMutation _ _ _ = throwError "no mutations are defined in the schema" parseTypedDocSubscription vmap frmap sset- = do q <- parseQuery Proxy Proxy vmap frmap sset+ = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset case q of- [one] -> pure $ SubscriptionDoc one- _ -> throwError "subscriptions may only have one field"+ ServiceQuery [one]+ -> pure $ SubscriptionDoc one+ _ -> throwError "subscriptions may only have one field" instance ( p ~ 'Package pname ss,@@ -185,7 +187,7 @@ KnownName qr, ParseMethod p ('Service qr qmethods) qmethods ) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where parseTypedDocQuery vmap frmap sset- = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset parseTypedDocMutation _ _ _ = throwError "no mutations are defined in the schema" parseTypedDocSubscription _ _ _@@ -201,12 +203,13 @@ parseTypedDocQuery _ _ _ = throwError "no queries are defined in the schema" parseTypedDocMutation vmap frmap sset- = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset parseTypedDocSubscription vmap frmap sset- = do q <- parseQuery Proxy Proxy vmap frmap sset+ = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset case q of- [one] -> pure $ SubscriptionDoc one- _ -> throwError "subscriptions may only have one field"+ ServiceQuery [one]+ -> pure $ SubscriptionDoc one+ _ -> throwError "subscriptions may only have one field" instance ( p ~ 'Package pname ss,@@ -216,7 +219,7 @@ parseTypedDocQuery _ _ _ = throwError "no queries are defined in the schema" parseTypedDocMutation vmap frmap sset- = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset+ = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset parseTypedDocSubscription _ _ _ = throwError "no subscriptions are defined in the schema" @@ -230,10 +233,11 @@ parseTypedDocMutation _ _ _ = throwError "no mutations are defined in the schema" parseTypedDocSubscription vmap frmap sset- = do q <- parseQuery Proxy Proxy vmap frmap sset+ = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset case q of- [one] -> pure $ SubscriptionDoc one- _ -> throwError "subscriptions may only have one field"+ ServiceQuery [one]+ -> pure $ SubscriptionDoc one+ _ -> throwError "subscriptions may only have one field" instance ParseTypedDoc p 'Nothing 'Nothing 'Nothing where@@ -263,60 +267,92 @@ [ GQL.ObjectField a (GQL.Node (constToValue v) m) l | GQL.ObjectField a (GQL.Node v m) l <- n ] +class ParseQuery (p :: Package') (s :: Symbol) where+ parseQuery+ :: ( MonadError T.Text f, p ~ 'Package pname ss )+ => Proxy p -> Proxy s+ -> VariableMap -> FragmentMap -> [GQL.Selection]+ -> f (ServiceQuery p (LookupService ss s)) -parseQuery ::- forall (p :: Package') (s :: Symbol) pname ss methods f.- ( MonadError T.Text f, p ~ 'Package pname ss,- LookupService ss s ~ 'Service s methods,- KnownName s, ParseMethod p ('Service s methods) methods- ) =>- Proxy p ->- Proxy s ->- VariableMap -> FragmentMap -> [GQL.Selection] ->- f (ServiceQuery p (LookupService ss s))-parseQuery _ _ _ _ [] = pure []-parseQuery pp ps vmap frmap (GQL.FieldSelection fld : ss)- = (++) <$> (maybeToList <$> fieldToMethod fld)- <*> parseQuery pp ps vmap frmap ss- where- fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))- fieldToMethod f@(GQL.Field alias name args dirs sels _)- | any (shouldSkip vmap) dirs- = pure Nothing- | name == "__typename"- = case (args, sels) of- ([], []) -> pure $ Just $ TypeNameQuery alias- _ -> throwError "__typename does not admit arguments nor selection of subfields"- | name == "__schema"- = case args of- [] -> Just . SchemaQuery alias <$> unFragment frmap (F.toList sels)- _ -> throwError "__schema does not admit selection of subfields"- | name == "__type"- = let getString (GQL.String s) = Just s- getString (GQL.Variable v) = HM.lookup v vmap >>= getString- getString _ = Nothing- in case args of- [GQL.Argument _ (GQL.Node 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 alias- <$> selectMethod (Proxy @('Service s methods))- (T.pack $ nameVal (Proxy @s))- vmap frmap f-parseQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)- | Just fr <- HM.lookup nm frmap- = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)- then (++) <$> parseQuery pp ps vmap frmap (fdSelectionSet fr)- <*> parseQuery pp ps vmap frmap ss- else parseQuery pp ps vmap frmap ss- | otherwise -- the fragment definition was not found- = throwError $ "fragment '" <> nm <> "' was not found"-parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported- = throwError "inline fragments are not (yet) supported"+instance ( p ~ 'Package pname ss+ , KnownName s+ , ParseQuery' p s (LookupService ss s) )+ => ParseQuery p s where+ parseQuery pp ps = parseQuery' pp ps (Proxy @(LookupService ss s)) +class ParseQuery' (p :: Package') (s :: Symbol) (svc :: Service') where+ parseQuery'+ :: ( MonadError T.Text f, p ~ 'Package pname ss+ , LookupService ss s ~ svc, KnownName s )+ => Proxy p -> Proxy s -> Proxy svc+ -> VariableMap -> FragmentMap -> [GQL.Selection]+ -> f (ServiceQuery p svc)++instance (ParseQueryOneOf p elts)+ => ParseQuery' p s ('OneOf s elts) where+ parseQuery' pp _ps _ vmap frmap fs+ = OneOfQuery <$> parseQueryOneOf pp (Proxy @elts) vmap frmap fs++class ParseQueryOneOf (p :: Package') (s :: [Symbol]) where+ parseQueryOneOf+ :: ( MonadError T.Text f, p ~ 'Package pname ss )+ => Proxy p -> Proxy s+ -> VariableMap -> FragmentMap -> [GQL.Selection]+ -> f (NP (ChosenOneOfQuery p) s)++instance ParseQueryOneOf p '[] where+ parseQueryOneOf _ _ _ _ _ = pure Nil+instance ( ParseQuery p s, KnownSymbol s+ , ParseQueryOneOf p ss)+ => ParseQueryOneOf p (s ': ss) where+ parseQueryOneOf pp _ps vmap frmap sel+ = (:*) <$> (ChosenOneOfQuery (Proxy @s) <$> parseQuery pp (Proxy @s) vmap frmap sel)+ <*> parseQueryOneOf pp (Proxy @ss) vmap frmap sel++instance ( ParseMethod p ('Service s methods) methods )+ => ParseQuery' p s ('Service s methods) where+ parseQuery' _pp _ps _psvc vmap frmap fs = ServiceQuery <$> go fs+ where+ go [] = pure []+ go (GQL.FieldSelection fld : ss)+ = (++) <$> (maybeToList <$> fieldToMethod fld) <*> go ss+ go (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)+ | Just fr <- HM.lookup nm frmap+ = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)+ then (++) <$> go (fdSelectionSet fr) <*> go ss+ else go ss+ | otherwise -- the fragment definition was not found+ = throwError $ "fragment '" <> nm <> "' was not found"+ go (_ : _) -- Inline fragments are not yet supported+ = throwError "inline fragments are not (yet) supported"+ -- fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))+ fieldToMethod f@(GQL.Field alias name args dirs sels _)+ | any (shouldSkip vmap) dirs+ = pure Nothing+ | name == "__typename"+ = case (args, sels) of+ ([], []) -> pure $ Just $ TypeNameQuery alias+ _ -> throwError "__typename does not admit arguments nor selection of subfields"+ | name == "__schema"+ = case args of+ [] -> Just . SchemaQuery alias <$> unFragment frmap (F.toList sels)+ _ -> throwError "__schema does not admit selection of subfields"+ | name == "__type"+ = let getString (GQL.String s) = Just s+ getString (GQL.Variable v) = HM.lookup v vmap >>= getString+ getString _ = Nothing+ in case args of+ [GQL.Argument _ (GQL.Node 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 alias+ <$> selectMethod (Proxy @('Service s methods))+ (T.pack $ nameVal (Proxy @s))+ vmap frmap f+ shouldSkip :: VariableMap -> GQL.Directive -> Bool shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _) | nm == "skip", ifn == "if"@@ -362,7 +398,7 @@ selectMethod _ tyName _ _ (fName -> wanted) = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" instance- ( KnownSymbol mname, ParseMethod p s ms+ ( KnownName mname, ParseMethod p s ms , ParseArgs p s ('Method mname args r) args , ParseDifferentReturn p r) => ParseMethod p s ('Method mname args r ': ms)@@ -713,10 +749,8 @@ => ParseReturn p ('OptionalRef r) where parseReturn vmap frmap fname s = RetOptional <$> parseReturn vmap frmap fname s-instance ( p ~ 'Package pname ss,- LookupService ss s ~ 'Service s methods,- KnownName s, ParseMethod p ('Service s methods) methods- ) => ParseReturn p ('ObjectRef s) where+instance ( p ~ 'Package pname ss, ParseQuery p s )+ => ParseReturn p ('ObjectRef s) where parseReturn vmap frmap _ s = RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s @@ -732,7 +766,7 @@ = pure QueryEnum parseSchema _ _ fname _ = throwError $ "field '" <> fname <> "' should not have a selection of subfields"-instance (KnownSymbol name, ParseField sch fields)+instance (KnownName name, ParseField sch fields) => ParseSchema sch ('DRecord name fields) where parseSchema vmap frmap _ s = QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) vmap frmap s@@ -741,7 +775,7 @@ forall (sch :: Schema') t (rname :: Symbol) fields f. ( MonadError T.Text f , t ~ 'DRecord rname fields- , KnownSymbol rname+ , KnownName rname , ParseField sch fields ) => Proxy sch -> Proxy t ->@@ -790,7 +824,7 @@ selectField tyName _ _ wanted _ = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" instance- (KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) =>+ (KnownName fname, ParseField sch fs, ParseSchemaReturn sch r) => ParseField sch ('FieldDef fname r ': fs) where selectField tyName vmap frmap wanted sels
src/Mu/GraphQL/Query/Run.hs view
@@ -11,6 +11,7 @@ {-# language ScopedTypeVariables #-} {-# language TupleSections #-} {-# language TypeApplications #-}+{-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# OPTIONS_GHC -fprint-explicit-foralls #-}@@ -36,9 +37,11 @@ import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Text as T+import Data.Typeable import GHC.TypeLits import qualified Language.GraphQL.AST as GQL import Network.HTTP.Types.Header+import Unsafe.Coerce (unsafeCoerce) import Mu.GraphQL.Query.Definition import qualified Mu.GraphQL.Query.Introspection as Intro@@ -233,11 +236,10 @@ runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink runQuery- :: forall m p s pname ss hs sname ms chn inh.+ :: forall m p s pname ss hs chn inh. ( RunQueryFindHandler m p hs chn ss s hs , p ~ 'Package pname ss- , s ~ 'Service sname ms- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> Intro.Schema -> ServerT chn GQL.Field p m hs@@ -248,11 +250,10 @@ runQuery f req sch whole@(Services ss) path = runQueryFindHandler f req sch whole path ss runSubscription- :: forall m p s pname ss hs sname ms chn inh.+ :: forall m p s pname ss hs chn inh. ( RunQueryFindHandler m p hs chn ss s hs , p ~ 'Package pname ss- , s ~ 'Service sname ms- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> ServerT chn GQL.Field p m hs@@ -267,8 +268,7 @@ class RunQueryFindHandler m p whole chn ss s hs where runQueryFindHandler :: ( p ~ 'Package pname wholess- , s ~ 'Service sname ms- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> Intro.Schema -> ServerT chn GQL.Field p m whole@@ -279,8 +279,7 @@ -> WriterT [GraphQLError] IO Aeson.Value runSubscriptionFindHandler :: ( p ~ 'Package pname wholess- , s ~ 'Service sname ms- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> ServerT chn GQL.Field p m whole@@ -291,6 +290,32 @@ -> ConduitT Aeson.Value Void IO () -> IO () +class RunQueryOnFoundHandler m p whole chn (s :: Service snm mnm anm (TypeRef snm)) hs where+ type ServiceName s :: snm+ runQueryOnFoundHandler+ :: ( p ~ 'Package pname wholess+ , inh ~ MappingRight chn (ServiceName s) )+ => (forall a. m a -> ServerErrorIO a)+ -> RequestHeaders+ -> Intro.Schema -> ServerT chn GQL.Field p m whole+ -> [T.Text]+ -> ServiceT chn GQL.Field s m hs+ -> inh+ -> ServiceQuery p s+ -> WriterT [GraphQLError] IO Aeson.Value+ runSubscriptionOnFoundHandler+ :: ( p ~ 'Package pname wholess+ , inh ~ MappingRight chn (ServiceName s) )+ => (forall a. m a -> ServerErrorIO a)+ -> RequestHeaders+ -> ServerT chn GQL.Field p m whole+ -> [T.Text]+ -> ServiceT chn GQL.Field s m hs+ -> inh+ -> OneMethodQuery p s+ -> ConduitT Aeson.Value Void IO ()+ -> IO ()+ instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s) => RunQueryFindHandler m p whole chn '[] s '[] where runQueryFindHandler _ = error "this should never be called"@@ -302,17 +327,24 @@ = runQueryFindHandler f req sch whole path that runSubscriptionFindHandler f req whole path (_ :<&>: that) = runSubscriptionFindHandler f req whole path that-instance {-# OVERLAPS #-}- ( s ~ 'Service sname ms, KnownName sname- , RunMethod m p whole chn s ms h )+instance {-# OVERLAPS #-}+ (RunQueryOnFoundHandler m p whole chn s h) => RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where- runQueryFindHandler f req sch whole path (this :<&>: _) inh queries+ runQueryFindHandler f req sch whole path (s :<&>: _)+ = runQueryOnFoundHandler f req sch whole path s+ runSubscriptionFindHandler f req whole path (s :<&>: _)+ = runSubscriptionOnFoundHandler f req whole path s++instance ( KnownName sname, RunMethod m p whole chn ('Service sname ms) ms h )+ => RunQueryOnFoundHandler m p whole chn ('Service sname ms) h where+ type ServiceName ('Service sname ms) = sname+ runQueryOnFoundHandler f req sch whole path (ProperSvc this) inh (ServiceQuery queries) = Aeson.object . catMaybes <$> mapM runOneQuery queries where -- if we include the signature we have to write -- an explicit type signature for 'runQueryFindHandler' runOneQuery (OneMethodQuery nm args)- = runMethod f req whole (Proxy @s) path nm inh this args+ = runMethod f req whole (Proxy @('Service sname ms)) path nm inh this args -- handle __typename runOneQuery (TypeNameQuery nm) = let realName = fromMaybe "__typename" nm@@ -333,23 +365,59 @@ path] pure $ Just (realName, Aeson.Null) -- subscriptions should only have one element- runSubscriptionFindHandler f req whole path (this :<&>: _) inh (OneMethodQuery nm args) sink- = runMethodSubscription f req whole (Proxy @s) path nm inh this args sink- runSubscriptionFindHandler _ _ _ _ _ _ (TypeNameQuery nm) sink+ runSubscriptionOnFoundHandler f req whole path (ProperSvc this) inh (OneMethodQuery nm args) sink+ = runMethodSubscription f req whole (Proxy @('Service sname ms)) path nm inh this args sink+ runSubscriptionOnFoundHandler _ _ _ _ _ _ (TypeNameQuery nm) sink = 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+ runSubscriptionOnFoundHandler _ _ _ _ _ _ _ sink = runConduit $ yieldMany ([singleErrValue "__schema and __type are not supported in subscriptions"] :: [Aeson.Value]) .| sink +instance ( KnownName sname, RunUnion m p whole chn elts )+ => RunQueryOnFoundHandler m p whole chn ('OneOf sname elts) h where+ type ServiceName ('OneOf sname elts) = sname+ runQueryOnFoundHandler f req sch whole path (OneOfSvc this) inh (OneOfQuery queries)+ = do res <- liftIO $ runExceptT $ f $ this inh+ case res of+ Left e -> tell [GraphQLError e path] >> pure Aeson.Null+ Right x -> runUnion f req sch whole path queries x+ runSubscriptionOnFoundHandler _ _ _ _ (OneOfSvc _) _ _ _+ = error "this should never happen"++class RunUnion m p whole chn elts where+ runUnion+ :: (forall a. m a -> ServerErrorIO a)+ -> RequestHeaders+ -> Intro.Schema -> ServerT chn GQL.Field p m whole+ -> [T.Text]+ -> NP (ChosenOneOfQuery p) elts+ -> UnionChoice chn elts+ -> WriterT [GraphQLError] IO Aeson.Value++instance RunUnion m p whole chn '[] where+ runUnion _ = error "this should never happen"+instance forall m p pname s sname whole ss chn elts.+ ( RunQueryFindHandler m p whole chn ss s whole+ , p ~ 'Package pname ss+ , s ~ LookupService ss sname+ , ServiceName s ~ sname+ , RunUnion m p whole chn elts )+ => RunUnion m p whole chn (sname ': elts) where+ runUnion f req sch whole path+ (ChosenOneOfQuery (Proxy :: Proxy sname) q :* rest)+ choice@(UnionChoice (Proxy :: Proxy other) v)+ = case eqT @sname @other of+ Nothing -> runUnion f req sch whole path rest (unsafeCoerce choice)+ Just Refl -> runQuery @m @('Package pname ss) @(LookupService ss sname) @pname @ss @whole f req sch whole path v q+ class RunMethod m p whole chn s ms hs where runMethod :: ( p ~ 'Package pname wholess- , s ~ 'Service sname allMs- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> ServerT chn GQL.Field p m whole@@ -359,8 +427,7 @@ -> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value)) runMethodSubscription :: ( p ~ 'Package pname wholess- , s ~ 'Service sname allMs- , inh ~ MappingRight chn sname )+ , inh ~ MappingRight chn (ServiceName s) ) => (forall a. m a -> ServerErrorIO a) -> RequestHeaders -> ServerT chn GQL.Field p m whole@@ -385,6 +452,7 @@ rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld runMethod f req whole p path nm inh (_ :<||>: r) (S cont) = runMethod f req whole p path nm inh r cont+ runMethod _ _ _ _ _ _ _ _ _ = error "this should never happen" -- handle subscriptions runMethodSubscription f req whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) sink = runHandlerSubscription f req whole (path ++ [realName]) (h rpcInfo inh) args ret sink@@ -392,6 +460,7 @@ rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld runMethodSubscription f req whole p path nm inh (_ :<||>: r) (S cont) sink = runMethodSubscription f req whole p path nm inh r cont sink+ runMethodSubscription _ _ _ _ _ _ _ _ _ _ = error "this should never happen" class Handles chn args r m h => RunHandler m p whole chn args r h where@@ -518,9 +587,9 @@ convertResult _ _ _ _ (RetSchema r) t = pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r instance ( MappingRight chn ref ~ t- , MappingRight chn sname ~ t- , LookupService ss ref ~ 'Service sname ms- , RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname ms) whole)+ , MappingRight chn (ServiceName svc) ~ t+ , LookupService ss ref ~ svc+ , RunQueryFindHandler m ('Package pname ss) whole chn ss svc whole) => ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where convertResult f req whole path (RetObject q) h = Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f req@@ -643,7 +712,7 @@ = 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+runIntroType path s (Intro.Type k tnm fs vals posTys ofT) ss = do things <- catMaybes <$> traverse runOne ss pure $ Just $ Aeson.object things where@@ -683,7 +752,12 @@ ("interfaces", _) -> pure $ Just $ Aeson.Array [] ("possibleTypes", _)- -> pure $ Just $ Aeson.Array []+ -> case k of+ Intro.UNION+ -> do res <- catMaybes <$>+ mapM (\o -> runIntroType path' s o innerss) posTys+ pure $ Just $ Aeson.toJSON res+ _ -> pure $ Just Aeson.Null _ -> do tell [GraphQLError (ServerError Invalid