higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-08-17 02:10: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 , containers >=0.6 && <0.7
, deepseq >=1.4 && <2 , deepseq >=1.4 && <2
, language-avro >=0.1.3 && <0.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 , mu-schema >=0.3 && <0.4
, sop-core >=0.5.0 && <0.6 , sop-core >=0.5.0 && <0.6
, tagged >=0.8.6 && <0.9 , 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 , http-client >=0.6 && <0.7
, http2-grpc-proto3-wire >=0.1 && <0.2 , http2-grpc-proto3-wire >=0.1 && <0.2
, language-protobuf >=1.0.1 && <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 , mu-schema >=0.3 && <0.4
, proto3-wire >=1.1 && <2 , proto3-wire >=1.1 && <2
, servant-client-core >=0.16 && <0.19 , servant-client-core >=0.16 && <0.19

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

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

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

@ -105,30 +105,43 @@ quickstartServer
type ApolloService type ApolloService
= 'Package ('Just "apollo") = 'Package ('Just "apollo")
'[ Object "Book" '[ Object "Book"
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String)) '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author")) , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
] ]
, Object "Author" , Object "Paper"
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String)) '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book"))) , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
] ]
, Union "Writing" ["Book", "Paper"]
, Object "Author"
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
, ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))
]
] ]
type ApolloBookAuthor = '[ type ApolloBookAuthor = '[
"Book" ':-> (String, Integer) "Book" ':-> (String, Integer)
, "Author" ':-> Integer , "Paper" ':-> (String, Integer)
, "Writing" ':-> Either (String, Integer) (String, Integer)
, "Author" ':-> Integer
] ]
apolloServer :: forall m i. (MonadServer m) apolloServer :: forall m i. (MonadServer m)
=> ServerT ApolloBookAuthor i ApolloService m _ => ServerT ApolloBookAuthor i ApolloService m _
apolloServer apolloServer
= resolver = resolver
( object @"Author" ( field @"name" authorName ( object @"Author" ( field @"name" authorName
, field @"books" authorBooks ) , field @"writings" authorWrs )
, object @"Book" ( field @"author" (pure . snd) , 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 where
authorName :: Integer -> m String authorName :: Integer -> m String
authorName _ = pure "alex" -- this would run in the DB authorName _ = pure "alex" -- this would run in the DB
authorBooks :: Integer -> m [(String, Integer)] authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]
authorBooks _ = pure [] 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 CPP #-}
{-# language ConstraintKinds #-} {-# language ConstraintKinds #-}
{-# language DataKinds #-} {-# language DataKinds #-}
@ -54,12 +55,13 @@ module Mu.Server (
-- ** Definitions by name -- ** Definitions by name
, singleService , singleService
, method, methodWithInfo , method, methodWithInfo
, resolver, object , resolver, object, union
, field, fieldWithInfo , field, fieldWithInfo
, UnionChoice(..), unionChoice
, NamedList(..) , NamedList(..)
-- ** Definitions by position -- ** Definitions by position
, SingleServerT, pattern Server , SingleServerT, pattern Server
, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:)) , ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))
-- ** Simple servers using only IO -- ** Simple servers using only IO
, ServerErrorIO, ServerIO , ServerErrorIO, ServerIO
-- * Errors which might be raised -- * Errors which might be raised
@ -74,6 +76,7 @@ import Control.Exception (Exception)
import Control.Monad.Except import Control.Monad.Except
import Data.Conduit import Data.Conduit
import Data.Kind import Data.Kind
import Data.Typeable
import GHC.TypeLits import GHC.TypeLits
import Mu.Rpc import Mu.Rpc
@ -151,7 +154,7 @@ data ServerT (chn :: ServiceChain snm) (info :: Type)
pattern Server :: (MappingRight chn sname ~ ()) pattern Server :: (MappingRight chn sname ~ ())
=> HandlersT chn info () methods m hs => HandlersT chn info () methods m hs
-> ServerT chn info ('Package pname '[ 'Service sname 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 :<&>: infixr 3 :<&>:
-- | Definition of a complete server for a service. -- | 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)]) (s :: [Service snm mnm anm (TypeRef snm)])
(m :: Type -> Type) (hs :: [[Type]]) where (m :: Type -> Type) (hs :: [[Type]]) where
S0 :: ServicesT chn info '[] m '[] 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 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. -- | 'HandlersT' is a sequence of handlers.
-- Note that the handlers for your service -- Note that the handlers for your service
@ -322,6 +347,11 @@ object
=> p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs) => p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
object nl = Named $ toHandlers $ toNamedList nl 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, -- | Combines the implementation of several GraphQL objects,
-- which means a whole Mu service for a GraphQL server. -- which means a whole Mu service for a GraphQL server.
-- Intented to be used with a tuple of 'objects': -- 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 instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl
, ToServices chn info ss m hs nl) , ToServices chn info ss m hs nl)
=> ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where => 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 class FindService name h nl | name nl -> h where
findService :: Proxy name -> NamedList nl -> h 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 CPP #-}
{-# language DataKinds #-} {-# language DataKinds #-}
{-# language FlexibleContexts #-} {-# language FlexibleContexts #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-} {-# language OverloadedStrings #-}
{-# language PartialTypeSignatures #-} {-# language PartialTypeSignatures #-}
{-# language PolyKinds #-} {-# language PolyKinds #-}
@ -52,9 +53,14 @@ main = do
(Proxy @'Nothing) (Proxy @'Nothing)
(Proxy @('Just "Subscription")) (Proxy @('Just "Subscription"))
data WritingMapping
= ABook (Integer, Integer) | AnArticle (Integer, Integer)
type ServiceMapping = '[ type ServiceMapping = '[
"Book" ':-> (Integer, Integer) "Book" ':-> (Integer, Integer)
, "Author" ':-> Integer , "Article" ':-> (Integer, Integer)
, "Author" ':-> Integer
, "Writing" ':-> WritingMapping
] ]
library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])] library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
@ -64,39 +70,54 @@ library
, (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))]) , (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) libraryServer :: forall m i. (MonadServer m)
=> ServerT ServiceMapping i ServiceDefinition m _ => ServerT ServiceMapping i ServiceDefinition m _
libraryServer libraryServer
= resolver ( object @"Book" ( field @"id" bookId = resolver ( object @"Book" ( field @"id" bookOrArticleId
, field @"title" bookTitle , field @"title" bookTitle
, field @"author" bookAuthor , field @"author" bookOrArticleAuthor
, field @"info" bookInfo ) , field @"info" bookInfo )
, object @"Article" ( field @"id" bookOrArticleId
, field @"title" articleTitle
, field @"author" bookOrArticleAuthor )
, object @"Author" ( field @"id" authorId , object @"Author" ( field @"id" authorId
, field @"name" authorName , field @"name" authorName
, field @"books" authorBooks ) , field @"writings" authorBooks )
, object @"Query" ( method @"author" findAuthor , object @"Query" ( method @"author" findAuthor
, method @"book" findBookTitle , method @"book" findBookTitle
, method @"authors" allAuthors , method @"authors" allAuthors
, method @"books" allBooks' ) , method @"books" allBooks' )
, object @"Subscription" ( method @"books" allBooksConduit ) , object @"Subscription" ( method @"books" allBooksConduit )
, union @"Writing" (\case (ABook x) -> pure $ unionChoice @"Book" x
(AnArticle x) -> pure $ unionChoice @"Article" x)
) )
where where
findBook i = find ((==i) . fst3) library 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 bookTitle (aid, bid) = pure $ fromMaybe "" $ do
bk <- findBook aid bk <- findBook aid
ev <- lookup bid (thd3 bk) ev <- lookup bid (thd3 bk)
pure (fst ev) pure (fst ev)
bookAuthor (aid, _) = pure aid
bookInfo (aid, bid) = pure $ do bookInfo (aid, bid) = pure $ do
bk <- findBook aid bk <- findBook aid
ev <- lookup bid (thd3 bk) ev <- lookup bid (thd3 bk)
pure $ JSON.object ["score" JSON..= snd ev] 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 authorId = pure
authorName aid = pure $ maybe "" snd3 (findBook aid) 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 findAuthor rx = pure $ listToMaybe
[aid | (aid, name, _) <- library, name =~ rx] [aid | (aid, name, _) <- library, name =~ rx]

10
graphql/exe/schema.graphql
View File

@ -5,10 +5,18 @@ type Book {
info: JSON info: JSON
} }
type Article {
id: Int!
title: String!
author: Author!
}
union Writing = Book | Article
type Author { type Author {
id: Int! id: Int!
name: String! name: String!
books: [Book!]! writings: [Writing!]!
} }
type Query { type Query {

6
graphql/mu-graphql.cabal
View File

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

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

@ -61,7 +61,8 @@ data GQLType =
| Object | Object
| Scalar | Scalar
| InputObject | InputObject
| Other | Union
| Interface
classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap
classifySchema = foldl' schemaToMap HM.empty classifySchema = foldl' schemaToMap HM.empty
@ -81,9 +82,9 @@ classify = HM.fromList . (typeToKeyValue <$>)
typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _) typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _)
= (name, Object) = (name, Object)
typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _) typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _)
= (name, Other) = (name, Interface)
typeToKeyValue (GQL.UnionTypeDefinition _ name _ _) typeToKeyValue (GQL.UnionTypeDefinition _ name _ _)
= (name, Other) = (name, Union)
typeToKeyValue (GQL.EnumTypeDefinition _ name _ _) typeToKeyValue (GQL.EnumTypeDefinition _ name _ _)
= (name, Enum) = (name, Enum)
typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _) typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _)
@ -118,8 +119,11 @@ defaultDeclToTy (sn, (mn, (an, dv)))
typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result
typeToDec _ _ _ GQL.InterfaceTypeDefinition {} typeToDec _ _ _ GQL.InterfaceTypeDefinition {}
= fail "interface types are not supported" = fail "interface types are not supported"
typeToDec _ _ _ GQL.UnionTypeDefinition {} typeToDec _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do
= fail "union types are not supported" selts <- mapM textToStrLit elts
GQLService <$> [t| 'OneOf $(textToStrLit nm)
$(pure $ typesToList selts) |]
<*> pure []
typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) =
GQLScalar <$ gqlTypeToType s tm schemaName GQLScalar <$ gqlTypeToType s tm schemaName
typeToDec schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do 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.NP
import Data.SOP.NS import Data.SOP.NS
import Data.Text import Data.Text
import Data.Typeable
import qualified Language.GraphQL.AST as GQL import qualified Language.GraphQL.AST as GQL
import Mu.Rpc import Mu.Rpc
import Mu.Schema import Mu.Schema
@ -27,9 +28,12 @@ data Document (p :: Package snm mnm anm (TypeRef snm))
=> OneMethodQuery ('Package pname ss) (LookupService ss sub) => OneMethodQuery ('Package pname ss) (LookupService ss sub)
-> Document ('Package pname ss) qr mut ('Just sub) -> Document ('Package pname ss) qr mut ('Just sub)
type ServiceQuery (p :: Package snm mnm anm (TypeRef snm)) data ServiceQuery (p :: Package snm mnm anm (TypeRef snm))
(s :: Service snm mnm anm (TypeRef snm)) (s :: Service snm mnm anm (TypeRef snm)) where
= [OneMethodQuery p s] 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)) data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
(s :: Service snm mnm anm (TypeRef snm)) where (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 -- the special '__typename' field
TypeNameQuery TypeNameQuery
:: Maybe Text :: Maybe Text
-> OneMethodQuery p ('Service nm ms) -> OneMethodQuery p s
-- introspection fields -- introspection fields
SchemaQuery SchemaQuery
:: Maybe Text :: Maybe Text
-> [GQL.Selection] -> [GQL.Selection]
-> OneMethodQuery p ('Service nm ms) -> OneMethodQuery p s
TypeQuery TypeQuery
:: Maybe Text :: Maybe Text
-> Text -> Text
-> [GQL.Selection] -> [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)) data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm))
(m :: Method snm mnm anm (TypeRef snm)) where (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 data Type
= Type = Type
{ kind :: TypeKind { kind :: TypeKind
, typeName :: Maybe T.Text , typeName :: Maybe T.Text
, fields :: [Field] , fields :: [Field]
, enumValues :: [EnumValue] , enumValues :: [EnumValue]
, ofType :: Maybe Type , possibleTypes :: [Type]
, ofType :: Maybe Type
} }
| TypeRef { to :: T.Text } | TypeRef { to :: T.Text }
deriving Show deriving Show
@ -74,17 +75,17 @@ data TypeKind
deriving Show deriving Show
tSimple :: T.Text -> Type tSimple :: T.Text -> Type
tSimple t = Type SCALAR (Just t) [] [] Nothing tSimple t = Type SCALAR (Just t) [] [] [] Nothing
tList :: Type -> Type tList :: Type -> Type
tList = Type LIST Nothing [] [] . Just tList = Type LIST Nothing [] [] [] . Just
tNonNull :: Type -> Type tNonNull :: Type -> Type
tNonNull = Type NON_NULL Nothing [] [] . Just tNonNull = Type NON_NULL Nothing [] [] [] . Just
unwrapNonNull :: Type -> Maybe Type unwrapNonNull :: Type -> Maybe Type
unwrapNonNull (Type NON_NULL _ _ _ x) = x unwrapNonNull (Type NON_NULL _ _ _ _ x) = x
unwrapNonNull _ = Nothing unwrapNonNull _ = Nothing
-- BUILD INTROSPECTION DATA -- BUILD INTROSPECTION DATA
-- ======================== -- ========================
@ -175,12 +176,32 @@ instance ( KnownSymbol sname
introspectServices _ psub = do introspectServices _ psub = do
let name = T.pack $ symbolVal (Proxy @sname) let name = T.pack $ symbolVal (Proxy @sname)
fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub)) 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 -- add this one to the mix
tell (HM.singleton name t) tell (HM.singleton name t)
-- continue with the rest -- continue with the rest
introspectServices (Proxy @ss) psub 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 class IntrospectFields (fs :: [Method']) (isSub :: Bool) where
introspectFields introspectFields
:: Proxy fs -> Proxy isSub -> Writer TypeMap [Field] :: Proxy fs -> Proxy isSub -> Writer TypeMap [Field]
@ -292,7 +313,7 @@ instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts)
introspectSchema k suffix _ = do introspectSchema k suffix _ = do
let name = T.pack (symbolVal (Proxy @name)) <> suffix let name = T.pack (symbolVal (Proxy @name)) <> suffix
fs = introspectSchemaFields suffix (Proxy @fields) 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 -- add this one to the mix
tell (HM.singleton name t) tell (HM.singleton name t)
-- continue with the rest -- continue with the rest
@ -302,7 +323,7 @@ instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts)
introspectSchema k suffix _ = do introspectSchema k suffix _ = do
let name = T.pack (symbolVal (Proxy @name)) <> suffix let name = T.pack (symbolVal (Proxy @name)) <> suffix
cs = introspectSchemaEnum (Proxy @choices) cs = introspectSchemaEnum (Proxy @choices)
t = Type ENUM (Just name) [] cs Nothing t = Type ENUM (Just name) [] cs [] Nothing
-- add this one to the mix -- add this one to the mix
tell (HM.singleton name t) tell (HM.singleton name t)
-- continue with the rest -- 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.List (find)
import Data.Maybe import Data.Maybe
import Data.Proxy import Data.Proxy
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
import Data.SOP.NS import Data.SOP.NS
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
import qualified Data.Text as T import qualified Data.Text as T
import GHC.TypeLits import GHC.TypeLits
import qualified Language.GraphQL.AST as GQL import qualified Language.GraphQL.AST as GQL
@ -139,14 +139,15 @@ instance
KnownName sub, ParseMethod p ('Service sub smethods) smethods KnownName sub, ParseMethod p ('Service sub smethods) smethods
) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where ) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where
parseTypedDocQuery vmap frmap sset parseTypedDocQuery vmap frmap sset
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
parseTypedDocMutation 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 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 case q of
[one] -> pure $ SubscriptionDoc one ServiceQuery [one]
_ -> throwError "subscriptions may only have one field" -> pure $ SubscriptionDoc one
_ -> throwError "subscriptions may only have one field"
instance instance
( p ~ 'Package pname ss, ( p ~ 'Package pname ss,
@ -156,9 +157,9 @@ instance
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods KnownName mut, ParseMethod p ('Service mut mmethods) mmethods
) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where ) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where
parseTypedDocQuery vmap frmap sset parseTypedDocQuery vmap frmap sset
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
parseTypedDocMutation vmap frmap sset parseTypedDocMutation vmap frmap sset
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
parseTypedDocSubscription _ _ _ parseTypedDocSubscription _ _ _
= throwError "no subscriptions are defined in the schema" = throwError "no subscriptions are defined in the schema"
@ -170,14 +171,15 @@ instance
KnownName sub, ParseMethod p ('Service sub smethods) smethods KnownName sub, ParseMethod p ('Service sub smethods) smethods
) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where ) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where
parseTypedDocQuery vmap frmap sset parseTypedDocQuery vmap frmap sset
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
parseTypedDocMutation _ _ _ parseTypedDocMutation _ _ _
= throwError "no mutations are defined in the schema" = throwError "no mutations are defined in the schema"
parseTypedDocSubscription 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 case q of
[one] -> pure $ SubscriptionDoc one ServiceQuery [one]
_ -> throwError "subscriptions may only have one field" -> pure $ SubscriptionDoc one
_ -> throwError "subscriptions may only have one field"
instance instance
( p ~ 'Package pname ss, ( p ~ 'Package pname ss,
@ -185,7 +187,7 @@ instance
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods KnownName qr, ParseMethod p ('Service qr qmethods) qmethods
) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where ) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where
parseTypedDocQuery vmap frmap sset parseTypedDocQuery vmap frmap sset
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
parseTypedDocMutation _ _ _ parseTypedDocMutation _ _ _
= throwError "no mutations are defined in the schema" = throwError "no mutations are defined in the schema"
parseTypedDocSubscription _ _ _ parseTypedDocSubscription _ _ _
@ -201,12 +203,13 @@ instance
parseTypedDocQuery _ _ _ parseTypedDocQuery _ _ _
= throwError "no queries are defined in the schema" = throwError "no queries are defined in the schema"
parseTypedDocMutation 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 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 case q of
[one] -> pure $ SubscriptionDoc one ServiceQuery [one]
_ -> throwError "subscriptions may only have one field" -> pure $ SubscriptionDoc one
_ -> throwError "subscriptions may only have one field"
instance instance
( p ~ 'Package pname ss, ( p ~ 'Package pname ss,
@ -216,7 +219,7 @@ instance
parseTypedDocQuery _ _ _ parseTypedDocQuery _ _ _
= throwError "no queries are defined in the schema" = throwError "no queries are defined in the schema"
parseTypedDocMutation vmap frmap sset parseTypedDocMutation vmap frmap sset
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
parseTypedDocSubscription _ _ _ parseTypedDocSubscription _ _ _
= throwError "no subscriptions are defined in the schema" = throwError "no subscriptions are defined in the schema"
@ -230,10 +233,11 @@ instance
parseTypedDocMutation _ _ _ parseTypedDocMutation _ _ _
= throwError "no mutations are defined in the schema" = throwError "no mutations are defined in the schema"
parseTypedDocSubscription 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 case q of
[one] -> pure $ SubscriptionDoc one ServiceQuery [one]
_ -> throwError "subscriptions may only have one field" -> pure $ SubscriptionDoc one
_ -> throwError "subscriptions may only have one field"
instance instance
ParseTypedDoc p 'Nothing 'Nothing 'Nothing where 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 (constToValue v) m) l
| GQL.ObjectField a (GQL.Node v m) l <- n ] | 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 :: instance ( p ~ 'Package pname ss
forall (p :: Package') (s :: Symbol) pname ss methods f. , KnownName s
( MonadError T.Text f, p ~ 'Package pname ss, , ParseQuery' p s (LookupService ss s) )
LookupService ss s ~ 'Service s methods, => ParseQuery p s where
KnownName s, ParseMethod p ('Service s methods) methods parseQuery pp ps = parseQuery' pp ps (Proxy @(LookupService ss s))
) =>
Proxy p -> class ParseQuery' (p :: Package') (s :: Symbol) (svc :: Service') where
Proxy s -> parseQuery'
VariableMap -> FragmentMap -> [GQL.Selection] -> :: ( MonadError T.Text f, p ~ 'Package pname ss
f (ServiceQuery p (LookupService ss s)) , LookupService ss s ~ svc, KnownName s )
parseQuery _ _ _ _ [] = pure [] => Proxy p -> Proxy s -> Proxy svc
parseQuery pp ps vmap frmap (GQL.FieldSelection fld : ss) -> VariableMap -> FragmentMap -> [GQL.Selection]
= (++) <$> (maybeToList <$> fieldToMethod fld) -> f (ServiceQuery p svc)
<*> parseQuery pp ps vmap frmap ss
where instance (ParseQueryOneOf p elts)
fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods))) => ParseQuery' p s ('OneOf s elts) where
fieldToMethod f@(GQL.Field alias name args dirs sels _) parseQuery' pp _ps _ vmap frmap fs
| any (shouldSkip vmap) dirs = OneOfQuery <$> parseQueryOneOf pp (Proxy @elts) vmap frmap fs
= pure Nothing
| name == "__typename" class ParseQueryOneOf (p :: Package') (s :: [Symbol]) where
= case (args, sels) of parseQueryOneOf
([], []) -> pure $ Just $ TypeNameQuery alias :: ( MonadError T.Text f, p ~ 'Package pname ss )
_ -> throwError "__typename does not admit arguments nor selection of subfields" => Proxy p -> Proxy s
| name == "__schema" -> VariableMap -> FragmentMap -> [GQL.Selection]
= case args of -> f (NP (ChosenOneOfQuery p) s)
[] -> Just . SchemaQuery alias <$> unFragment frmap (F.toList sels)
_ -> throwError "__schema does not admit selection of subfields" instance ParseQueryOneOf p '[] where
| name == "__type" parseQueryOneOf _ _ _ _ _ = pure Nil
= let getString (GQL.String s) = Just s instance ( ParseQuery p s, KnownSymbol s
getString (GQL.Variable v) = HM.lookup v vmap >>= getString , ParseQueryOneOf p ss)
getString _ = Nothing => ParseQueryOneOf p (s ': ss) where
in case args of parseQueryOneOf pp _ps vmap frmap sel
[GQL.Argument _ (GQL.Node val _) _] = (:*) <$> (ChosenOneOfQuery (Proxy @s) <$> parseQuery pp (Proxy @s) vmap frmap sel)
-> case getString val of <*> parseQueryOneOf pp (Proxy @ss) vmap frmap sel
Just s -> Just . TypeQuery alias s <$> unFragment frmap sels
_ -> throwError "__type requires a string argument" instance ( ParseMethod p ('Service s methods) methods )
_ -> throwError "__type requires one single argument" => ParseQuery' p s ('Service s methods) where
| otherwise parseQuery' _pp _ps _psvc vmap frmap fs = ServiceQuery <$> go fs
= Just . OneMethodQuery alias where
<$> selectMethod (Proxy @('Service s methods)) go [] = pure []
(T.pack $ nameVal (Proxy @s)) go (GQL.FieldSelection fld : ss)
vmap frmap f = (++) <$> (maybeToList <$> fieldToMethod fld) <*> go ss
parseQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss) go (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)
| Just fr <- HM.lookup nm frmap | Just fr <- HM.lookup nm frmap
= if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr) = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)
then (++) <$> parseQuery pp ps vmap frmap (fdSelectionSet fr) then (++) <$> go (fdSelectionSet fr) <*> go ss
<*> parseQuery pp ps vmap frmap ss else go ss
else parseQuery pp ps vmap frmap ss | otherwise -- the fragment definition was not found
| otherwise -- the fragment definition was not found = throwError $ "fragment '" <> nm <> "' was not found"
= throwError $ "fragment '" <> nm <> "' was not found" go (_ : _) -- Inline fragments are not yet supported
parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported = throwError "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 :: VariableMap -> GQL.Directive -> Bool
shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _) shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _)
@ -362,7 +398,7 @@ instance ParseMethod p s '[] where
selectMethod _ tyName _ _ (fName -> wanted) selectMethod _ tyName _ _ (fName -> wanted)
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
instance instance
( KnownSymbol mname, ParseMethod p s ms ( KnownName mname, ParseMethod p s ms
, ParseArgs p s ('Method mname args r) args , ParseArgs p s ('Method mname args r) args
, ParseDifferentReturn p r) => , ParseDifferentReturn p r) =>
ParseMethod p s ('Method mname args r ': ms) ParseMethod p s ('Method mname args r ': ms)
@ -713,10 +749,8 @@ instance ParseReturn p r
=> ParseReturn p ('OptionalRef r) where => ParseReturn p ('OptionalRef r) where
parseReturn vmap frmap fname s parseReturn vmap frmap fname s
= RetOptional <$> parseReturn vmap frmap fname s = RetOptional <$> parseReturn vmap frmap fname s
instance ( p ~ 'Package pname ss, instance ( p ~ 'Package pname ss, ParseQuery p s )
LookupService ss s ~ 'Service s methods, => ParseReturn p ('ObjectRef s) where
KnownName s, ParseMethod p ('Service s methods) methods
) => ParseReturn p ('ObjectRef s) where
parseReturn vmap frmap _ s parseReturn vmap frmap _ s
= RetObject <$> parseQuery (Proxy @p) (Proxy @s) 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 = pure QueryEnum
parseSchema _ _ fname _ parseSchema _ _ fname _
= throwError $ "field '" <> fname <> "' should not have a selection of subfields" = 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 sch ('DRecord name fields) where
parseSchema vmap frmap _ s parseSchema vmap frmap _ s
= QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) 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. forall (sch :: Schema') t (rname :: Symbol) fields f.
( MonadError T.Text f ( MonadError T.Text f
, t ~  'DRecord rname fields , t ~  'DRecord rname fields
, KnownSymbol rname , KnownName rname
, ParseField sch fields ) => , ParseField sch fields ) =>
Proxy sch -> Proxy sch ->
Proxy t -> Proxy t ->
@ -790,7 +824,7 @@ instance ParseField sch '[] where
selectField tyName _ _ wanted _ selectField tyName _ _ wanted _
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
instance instance
(KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) => (KnownName fname, ParseField sch fs, ParseSchemaReturn sch r) =>
ParseField sch ('FieldDef fname r ': fs) ParseField sch ('FieldDef fname r ': fs)
where where
selectField tyName vmap frmap wanted sels selectField tyName vmap frmap wanted sels

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

@ -11,6 +11,7 @@
{-# language ScopedTypeVariables #-} {-# language ScopedTypeVariables #-}
{-# language TupleSections #-} {-# language TupleSections #-}
{-# language TypeApplications #-} {-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-} {-# language TypeOperators #-}
{-# language UndecidableInstances #-} {-# language UndecidableInstances #-}
{-# OPTIONS_GHC -fprint-explicit-foralls #-} {-# OPTIONS_GHC -fprint-explicit-foralls #-}
@ -36,9 +37,11 @@ import Data.Conduit.TQueue
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable
import GHC.TypeLits import GHC.TypeLits
import qualified Language.GraphQL.AST as GQL import qualified Language.GraphQL.AST as GQL
import Network.HTTP.Types.Header import Network.HTTP.Types.Header
import Unsafe.Coerce (unsafeCoerce)
import Mu.GraphQL.Query.Definition import Mu.GraphQL.Query.Definition
import qualified Mu.GraphQL.Query.Introspection as Intro 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 runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink
runQuery 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 ( RunQueryFindHandler m p hs chn ss s hs
, p ~ 'Package pname ss , p ~ 'Package pname ss
, s ~ 'Service sname ms , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> Intro.Schema -> ServerT chn GQL.Field p m hs -> 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 runQuery f req sch whole@(Services ss) path = runQueryFindHandler f req sch whole path ss
runSubscription 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 ( RunQueryFindHandler m p hs chn ss s hs
, p ~ 'Package pname ss , p ~ 'Package pname ss
, s ~ 'Service sname ms , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> ServerT chn GQL.Field p m hs -> 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 class RunQueryFindHandler m p whole chn ss s hs where
runQueryFindHandler runQueryFindHandler
:: ( p ~ 'Package pname wholess :: ( p ~ 'Package pname wholess
, s ~ 'Service sname ms , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> Intro.Schema -> ServerT chn GQL.Field p m whole -> 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 -> WriterT [GraphQLError] IO Aeson.Value
runSubscriptionFindHandler runSubscriptionFindHandler
:: ( p ~ 'Package pname wholess :: ( p ~ 'Package pname wholess
, s ~ 'Service sname ms , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> ServerT chn GQL.Field p m whole -> 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 () -> ConduitT Aeson.Value Void IO ()
-> 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) instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s)
=> RunQueryFindHandler m p whole chn '[] s '[] where => RunQueryFindHandler m p whole chn '[] s '[] where
runQueryFindHandler _ = error "this should never be called" runQueryFindHandler _ = error "this should never be called"
@ -302,17 +327,24 @@ instance {-# OVERLAPPABLE #-}
= runQueryFindHandler f req sch whole path that = runQueryFindHandler f req sch whole path that
runSubscriptionFindHandler f req whole path (_ :<&>: that) runSubscriptionFindHandler f req whole path (_ :<&>: that)
= runSubscriptionFindHandler f req whole path that = runSubscriptionFindHandler f req whole path that
instance {-# OVERLAPS #-} instance {-# OVERLAPS #-}
( s ~ 'Service sname ms, KnownName sname (RunQueryOnFoundHandler m p whole chn s h)
, RunMethod m p whole chn s ms h )
=> RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where => 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 = Aeson.object . catMaybes <$> mapM runOneQuery queries
where where
-- if we include the signature we have to write -- if we include the signature we have to write
-- an explicit type signature for 'runQueryFindHandler' -- an explicit type signature for 'runQueryFindHandler'
runOneQuery (OneMethodQuery nm args) 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 -- handle __typename
runOneQuery (TypeNameQuery nm) runOneQuery (TypeNameQuery nm)
= let realName = fromMaybe "__typename" nm = let realName = fromMaybe "__typename" nm
@ -333,23 +365,59 @@ instance {-# OVERLAPS #-}
path] path]
pure $ Just (realName, Aeson.Null) pure $ Just (realName, Aeson.Null)
-- subscriptions should only have one element -- subscriptions should only have one element
runSubscriptionFindHandler f req whole path (this :<&>: _) inh (OneMethodQuery nm args) sink runSubscriptionOnFoundHandler f req whole path (ProperSvc this) inh (OneMethodQuery nm args) sink
= runMethodSubscription f req whole (Proxy @s) path nm inh this args sink = runMethodSubscription f req whole (Proxy @('Service sname ms)) path nm inh this args sink
runSubscriptionFindHandler _ _ _ _ _ _ (TypeNameQuery nm) sink runSubscriptionOnFoundHandler _ _ _ _ _ _ (TypeNameQuery nm) sink
= let realName = fromMaybe "__typename" nm = let realName = fromMaybe "__typename" nm
o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))] o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))]
in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink
runSubscriptionFindHandler _ _ _ _ _ _ _ sink runSubscriptionOnFoundHandler _ _ _ _ _ _ _ sink
= runConduit $ yieldMany = runConduit $ yieldMany
([singleErrValue "__schema and __type are not supported in subscriptions"] ([singleErrValue "__schema and __type are not supported in subscriptions"]
:: [Aeson.Value]) :: [Aeson.Value])
.| sink .| 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 class RunMethod m p whole chn s ms hs where
runMethod runMethod
:: ( p ~ 'Package pname wholess :: ( p ~ 'Package pname wholess
, s ~ 'Service sname allMs , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> ServerT chn GQL.Field p m whole -> 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)) -> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value))
runMethodSubscription runMethodSubscription
:: ( p ~ 'Package pname wholess :: ( p ~ 'Package pname wholess
, s ~ 'Service sname allMs , inh ~ MappingRight chn (ServiceName s) )
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a) => (forall a. m a -> ServerErrorIO a)
-> RequestHeaders -> RequestHeaders
-> ServerT chn GQL.Field p m whole -> 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 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) (S cont)
= runMethod f req whole p path nm inh r cont = runMethod f req whole p path nm inh r cont
runMethod _ _ _ _ _ _ _ _ _ = error "this should never happen"
-- handle subscriptions -- handle subscriptions
runMethodSubscription f req whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) sink 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 = 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 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) (S cont) sink
= runMethodSubscription f req whole p path nm inh r 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 class Handles chn args r m h
=> RunHandler m p whole chn args r h where => RunHandler m p whole chn args r h where
@ -518,9 +587,9 @@ instance ( ToSchema sch l r
convertResult _ _ _ _ (RetSchema r) t convertResult _ _ _ _ (RetSchema r) t
= pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r = pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r
instance ( MappingRight chn ref ~ t instance ( MappingRight chn ref ~ t
, MappingRight chn sname ~ t , MappingRight chn (ServiceName svc) ~ t
, LookupService ss ref ~ 'Service sname ms , LookupService ss ref ~ svc
, RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname ms) whole) , RunQueryFindHandler m ('Package pname ss) whole chn ss svc whole)
=> ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where => ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where
convertResult f req whole path (RetObject q) h convertResult f req whole path (RetObject q) h
= Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f req = 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 = case HM.lookup t ts of
Nothing -> pure Nothing Nothing -> pure Nothing
Just ty -> runIntroType path s ty ss 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 = do things <- catMaybes <$> traverse runOne ss
pure $ Just $ Aeson.object things pure $ Just $ Aeson.object things
where where
@ -683,7 +752,12 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
("interfaces", _) ("interfaces", _)
-> pure $ Just $ Aeson.Array [] -> pure $ Just $ Aeson.Array []
("possibleTypes", _) ("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 _ -> do tell [GraphQLError
(ServerError Invalid (ServerError Invalid

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

@ -41,7 +41,7 @@ library
, mu-grpc-common >=0.4 && <0.5 , mu-grpc-common >=0.4 && <0.5
, mu-optics >=0.3 && <0.4 , mu-optics >=0.3 && <0.4
, mu-protobuf >=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 , mu-schema >=0.3 && <0.4
, optics-core >=0.2 && <0.4 , optics-core >=0.2 && <0.4
, sop-core >=0.5 && <0.6 , 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 , http2-grpc-types >=0.5 && <0.6
, mu-avro >=0.4 && <0.5 , mu-avro >=0.4 && <0.5
, mu-protobuf >=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 , mu-schema >=0.3 && <0.4
hs-source-dirs: src hs-source-dirs: src

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

@ -1,5 +1,5 @@
name: mu-grpc-server name: mu-grpc-server
version: 0.4.0.0 version: 0.5.0.0
synopsis: gRPC servers for Mu definitions synopsis: gRPC servers for Mu definitions
description: description:
With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell! With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell!
@ -33,7 +33,7 @@ library
, mtl >=2.2 && <3 , mtl >=2.2 && <3
, mu-grpc-common >=0.4 && <0.5 , mu-grpc-common >=0.4 && <0.5
, mu-protobuf >=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 , mu-schema >=0.3 && <0.4
, sop-core >=0.5 && <0.6 , sop-core >=0.5 && <0.6
, stm >=2.5 && <3 , stm >=2.5 && <3
@ -59,9 +59,9 @@ executable grpc-example-server
, http2-grpc-types >=0.5 && <0.6 , http2-grpc-types >=0.5 && <0.6
, mtl >=2.2 && <3 , mtl >=2.2 && <3
, mu-grpc-common >=0.4 && <0.5 , mu-grpc-common >=0.4 && <0.5
, mu-grpc-server >=0.4 && <0.5 , mu-grpc-server
, mu-protobuf >=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 , mu-schema >=0.3 && <0.4
, sop-core >=0.5 && <0.6 , sop-core >=0.5 && <0.6
, stm >=2.5 && <3 , 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.Conduit.TMChan
import Data.Kind import Data.Kind
import Data.Proxy import Data.Proxy
import GHC.TypeLits
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed) import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..)) import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..))
import Network.GRPC.Server.Handlers.Trans import Network.GRPC.Server.Handlers.Trans
@ -174,12 +175,15 @@ instance ( KnownName name
p m chn (MappingRight chn name) methods h p m chn (MappingRight chn name) methods h
, GRpcServiceHandlers fullP p m chn rest hs ) , GRpcServiceHandlers fullP p m chn rest hs )
=> GRpcServiceHandlers fullP p m chn ('Service name methods ': rest) (h ': hs) where => 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 = gRpcMethodHandlers f pfullP (Proxy @('Service name methods)) pr
packageName serviceName svr packageName serviceName svr
++ gRpcServiceHandlers f pfullP pr packageName rest ++ gRpcServiceHandlers f pfullP pr packageName rest
where serviceName = BS.pack (nameVal (Proxy @name)) 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)) class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm))
(fullS :: Service 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 name: mu-prometheus
version: 0.4.0.0 version: 0.5.0.0
synopsis: Metrics support for Mu using Prometheus synopsis: Metrics support for Mu using Prometheus
description: Get metrics of your running Mu servers using Prometheus description: Get metrics of your running Mu servers using Prometheus
license: Apache-2.0 license: Apache-2.0
@ -22,12 +22,12 @@ library
build-depends: build-depends:
base >=4.12 && <5 base >=4.12 && <5
, lifted-base >=0.2 && <0.3 , lifted-base >=0.2 && <0.3
, monad-control >1 && <2 , monad-control >1 && <2
, mu-rpc >=0.4 && <0.5 , mu-rpc >=0.5 && <0.6
, prometheus-client >1 && <2 , prometheus-client >1 && <2
, text >=1.2 && <2 , text >=1.2 && <2
, wai >=3.2 && <4 , wai >=3.2 && <4
, wai-middleware-prometheus >1 && <2 , wai-middleware-prometheus >1 && <2
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 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 prometheusMetrics metrics NoRpcInfo run = do
incGauge (activeCalls metrics) incGauge (activeCalls metrics)
run `finally` decGauge (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) 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 () ( do -- We are forced to use a MVar because 'withLabel' only allows IO ()
r <- liftBaseWith $ \runInIO -> do r <- liftBaseWith $ \runInIO -> do
result :: MVar (StM m a) <- newEmptyMVar result :: MVar (StM m a) <- newEmptyMVar
withLabel (callsTotal metrics) (sname, mname) $ \h -> withLabel (callsTotal metrics) (sname', mname') $ \h ->
h `observeDuration` (runInIO run >>= putMVar result) h `observeDuration` (runInIO run >>= putMVar result)
takeMVar result takeMVar result
x <- restoreM r x <- restoreM r
withLabel (messagesSent metrics) (sname, mname) incCounter withLabel (messagesSent metrics) (sname', mname') incCounter
pure x ) pure x )
`finally` decGauge (activeCalls metrics) `finally` decGauge (activeCalls metrics)

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

@ -1,5 +1,5 @@
name: mu-servant-server name: mu-servant-server
version: 0.4.0.0 version: 0.5.0.0
synopsis: Servant servers for Mu definitions synopsis: Servant servers for Mu definitions
description: description:
With @mu-servant-server@ you can easily build Servant servers for mu-haskell! With @mu-servant-server@ you can easily build Servant servers for mu-haskell!
@ -30,7 +30,7 @@ library
, generic-aeson >=0.2 && <0.3 , generic-aeson >=0.2 && <0.3
, ghc-prim >=0.5 && <0.7 , ghc-prim >=0.5 && <0.7
, mtl >=2.2 && <3 , mtl >=2.2 && <3
, mu-rpc >=0.4 && <0.5 , mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4 , mu-schema >=0.3 && <0.4
, servant >=0.16 && <0.19 , servant >=0.16 && <0.19
, servant-server >=0.16 && <0.19 , servant-server >=0.16 && <0.19
@ -49,7 +49,7 @@ executable servant-example-server
aeson >=1.4 && <2 aeson >=1.4 && <2
, base >=4.12 && <5 , base >=4.12 && <5
, conduit >=1.3.2 && <2 , conduit >=1.3.2 && <2
, mu-rpc >=0.4 && <0.5 , mu-rpc >=0.5 && <0.6
, mu-schema >=0.3 && <0.4 , mu-schema >=0.3 && <0.4
, mu-servant-server , mu-servant-server
, servant-server >=0.16 && <0.19 , 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.Conduit.Internal (ConduitT (..), Pipe (..))
import Data.Kind import Data.Kind
import Data.Swagger (Swagger, ToSchema (..)) import Data.Swagger (Swagger, ToSchema (..))
import Generics.Generic.Aeson
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
import GHC.Types (Any) import GHC.Types (Any)
import Generics.Generic.Aeson
import Mu.Rpc import Mu.Rpc
import Mu.Rpc.Annotations import Mu.Rpc.Annotations
import Mu.Schema import Mu.Schema
@ -170,10 +170,16 @@ instance
type type
ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) = ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) =
MethodsAPI pkg sname methods hs :<|> ServicesAPI pkg rest 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 servantMethodHandlers f pkgP (Proxy @sname) svr
:<|> servantServiceHandlers f pkgP rest :<|> 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 class
ServantMethodHandlers ServantMethodHandlers
(pkg :: Package Symbol Symbol anm (TypeRef Symbol)) (pkg :: Package Symbol Symbol anm (TypeRef Symbol))