higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-07-14 17:50:22 +03:00
Code Issues Projects Releases Wiki Activity

Unions in GraphQL (#270)

Browse Source
This commit is contained in:
Alejandro Serrano 2021-01-07 14:55:32 +01:00 committed by GitHub
parent 8bb3a5cf6c
commit e9d55fd6bf
23 changed files with 455 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
adapter/avro/mu-avro.cabal
View File

@ -38,7 +38,7 @@ library
, containers >=0.6 && <0.7
, deepseq >=1.4 && <2
, language-avro >=0.1.3 && <0.2
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.4 && <0.6
, mu-schema >=0.3 && <0.4
, sop-core >=0.5.0 && <0.6
, tagged >=0.8.6 && <0.9

2
adapter/protobuf/mu-protobuf.cabal
View File

@ -38,7 +38,7 @@ library
, http-client >=0.6 && <0.7
, http2-grpc-proto3-wire >=0.1 && <0.2
, language-protobuf >=1.0.1 && <2
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.4 && <0.6
, mu-schema >=0.3 && <0.4
, proto3-wire >=1.1 && <2
, servant-client-core >=0.16 && <0.19

2
core/rpc/mu-rpc.cabal
View File

@ -1,5 +1,5 @@
name: mu-rpc
version: 0.4.0.1
version: 0.5.0.0
synopsis: Protocol-independent declaration of services and servers.
description:
Protocol-independent declaration of services and servers for mu-haskell.

36
core/rpc/src/Mu/Rpc.hs
View File

@ -20,7 +20,7 @@ and protocol.
-}
module Mu.Rpc (
Package', Package(..)
, Service', Service(..), Object
, Service', Service(..), Object, Union
, Method', Method(..), ObjectField
, LookupService, LookupMethod
, TypeRef(..), Argument', Argument(..), Return(..)
@ -56,6 +56,7 @@ data Package serviceName methodName argName tyRef
data Service serviceName methodName argName tyRef
= Service serviceName
[Method serviceName methodName argName tyRef]
| OneOf serviceName [serviceName]
-- | A method is defined by its name, arguments, and return type.
data Method serviceName methodName argName tyRef
@ -66,6 +67,8 @@ data Method serviceName methodName argName tyRef
-- Synonyms for GraphQL
-- | An object is a set of fields, in GraphQL lingo.
type Object = 'Service
-- | A union is one of the objects.
type Union = 'OneOf
-- | A field in an object takes some input objects,
-- and returns a value or some other object,
-- in GraphQL lingo.
@ -76,6 +79,7 @@ type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm)
:: Service snm mnm anm tr where
LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)
LookupService ('Service s ms ': ss) s = 'Service s ms
LookupService ('OneOf s ms ': ss) s = 'OneOf s ms
LookupService (other ': ss) s = LookupService ss s
-- | Look up a method in a service definition using its name.
@ -136,7 +140,7 @@ data RpcInfo i
= NoRpcInfo
| RpcInfo { packageInfo :: Package Text Text Text TyInfo
, serviceInfo :: Service Text Text Text TyInfo
, methodInfo :: Method Text Text Text TyInfo
, methodInfo :: Maybe (Method Text Text Text TyInfo)
, headers :: RequestHeaders
, extraInfo :: i
}
@ -150,10 +154,15 @@ data TyInfo
instance Show (RpcInfo i) where
show NoRpcInfo
= "<no info>"
show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _ _)
= T.unpack (s <> ":" <> m)
show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _ _)
= T.unpack (p <> ":" <> s <> ":" <> m)
show (RpcInfo (Package p _) s m _ _)
= T.unpack $ showPkg p (showMth m (showSvc s))
where
showPkg Nothing = id
showPkg (Just pkg) = ((pkg <> ":") <>)
showMth Nothing = id
showMth (Just (Method mt _ _)) = (<> (":" <> mt))
showSvc (Service sv _) = sv
showSvc (OneOf sv _) = sv
class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i
@ -175,6 +184,13 @@ instance KnownMaySymbol 'Nothing where
instance (KnownSymbol s) => KnownMaySymbol ('Just s) where
maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
class KnownSymbols (m :: [Symbol]) where
symbolsVal :: Proxy m -> [Text]
instance KnownSymbols '[] where
symbolsVal _ = []
instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where
symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)
class ReflectServices (ss :: [Service']) where
reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]
instance ReflectServices '[] where
@ -204,7 +220,7 @@ instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMet
reflectRpcInfo _ ps pm req extra
= RpcInfo (Package (maySymbolVal (Proxy @pname))
(reflectServices (Proxy @ss)))
(reflectService ps) (reflectMethod pm) req extra
(reflectService ps) (Just (reflectMethod pm)) req extra
instance (KnownSymbol sname, ReflectMethods ms)
=> ReflectService ('Service sname ms) where
@ -212,6 +228,12 @@ instance (KnownSymbol sname, ReflectMethods ms)
= Service (T.pack $ symbolVal (Proxy @sname))
(reflectMethods (Proxy @ms))
instance (KnownSymbol sname, KnownSymbols elts)
=> ReflectService ('OneOf sname elts) where
reflectService _
= OneOf (T.pack $ symbolVal (Proxy @sname))
(symbolsVal (Proxy @elts))
instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)
=> ReflectMethod ('Method mname args r) where
reflectMethod _

41
core/rpc/src/Mu/Rpc/Examples.hs
View File

@ -105,30 +105,43 @@ quickstartServer
type ApolloService
= 'Package ('Just "apollo")
'[ Object "Book"
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
]
, Object "Author"
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
]
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
]
, Object "Paper"
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
]
, Union "Writing" ["Book", "Paper"]
, Object "Author"
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))
]
]
type ApolloBookAuthor = '[
"Book" ':-> (String, Integer)
, "Author" ':-> Integer
"Book" ':-> (String, Integer)
, "Paper" ':-> (String, Integer)
, "Writing" ':-> Either (String, Integer) (String, Integer)
, "Author" ':-> Integer
]
apolloServer :: forall m i. (MonadServer m)
=> ServerT ApolloBookAuthor i ApolloService m _
apolloServer
= resolver
( object @"Author" ( field @"name" authorName
, field @"books" authorBooks )
( object @"Author" ( field @"name" authorName
, field @"writings" authorWrs )
, object @"Book" ( field @"author" (pure . snd)
, field @"title" (pure . fst) ) )
, field @"title" (pure . fst) )
, object @"Paper" ( field @"author" (pure . snd)
, field @"title" (pure . fst) )
, union @"Writing" writing )
where
authorName :: Integer -> m String
authorName _ = pure "alex" -- this would run in the DB
authorBooks :: Integer -> m [(String, Integer)]
authorBooks _ = pure []
authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]
authorWrs _ = pure []
writing (Left c) = pure $ unionChoice @"Book" c
writing (Right c) = pure $ unionChoice @"Paper" c

47
core/rpc/src/Mu/Server.hs
View File

@ -1,3 +1,4 @@
{-# language AllowAmbiguousTypes #-}
{-# language CPP #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
@ -54,12 +55,13 @@ module Mu.Server (
-- ** Definitions by name
, singleService
, method, methodWithInfo
, resolver, object
, resolver, object, union
, field, fieldWithInfo
, UnionChoice(..), unionChoice
, NamedList(..)
-- ** Definitions by position
, SingleServerT, pattern Server
, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))
, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))
-- ** Simple servers using only IO
, ServerErrorIO, ServerIO
-- * Errors which might be raised
@ -74,6 +76,7 @@ import Control.Exception (Exception)
import Control.Monad.Except
import Data.Conduit
import Data.Kind
import Data.Typeable
import GHC.TypeLits
import Mu.Rpc
@ -151,7 +154,7 @@ data ServerT (chn :: ServiceChain snm) (info :: Type)
pattern Server :: (MappingRight chn sname ~ ())
=> HandlersT chn info () methods m hs
-> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
pattern Server svr = Services (svr :<&>: S0)
pattern Server svr = Services (ProperSvc svr :<&>: S0)
infixr 3 :<&>:
-- | Definition of a complete server for a service.
@ -159,9 +162,31 @@ data ServicesT (chn :: ServiceChain snm) (info :: Type)
(s :: [Service snm mnm anm (TypeRef snm)])
(m :: Type -> Type) (hs :: [[Type]]) where
S0 :: ServicesT chn info '[] m '[]
(:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs
(:<&>:) :: ServiceT chn info svc m hs
-> ServicesT chn info rest m hss
-> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)
-> ServicesT chn info (svc ': rest) m (hs ': hss)
type family InUnion (x :: k) (xs :: [k]) :: Constraint where
InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union")
InUnion x (x ': xs) = ()
InUnion x (y ': xs) = InUnion x xs
data UnionChoice chn elts where
UnionChoice :: (InUnion elt elts, Typeable elt)
=> Proxy elt -> MappingRight chn elt
-> UnionChoice chn elts
unionChoice :: forall elt elts chn.
(InUnion elt elts, Typeable elt)
=> MappingRight chn elt -> UnionChoice chn elts
unionChoice = UnionChoice (Proxy @elt)
-- | Definition of different kinds of services.
data ServiceT chn info svc m hs where
ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs
-> ServiceT chn info ('Service sname methods) m hs
OneOfSvc :: (MappingRight chn sname -> m (UnionChoice chn elts))
-> ServiceT chn info ('OneOf sname elts) m '[]
-- | 'HandlersT' is a sequence of handlers.
-- Note that the handlers for your service
@ -322,6 +347,11 @@ object
=> p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
object nl = Named $ toHandlers $ toNamedList nl
union :: forall sname chn m elts.
(MappingRight chn sname -> m (UnionChoice chn elts))
-> Named sname (MappingRight chn sname -> m (UnionChoice chn elts))
union = Named
-- | Combines the implementation of several GraphQL objects,
-- which means a whole Mu service for a GraphQL server.
-- Intented to be used with a tuple of 'objects':
@ -412,7 +442,12 @@ instance ToServices chn info '[] m '[] nl where
instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl
, ToServices chn info ss m hs nl)
=> ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where
toServices nl = findService (Proxy @name) nl :<&>: toServices nl
toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl
instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl
, ToServices chn info ss m hs nl)
=> ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where
toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl
class FindService name h nl | name nl -> h where
findService :: Proxy name -> NamedList nl -> h

2
examples/library

@ -1 +1 @@
Subproject commit 851f9522792e843f2e4b5e478cae6714b5cefd79
Subproject commit b2cfb27c24d14fe51c0d7d13b602eb7584a9a598

37
graphql/exe/Main.hs
View File

@ -1,6 +1,7 @@
{-# language CPP #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{-# language PartialTypeSignatures #-}
{-# language PolyKinds #-}
@ -52,9 +53,14 @@ main = do
(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, Integer))])]
@ -64,39 +70,54 @@ library
, (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
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)
bookAuthor (aid, _) = pure aid
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]

10
graphql/exe/schema.graphql
View File

@ -5,10 +5,18 @@ type Book {
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 {

6
graphql/mu-graphql.cabal
View File

@ -1,5 +1,5 @@
name: mu-graphql
version: 0.4.1.1
version: 0.5.0.0
synopsis: GraphQL support for Mu
description: GraphQL servers and clients for Mu-Haskell
cabal-version: >=1.10
@ -40,7 +40,7 @@ library
, list-t >=1.0 && <2
, megaparsec >=8 && <10
, mtl >=2.2 && <2.3
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, parsers >=0.12 && <0.13
, scientific >=0.3 && <0.4
@ -73,7 +73,7 @@ executable library-graphql
, aeson >=1.4 && <2
, conduit >=1.3.2 && <1.4
, mu-graphql
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, regex-tdfa >=1.3 && <2
, text >=1.2 && <2

14
graphql/src/Mu/GraphQL/Quasi.hs
View File

@ -61,7 +61,8 @@ data GQLType =
| Object
| Scalar
| InputObject
| Other
| Union
| Interface
classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap
classifySchema = foldl' schemaToMap HM.empty
@ -81,9 +82,9 @@ classify = HM.fromList . (typeToKeyValue <$>)
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 _ _)
@ -118,8 +119,11 @@ defaultDeclToTy (sn, (mn, (an, dv)))
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

22
graphql/src/Mu/GraphQL/Query/Definition.hs
View File

@ -8,6 +8,7 @@ module Mu.GraphQL.Query.Definition where
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 @@ data Document (p :: Package snm mnm anm (TypeRef snm))
=> 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 @@ data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
-- 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

47
graphql/src/Mu/GraphQL/Query/Introspection.hs
View File

@ -33,11 +33,12 @@ data Schema
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
@ -74,17 +75,17 @@ data TypeKind
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
-- ========================
@ -175,12 +176,32 @@ instance ( KnownSymbol sname
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]
@ -292,7 +313,7 @@ instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts)
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
@ -302,7 +323,7 @@ instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts)
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

196
graphql/src/Mu/GraphQL/Query/Parse.hs
View File

@ -22,8 +22,8 @@ import Data.Int (Int32)
import Data.List (find)
import Data.Maybe
import Data.Proxy
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
import Data.SOP.NS
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
import qualified Data.Text as T
import GHC.TypeLits
import qualified Language.GraphQL.AST as GQL
@ -139,14 +139,15 @@ instance
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 @@ instance
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 @@ instance
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 @@ instance
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 @@ instance
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 @@ instance
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 @@ instance
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,59 +267,91 @@ constToValue (GQL.ConstObject n)
[ 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 _) _] _)
@ -362,7 +398,7 @@ instance ParseMethod p s '[] where
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 @@ instance ParseReturn p r
=> 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 @@ instance ParseSchema sch ('DEnum name choices) where
= 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 @@ parseSchemaQuery ::
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 @@ instance ParseField sch '[] where
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

130
graphql/src/Mu/GraphQL/Query/Run.hs
View File

@ -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 Data.Conduit.TQueue
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 @@ yieldDocument f req svr doc sink = do
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
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 @@ runSubscription f req whole@(Services ss) path
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 @@ class RunQueryFindHandler m p whole chn ss s hs where
-> 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 @@ class RunQueryFindHandler m p whole chn ss s hs where
-> 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 @@ instance {-# OVERLAPPABLE #-}
= 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 @@ instance {-# OVERLAPS #-}
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 @@ class RunMethod m p whole chn s ms hs where
-> 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 @@ instance ( RunMethod m p whole chn s ms hs
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 @@ instance ( RunMethod m p whole chn s ms hs
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 @@ instance ( ToSchema sch l r
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 @@ 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
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 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
("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

2
grpc/client/mu-grpc-client.cabal
View File

@ -41,7 +41,7 @@ library
, mu-grpc-common >=0.4 && <0.5
, mu-optics >=0.3 && <0.4
, mu-protobuf >=0.4 && <0.5
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.4 && <0.6
, mu-schema >=0.3 && <0.4
, optics-core >=0.2 && <0.4
, sop-core >=0.5 && <0.6

2
grpc/common/mu-grpc-common.cabal
View File

@ -33,7 +33,7 @@ library
, http2-grpc-types >=0.5 && <0.6
, mu-avro >=0.4 && <0.5
, mu-protobuf >=0.4 && <0.5
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.4 && <0.6
, mu-schema >=0.3 && <0.4
hs-source-dirs: src

8
grpc/server/mu-grpc-server.cabal
View File

@ -1,5 +1,5 @@
name: mu-grpc-server
version: 0.4.0.0
version: 0.5.0.0
synopsis: gRPC servers for Mu definitions
description:
With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell!
@ -33,7 +33,7 @@ library
, mtl >=2.2 && <3
, mu-grpc-common >=0.4 && <0.5
, mu-protobuf >=0.4 && <0.5
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, sop-core >=0.5 && <0.6
, stm >=2.5 && <3
@ -59,9 +59,9 @@ executable grpc-example-server
, http2-grpc-types >=0.5 && <0.6
, mtl >=2.2 && <3
, mu-grpc-common >=0.4 && <0.5
, mu-grpc-server >=0.4 && <0.5
, mu-grpc-server
, mu-protobuf >=0.4 && <0.5
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, sop-core >=0.5 && <0.6
, stm >=2.5 && <3

6
grpc/server/src/Mu/GRpc/Server.hs
View File

@ -47,6 +47,7 @@ import Data.Conduit
import Data.Conduit.TMChan
import Data.Kind
import Data.Proxy
import GHC.TypeLits
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..))
import Network.GRPC.Server.Handlers.Trans
@ -174,12 +175,15 @@ instance ( KnownName name
p m chn (MappingRight chn name) methods h
, GRpcServiceHandlers fullP p m chn rest hs )
=> GRpcServiceHandlers fullP p m chn ('Service name methods ': rest) (h ': hs) where
gRpcServiceHandlers f pfullP pr packageName (svr :<&>: rest)
gRpcServiceHandlers f pfullP pr packageName (ProperSvc svr :<&>: rest)
= gRpcMethodHandlers f pfullP (Proxy @('Service name methods)) pr
packageName serviceName svr
++ gRpcServiceHandlers f pfullP pr packageName rest
where serviceName = BS.pack (nameVal (Proxy @name))
instance ( GHC.TypeLits.TypeError ('Text "unions are not supported in gRPC") )
=> GRpcServiceHandlers fullP p m chn ('OneOf name methods ': rest) hs where
gRpcServiceHandlers _ = error "unions are not supported in gRPC"
class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm))
(fullS :: Service snm mnm anm (TypeRef snm))

10
instrumentation/prometheus/mu-prometheus.cabal
View File

@ -1,5 +1,5 @@
name: mu-prometheus
version: 0.4.0.0
version: 0.5.0.0
synopsis: Metrics support for Mu using Prometheus
description: Get metrics of your running Mu servers using Prometheus
license: Apache-2.0
@ -22,12 +22,12 @@ library
build-depends:
base >=4.12 && <5
, lifted-base >=0.2 && <0.3
, monad-control >1 && <2
, mu-rpc >=0.4 && <0.5
, prometheus-client >1 && <2
, monad-control >1 && <2
, mu-rpc >=0.5 && <0.6
, prometheus-client >1 && <2
, text >=1.2 && <2
, wai >=3.2 && <4
, wai-middleware-prometheus >1 && <2
, wai-middleware-prometheus >1 && <2
hs-source-dirs: src
default-language: Haskell2010

14
instrumentation/prometheus/src/Mu/Instrumentation/Prometheus.hs
View File

@ -49,17 +49,23 @@ prometheusMetrics :: forall m a info. (MonadBaseControl IO m, MonadMonitor m)
prometheusMetrics metrics NoRpcInfo run = do
incGauge (activeCalls metrics)
run `finally` decGauge (activeCalls metrics)
prometheusMetrics metrics (RpcInfo _pkg (Service sname _) (Method mname _ _) _ _) run = do
prometheusMetrics metrics (RpcInfo _pkg ss mm _ _) run = do
let sname' = case ss of
Service sname _ -> sname
OneOf sname _ -> sname
mname' = case mm of
Just (Method mname _ _) -> mname
Nothing -> "<noname>"
incGauge (activeCalls metrics)
withLabel (messagesReceived metrics) (sname, mname) incCounter
withLabel (messagesReceived metrics) (sname', mname') incCounter
( do -- We are forced to use a MVar because 'withLabel' only allows IO ()
r <- liftBaseWith $ \runInIO -> do
result :: MVar (StM m a) <- newEmptyMVar
withLabel (callsTotal metrics) (sname, mname) $ \h ->
withLabel (callsTotal metrics) (sname', mname') $ \h ->
h `observeDuration` (runInIO run >>= putMVar result)
takeMVar result
x <- restoreM r
withLabel (messagesSent metrics) (sname, mname) incCounter
withLabel (messagesSent metrics) (sname', mname') incCounter
pure x )
`finally` decGauge (activeCalls metrics)

6
servant/server/mu-servant-server.cabal
View File

@ -1,5 +1,5 @@
name: mu-servant-server
version: 0.4.0.0
version: 0.5.0.0
synopsis: Servant servers for Mu definitions
description:
With @mu-servant-server@ you can easily build Servant servers for mu-haskell!
@ -30,7 +30,7 @@ library
, generic-aeson >=0.2 && <0.3
, ghc-prim >=0.5 && <0.7
, mtl >=2.2 && <3
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, servant >=0.16 && <0.19
, servant-server >=0.16 && <0.19
@ -49,7 +49,7 @@ executable servant-example-server
aeson >=1.4 && <2
, base >=4.12 && <5
, conduit >=1.3.2 && <2
, mu-rpc >=0.4 && <0.5
, mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4
, mu-servant-server
, servant-server >=0.16 && <0.19

10
servant/server/src/Mu/Servant/Server.hs
View File

@ -47,10 +47,10 @@ import qualified Data.ByteString.Lazy.UTF8 as LB8
import Data.Conduit.Internal (ConduitT (..), Pipe (..))
import Data.Kind
import Data.Swagger (Swagger, ToSchema (..))
import Generics.Generic.Aeson
import GHC.Generics
import GHC.TypeLits
import GHC.Types (Any)
import Generics.Generic.Aeson
import Mu.Rpc
import Mu.Rpc.Annotations
import Mu.Schema
@ -170,10 +170,16 @@ instance
type
ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) =
MethodsAPI pkg sname methods hs :<|> ServicesAPI pkg rest hss
servantServiceHandlers f pkgP (svr :<&>: rest) =
servantServiceHandlers f pkgP (ProperSvc svr :<&>: rest) =
servantMethodHandlers f pkgP (Proxy @sname) svr
:<|> servantServiceHandlers f pkgP rest
instance (TypeError ('Text "unions are not supported by Servant servers"))
=> ServantServiceHandlers pkg m chn ('OneOf sname methods ': rest) hs where
type ServicesAPI pkg ('OneOf sname methods ': rest) hs =
TypeError ('Text "unions are not supported by Servant servers")
servantServiceHandlers _ = error "unions are not supported by Servant servers"
class
ServantMethodHandlers
(pkg :: Package Symbol Symbol anm (TypeRef Symbol))