higherkindness/mu-haskell
1
1
Fork 0
mirror of https://github.com/higherkindness/mu-haskell.git synced 2024-09-11 14:36:01 +03:00
Code Issues Projects Releases Wiki Activity

Add parameter to RpcInfo (#205)

Browse Source
This commit is contained in:
Alejandro Serrano 2020-06-22 14:24:05 +02:00 committed by GitHub
parent 1d7a52a2a6
commit bf00ed67d8
21 changed files with 174 additions and 154 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -131,11 +131,12 @@ data Return serviceName tyRef where
-- | Reflection
data RpcInfo
data RpcInfo i
= NoRpcInfo
| RpcInfo { packageInfo :: Package Text Text Text TyInfo
, serviceInfo :: Service Text Text Text TyInfo
, methodInfo :: Method Text Text Text TyInfo
, extraInfo :: i
}
data TyInfo
@ -144,16 +145,16 @@ data TyInfo
| TyTy Text
deriving (Show, Eq)
instance Show RpcInfo where
instance Show (RpcInfo i) where
show NoRpcInfo
= "<no info>"
show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _))
show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _)
= T.unpack (s <> ":" <> m)
show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _))
show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _)
= T.unpack (p <> ":" <> s <> ":" <> m)
class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RpcInfo
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> i -> RpcInfo i
class ReflectService (s :: Service') where
reflectService :: Proxy s -> Service Text Text Text TyInfo
class ReflectMethod (m :: Method') where

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

@ -70,8 +70,8 @@ newtype HiRequest = HiRequest { number :: Int }
, ToSchema QuickstartSchema "HiRequest"
, FromSchema QuickstartSchema "HiRequest" )
quickstartServer :: forall m. (MonadServer m)
=> ServerT '[] QuickStartService m _
quickstartServer :: forall m i. (MonadServer m)
=> ServerT '[] i QuickStartService m _
quickstartServer
-- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
= singleService ( method @"SayHello" sayHello
@ -110,7 +110,8 @@ type ApolloBookAuthor = '[
, "Author" ':-> Integer
]
apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _
apolloServer :: forall m i. (MonadServer m)
=> ServerT ApolloBookAuthor i ApolloService m _
apolloServer
= resolver
( object @"Author" ( field @"name" authorName

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

@ -84,7 +84,7 @@ type ServerErrorIO = ExceptT ServerError IO
-- | Simple 'ServerT' which uses only 'IO' and errors,
-- and whose service has no back-references.
type ServerIO srv = ServerT '[] srv ServerErrorIO
type ServerIO info srv = ServerT '[] info srv ServerErrorIO
-- | Stop the current handler,
-- returning an error to the client.
@ -133,24 +133,26 @@ type SingleServerT = ServerT '[]
-- | Definition of a complete server
-- for a set of services, with possible
-- references between them.
data ServerT (chn :: ServiceChain snm) (s :: Package snm mnm anm (TypeRef snm))
data ServerT (chn :: ServiceChain snm) (info :: Type)
(s :: Package snm mnm anm (TypeRef snm))
(m :: Type -> Type) (hs :: [[Type]]) where
Services :: ServicesT chn s m hs
-> ServerT chn ('Package pname s) m hs
Services :: ServicesT chn info s m hs
-> ServerT chn info ('Package pname s) m hs
pattern Server :: (MappingRight chn sname ~ ())
=> HandlersT chn () methods m hs
-> ServerT chn ('Package pname '[ 'Service sname methods ]) m '[hs]
=> HandlersT chn info () methods m hs
-> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
pattern Server svr = Services (svr :<&>: S0)
infixr 3 :<&>:
-- | Definition of a complete server for a service.
data ServicesT (chn :: ServiceChain snm) (s :: [Service snm mnm anm (TypeRef snm)])
data ServicesT (chn :: ServiceChain snm) (info :: Type)
(s :: [Service snm mnm anm (TypeRef snm)])
(m :: Type -> Type) (hs :: [[Type]]) where
S0 :: ServicesT chn '[] m '[]
(:<&>:) :: HandlersT chn (MappingRight chn sname) methods m hs
-> ServicesT chn rest m hss
-> ServicesT chn ('Service sname methods ': rest) m (hs ': hss)
S0 :: ServicesT chn info '[] m '[]
(:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs
-> ServicesT chn info rest m hss
-> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)
-- | 'HandlersT' is a sequence of handlers.
-- Note that the handlers for your service
@ -171,26 +173,27 @@ data ServicesT (chn :: ServiceChain snm) (s :: [Service snm mnm anm (TypeRef snm
-- * Output streams turn into an __additional argument__
-- of type @Conduit t Void m ()@. This stream should
-- be connected to a source to get the elements.
data HandlersT (chn :: ServiceChain snm)
data HandlersT (chn :: ServiceChain snm) (info :: Type)
(inh :: *) (methods :: [Method snm mnm anm (TypeRef snm)])
(m :: Type -> Type) (hs :: [Type]) where
H0 :: HandlersT chn inh '[] m '[]
H0 :: HandlersT chn info inh '[] m '[]
Hmore :: Handles chn args ret m h
=> Proxy args -> Proxy ret
-> (RpcInfo -> inh -> h) -> HandlersT chn inh ms m hs
-> HandlersT chn inh ('Method name args ret ': ms) m (h ': hs)
-> (RpcInfo info -> inh -> h)
-> HandlersT chn info inh ms m hs
-> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs)
infixr 4 :<||>:
pattern (:<||>:) :: Handles chn args ret m h
=> (RpcInfo -> inh -> h) -> HandlersT chn inh ms m hs
-> HandlersT chn inh ('Method name args ret ': ms) m (h ': hs)
=> (RpcInfo info -> inh -> h) -> HandlersT chn info inh ms m hs
-> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs)
pattern x :<||>: xs <- Hmore _ _ x xs where
x :<||>: xs = Hmore Proxy Proxy x xs
infixr 4 :<|>:
pattern (:<|>:) :: (Handles chn args ret m h)
=> h -> HandlersT chn () ms m hs
-> HandlersT chn () ('Method name args ret ': ms) m (h ': hs)
=> h -> HandlersT chn info () ms m hs
-> HandlersT chn info () ('Method name args ret ': ms) m (h ': hs)
pattern x :<|>: xs <- (($ ()) . ($ NoRpcInfo) -> x) :<||>: xs where
x :<|>: xs = noContext x :<||>: xs
@ -265,14 +268,14 @@ method f = Named (\_ _ -> f)
-- Intended to be used with @TypeApplications@:
--
-- > methodWithInfo @"myMethod" myHandler
methodWithInfo :: forall n p. (RpcInfo -> p) -> Named n (RpcInfo -> () -> p)
methodWithInfo :: forall n p info. (RpcInfo info -> p) -> Named n (RpcInfo info -> () -> p)
methodWithInfo f = Named (\x () -> f x)
-- | Declares the handler for a field in an object.
-- Intended to be used with @TypeApplications@:
--
-- > field @"myField" myHandler
field :: forall n h. h -> Named n (RpcInfo -> h)
field :: forall n h info. h -> Named n (RpcInfo info -> h)
field f = Named (const f)
-- | Declares the handler for a field in an object,
@ -280,7 +283,7 @@ field f = Named (const f)
-- Intended to be used with @TypeApplications@:
--
-- > fieldWithInfo @"myField" myHandler
fieldWithInfo :: forall n h. (RpcInfo -> h) -> Named n (RpcInfo -> h)
fieldWithInfo :: forall n h info. (RpcInfo info -> h) -> Named n (RpcInfo info -> h)
fieldWithInfo = Named
-- | Defines a server for a package with a single service.
@ -288,8 +291,10 @@ fieldWithInfo = Named
--
-- > singleService (method @"m1" h1, method @"m2" h2)
singleService
:: (ToNamedList p nl, ToHandlers chn () methods m hs nl, MappingRight chn sname ~ ())
=> p -> ServerT chn ('Package pname '[ 'Service sname methods ]) m '[hs]
:: ( ToNamedList p nl
, ToHandlers chn info () methods m hs nl
, MappingRight chn sname ~ () )
=> p -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
singleService nl = Server $ toHandlers $ toNamedList nl
-- | Defines the implementation of a single GraphQL object,
@ -302,9 +307,10 @@ singleService nl = Server $ toHandlers $ toNamedList nl
-- Note: for the root objects in GraphQL (query, mutation, subscription)
-- use 'method' instead of 'object'.
object
:: forall sname p nl chn ms m hs.
(ToNamedList p nl, ToHandlers chn (MappingRight chn sname) ms m hs nl)
=> p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
:: forall sname p nl chn info ms m hs.
( ToNamedList p nl
, ToHandlers chn info (MappingRight chn sname) ms m hs nl )
=> p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
object nl = Named $ toHandlers $ toNamedList nl
-- | Combines the implementation of several GraphQL objects,
@ -313,8 +319,8 @@ object nl = Named $ toHandlers $ toNamedList nl
--
-- > resolver (object @"o1" ..., object @"o2" ...)
resolver
:: (ToNamedList p nl, ToServices chn ss m hs nl)
=> p -> ServerT chn ('Package pname ss) m hs
:: (ToNamedList p nl, ToServices chn info ss m hs nl)
=> p -> ServerT chn info ('Package pname ss) m hs
resolver nl = Services $ toServices $ toNamedList nl
-- | A value tagged with a type-level name.
@ -364,37 +370,39 @@ instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named
'[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9) ] where
toNamedList (n1, n2, n3, n4, n5, n6, n7, n8, n9) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: n9 :|: N0
class ToHandlers chn inh ms m hs nl | chn inh ms m nl -> hs where
class ToHandlers chn info inh ms m hs nl | chn inh ms m nl -> hs where
toHandlers :: NamedList nl
-> HandlersT chn inh ms m hs
-> HandlersT chn info inh ms m hs
instance ToHandlers chn inh '[] m '[] nl where
instance ToHandlers chn info inh '[] m '[] nl where
toHandlers _ = H0
instance (FindHandler name inh h nl, Handles chn args ret m h, ToHandlers chn inh ms m hs nl)
=> ToHandlers chn inh ('Method name args ret ': ms) m (h ': hs) nl where
instance ( FindHandler name info inh h nl
, Handles chn args ret m h
, ToHandlers chn info inh ms m hs nl )
=> ToHandlers chn info inh ('Method name args ret ': ms) m (h ': hs) nl where
toHandlers nl = findHandler (Proxy @name) nl :<||>: toHandlers nl
class FindHandler name inh h nl | name nl -> inh h where
findHandler :: Proxy name -> NamedList nl -> RpcInfo -> inh -> h
class FindHandler name info inh h nl | name nl -> inh h where
findHandler :: Proxy name -> NamedList nl -> RpcInfo info -> inh -> h
instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))
=> FindHandler name inh h '[] where
=> FindHandler name info inh h '[] where
findHandler = error "this should never be called"
instance {-# OVERLAPS #-} (RpcInfo ~ rpc', inh ~ inh', h ~ h')
=> FindHandler name inh h ( '(name, rpc' -> inh' -> h') ': rest ) where
instance {-# OVERLAPS #-} (RpcInfo info ~ rpc', inh ~ inh', h ~ h')
=> FindHandler name info inh h ( '(name, rpc' -> inh' -> h') ': rest ) where
findHandler _ (Named f :|: _) = f
instance {-# OVERLAPPABLE #-} FindHandler name inh h rest
=> FindHandler name inh h (thing ': rest) where
instance {-# OVERLAPPABLE #-} FindHandler name info inh h rest
=> FindHandler name info inh h (thing ': rest) where
findHandler p (_ :|: rest) = findHandler p rest
class ToServices chn ss m hs nl | chn ss m nl -> hs where
class ToServices chn info ss m hs nl | chn ss m nl -> hs where
toServices :: NamedList nl
-> ServicesT chn ss m hs
-> ServicesT chn info ss m hs
instance ToServices chn '[] m '[] nl where
instance ToServices chn info '[] m '[] nl where
toServices _ = S0
instance ( FindService name (HandlersT chn (MappingRight chn name) methods m h) nl
, ToServices chn ss m hs nl)
=> ToServices chn ('Service name methods ': ss) m (h ': hs) 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
class FindService name h nl | name nl -> h where
@ -412,20 +420,21 @@ instance {-# OVERLAPPABLE #-} FindService name h rest
-- WRAPPING MECHANISM
wrapServer
:: forall chn p m topHs.
(forall a. RpcInfo -> m a -> m a)
-> ServerT chn p m topHs -> ServerT chn p m topHs
:: forall chn info p m topHs.
(forall a. RpcInfo info -> m a -> m a)
-> ServerT chn info p m topHs -> ServerT chn info p m topHs
wrapServer f (Services ss) = Services (wrapServices ss)
where
wrapServices :: forall ss hs.
ServicesT chn ss m hs -> ServicesT chn ss m hs
ServicesT chn info ss m hs
-> ServicesT chn info ss m hs
wrapServices S0 = S0
wrapServices (h :<&>: rest)
= wrapHandlers h :<&>: wrapServices rest
wrapHandlers :: forall inh ms innerHs.
HandlersT chn inh ms m innerHs
-> HandlersT chn inh ms m innerHs
HandlersT chn info inh ms m innerHs
-> HandlersT chn info inh ms m innerHs
wrapHandlers H0 = H0
wrapHandlers (Hmore pargs pret h rest)
= Hmore pargs pret

12
examples/health-check/mu-example-health-check.cabal
View File

@ -1,5 +1,5 @@
name: mu-example-health-check
version: 0.3.0.0
version: 0.4.0.0
synopsis:
Example health-check project from mu-scala (with protobuf) ported to mu-haskell
@ -26,10 +26,10 @@ executable health-server
, conduit
, deferred-folds
, mu-graphql
, mu-grpc-server >=0.3.0
, mu-grpc-server >=0.4.0
, mu-prometheus
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, stm
, stm-conduit
@ -49,8 +49,8 @@ executable health-client-tyapps
base >=4.12 && <5
, conduit
, mu-grpc-client >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, text

2
examples/health-check/src/Server.hs
View File

@ -45,7 +45,7 @@ main = do
type StatusMap = M.Map T.Text T.Text
type StatusUpdates = TBMChan HealthStatusMsg
server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _
server :: StatusMap -> StatusUpdates -> ServerIO info HealthCheckService _
server m upd
= wrapServer (\info h -> liftIO (print info) >> h) $
singleService ( method @"setStatus" $ setStatus_ m upd

8
examples/route-guide/mu-example-route-guide.cabal
View File

@ -1,5 +1,5 @@
name: mu-example-route-guide
version: 0.3.0.0
version: 0.4.0.0
synopsis:
Example route-guide project from mu-scala ported to mu-haskell
@ -26,9 +26,9 @@ executable route-guide-server
, base >=4.12 && <5
, conduit
, hashable
, mu-grpc-server >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-grpc-server >=0.4.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, stm
, stm-chans

2
examples/route-guide/src/Server.hs
View File

@ -69,7 +69,7 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2)
-- Server implementation
-- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/server/src/main/scala/handlers/RouteGuideServiceHandler.scala
server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _
server :: Features -> TBMChan RouteNote -> ServerIO info RouteGuideService _
server f m
= singleService ( method @"GetFeature" $ getFeature f
, method @"ListFeatures" $ listFeatures f

12
examples/seed/mu-example-seed.cabal
View File

@ -35,9 +35,9 @@ executable seed-server
, conduit
, monad-logger
, mu-graphql
, mu-grpc-server >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-grpc-server >=0.4.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, random
, stm
@ -53,10 +53,10 @@ executable seed-server-optics
base >=4.12 && <5
, conduit
, monad-logger
, mu-grpc-server >=0.3.0
, mu-grpc-server >=0.4.0
, mu-optics >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, random
, stm

2
examples/seed/src/Main.hs
View File

@ -85,7 +85,7 @@ main = do
-- Server implementation
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
server :: (MonadServer m, MonadLogger m) => SingleServerT PeopleService m _
server :: (MonadServer m, MonadLogger m) => SingleServerT info PeopleService m _
server = singleService
( method @"getPerson" getPerson
, method @"getPersonStream" getPersonStream

2
examples/seed/src/Optics.hs
View File

@ -38,7 +38,7 @@ main = do
-- Server implementation
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
server :: (MonadServer m, MonadLogger m) => SingleServerT PeopleService m _
server :: (MonadServer m, MonadLogger m) => SingleServerT info PeopleService m _
server = singleService
( method @"getPerson" getPerson
, method @"getPersonStream" getPersonStream

6
examples/todolist/mu-example-todolist.cabal
View File

@ -20,9 +20,9 @@ executable todolist-server
other-modules: Definition
build-depends:
base >=4.12 && <5
, mu-grpc-server >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-grpc-server >=0.4.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, stm
, text

2
examples/todolist/src/Server.hs
View File

@ -31,7 +31,7 @@ main = do
type Id = TVar Int32
type TodoList = TVar [TodoListMessage]
server :: Id -> TodoList -> ServerIO TodoListService _
server :: Id -> TodoList -> ServerIO info TodoListService _
server i t
= singleService ( method @"reset" $ reset i t
, method @"insert" $ insert i t

18
examples/with-persistent/mu-example-with-persistent.cabal
View File

@ -24,10 +24,10 @@ executable persistent-server
base >=4.12 && <5
, conduit
, monad-logger
, mu-grpc-server >=0.3.0
, mu-grpc-server >=0.4.0
, mu-persistent >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, persistent
, persistent-sqlite
@ -42,8 +42,8 @@ executable persistent-client
, conduit
, mu-grpc-client >=0.3.0
, mu-persistent >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, persistent
, persistent-sqlite
@ -62,8 +62,8 @@ executable persistent-client-record
, conduit
, mu-grpc-client >=0.3.0
, mu-persistent >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, persistent
, persistent-sqlite
@ -83,8 +83,8 @@ executable persistent-client-optics
, mu-grpc-client >=0.3.0.0
, mu-optics >=0.3.0.0
, mu-persistent >=0.3.0
, mu-protobuf >=0.3.0
, mu-rpc >=0.3.0
, mu-protobuf >=0.4.0
, mu-rpc >=0.4.0
, mu-schema >=0.3.0
, persistent
, persistent-sqlite

2
examples/with-persistent/src/Server.hs
View File

@ -27,7 +27,7 @@ main = do
runDb conn $ runMigration migrateAll
liftIO $ runGRpcApp msgProtoBuf 1234 (server conn)
server :: SqlBackend -> SingleServerT PersistentService ServerErrorIO _
server :: SqlBackend -> SingleServerT info PersistentService ServerErrorIO _
server p
= singleService ( method @"getPerson" $ getPerson p
, method @"newPerson" $ newPerson p

3
graphql/exe/Main.hs
View File

@ -63,7 +63,8 @@ library
, (3, "Michael Ende", [(4, "The Neverending Story"), (5, "Momo")])
]
libraryServer :: forall m. (MonadServer m) => ServerT ServiceMapping ServiceDefinition m _
libraryServer :: forall m i. (MonadServer m)
=> ServerT ServiceMapping i ServiceDefinition m _
libraryServer
= resolver ( object @"Book" ( field @"id" bookId
, field @"title" bookTitle

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

@ -55,7 +55,8 @@ data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm))
(m :: Method snm mnm anm (TypeRef snm)) where
ChosenMethodQuery
:: NP (ArgumentValue p) args
:: GQL.Field
-> NP (ArgumentValue p) args
-> ReturnQuery p r
-> ChosenMethodQuery p ('Method mname args r)

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

@ -267,7 +267,7 @@ parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
<*> parseQuery pp ps vmap frmap ss
where
fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))
fieldToMethod (GQL.Field alias name args dirs sels)
fieldToMethod f@(GQL.Field alias name args dirs sels)
| any (shouldSkip vmap) dirs
= pure Nothing
| GQL.unName name == "__typename"
@ -291,7 +291,9 @@ parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
_ -> throwError "__type requires one single argument"
| otherwise
= Just . OneMethodQuery (GQL.unName . GQL.unAlias <$> alias)
<$> selectMethod (Proxy @('Service s methods)) (T.pack $ nameVal (Proxy @s)) vmap frmap name args sels
<$> selectMethod (Proxy @('Service s methods))
(T.pack $ nameVal (Proxy @s))
vmap frmap f
parseQuery pp ps vmap frmap (GQL.SelectionFragmentSpread (GQL.FragmentSpread nm dirs) : ss)
| Just fr <- HM.lookup (GQL.unName nm) frmap
= if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ GQL._fdDirectives fr)
@ -337,13 +339,14 @@ class ParseMethod (p :: Package') (s :: Service') (ms :: [Method']) where
T.Text ->
VariableMap ->
FragmentMap ->
GQL.Name ->
GQL.Field ->
{- GQL.Name ->
[GQL.Argument] ->
GQL.SelectionSet ->
GQL.SelectionSet -> -}
f (NS (ChosenMethodQuery p) ms)
instance ParseMethod p s '[] where
selectMethod _ tyName _ _ (GQL.unName -> wanted) _ _
selectMethod _ tyName _ _ (GQL.unName . GQL._fName -> wanted)
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
instance
( KnownSymbol mname, ParseMethod p s ms
@ -351,13 +354,13 @@ instance
, ParseDifferentReturn p r) =>
ParseMethod p s ('Method mname args r ': ms)
where
selectMethod s tyName vmap frmap w@(GQL.unName -> wanted) args sels
selectMethod s tyName vmap frmap f@(GQL.Field _ (GQL.unName -> wanted) args _ sels)
| wanted == mname
= Z <$> (ChosenMethodQuery <$> parseArgs (Proxy @s) (Proxy @('Method mname args r))
vmap args
<*> parseDiffReturn vmap frmap wanted sels)
= Z <$> (ChosenMethodQuery f
<$> parseArgs (Proxy @s) (Proxy @('Method mname args r)) vmap args
<*> parseDiffReturn vmap frmap wanted sels)
| otherwise
= S <$> selectMethod s tyName vmap frmap w args sels
= S <$> selectMethod s tyName vmap frmap f
where
mname = T.pack $ nameVal (Proxy @mname)

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

@ -57,7 +57,7 @@ type GraphQLApp p qr mut sub m chn hs
runPipeline
:: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr -> Proxy mut -> Proxy sub
-> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument
-> IO Aeson.Value
@ -73,7 +73,7 @@ runPipeline f svr _ _ _ opName vmap doc
runSubscriptionPipeline
:: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr -> Proxy mut -> Proxy sub
-> Maybe T.Text -> VariableMapC -> GQL.ExecutableDocument
-> ConduitT Aeson.Value Void IO ()
@ -116,12 +116,12 @@ class RunDocument (p :: Package')
m chn hs where
runDocument ::
(forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Document p qr mut sub
-> WriterT [GraphQLError] IO Aeson.Value
runDocumentSubscription ::
(forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Document p qr mut sub
-> ConduitT Aeson.Value Void IO ()
-> IO ()
@ -216,7 +216,7 @@ yieldDocument ::
forall p qr mut sub m chn hs.
RunDocument p qr mut sub m chn hs
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Document p qr mut sub
-> ConduitT Aeson.Value Void IO ()
-> IO ()
@ -235,7 +235,7 @@ runQuery
, s ~ 'Service sname ms
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> Intro.Schema -> ServerT chn p m hs
-> Intro.Schema -> ServerT chn GQL.Field p m hs
-> [T.Text]
-> inh
-> ServiceQuery p s
@ -249,7 +249,7 @@ runSubscription
, s ~ 'Service sname ms
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> [T.Text]
-> inh
-> OneMethodQuery p s
@ -264,9 +264,9 @@ class RunQueryFindHandler m p whole chn ss s hs where
, s ~ 'Service sname ms
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> Intro.Schema -> ServerT chn p m whole
-> Intro.Schema -> ServerT chn GQL.Field p m whole
-> [T.Text]
-> ServicesT chn ss m hs
-> ServicesT chn GQL.Field ss m hs
-> inh
-> ServiceQuery p s
-> WriterT [GraphQLError] IO Aeson.Value
@ -275,9 +275,9 @@ class RunQueryFindHandler m p whole chn ss s hs where
, s ~ 'Service sname ms
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> [T.Text]
-> ServicesT chn ss m hs
-> ServicesT chn GQL.Field ss m hs
-> inh
-> OneMethodQuery p s
-> ConduitT Aeson.Value Void IO ()
@ -343,9 +343,9 @@ class RunMethod m p whole chn s ms hs where
, s ~ 'Service sname allMs
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> Proxy s -> [T.Text] -> Maybe T.Text -> inh
-> HandlersT chn inh ms m hs
-> HandlersT chn GQL.Field inh ms m hs
-> NS (ChosenMethodQuery p) ms
-> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value))
runMethodSubscription
@ -353,9 +353,9 @@ class RunMethod m p whole chn s ms hs where
, s ~ 'Service sname allMs
, inh ~ MappingRight chn sname )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> Proxy s -> [T.Text] -> Maybe T.Text -> inh
-> HandlersT chn inh ms m hs
-> HandlersT chn GQL.Field inh ms m hs
-> NS (ChosenMethodQuery p) ms
-> ConduitT Aeson.Value Void IO ()
-> IO ()
@ -369,17 +369,20 @@ instance ( RunMethod m p whole chn s ms hs
, ReflectRpcInfo p s ('Method mname args r) )
=> RunMethod m p whole chn s ('Method mname args r ': ms) (h ': hs) where
-- handle normal methods
runMethod f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery args ret))
= ((realName ,) <$>) <$> runHandler f whole (path ++ [realName]) (h rpcInfo inh) args ret
runMethod f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret))
= ((realName ,) <$>)
<$> runHandler f whole (path ++ [realName]) (h rpcInfo inh) args ret
where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r))
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s)
(Proxy @('Method mname args r)) fld
runMethod f whole p path nm inh (_ :<||>: r) (S cont)
= runMethod f whole p path nm inh r cont
-- handle subscriptions
runMethodSubscription f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery args ret)) sink
runMethodSubscription f whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) sink
= runHandlerSubscription f whole (path ++ [realName]) (h rpcInfo inh) args ret sink
where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r))
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s)
(Proxy @('Method mname args r)) fld
runMethodSubscription f whole p path nm inh (_ :<||>: r) (S cont) sink
= runMethodSubscription f whole p path nm inh r cont sink
@ -387,7 +390,7 @@ class Handles chn args r m h
=> RunHandler m p whole chn args r h where
runHandler
:: (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> [T.Text]
-> h
-> NP (ArgumentValue p) args
@ -395,7 +398,7 @@ class Handles chn args r m h
-> WriterT [GraphQLError] IO (Maybe Aeson.Value)
runHandlerSubscription
:: (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> [T.Text]
-> h
-> NP (ArgumentValue p) args
@ -492,7 +495,7 @@ instance ArgumentConversion chn ref t
class ToRef chn r l => ResultConversion m p whole chn r l where
convertResult :: (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m whole
-> ServerT chn GQL.Field p m whole
-> [T.Text]
-> ReturnQuery' p r
-> l -> WriterT [GraphQLError] IO (Maybe Aeson.Value)

21
graphql/src/Mu/GraphQL/Server.hs
View File

@ -43,6 +43,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Lazy.Encoding as T
import Language.GraphQL.Draft.Parser (parseExecutableDoc)
import qualified Language.GraphQL.Draft.Syntax as GQL
import Mu.Adapter.Json ()
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.Method (StdMethod (..), parseMethod)
@ -71,7 +72,7 @@ instance A.FromJSON GraphQLInput where
-- queries, but also mutations or subscriptions.
graphQLApp ::
( GraphQLApp p qr mut sub ServerErrorIO chn hs )
=> ServerT chn p ServerErrorIO hs
=> ServerT chn GQL.Field p ServerErrorIO hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -83,7 +84,7 @@ graphQLApp = graphQLAppTrans id
graphQLAppQuery ::
forall qr p chn hs.
( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs )
=> ServerT chn p ServerErrorIO hs
=> ServerT chn GQL.Field p ServerErrorIO hs
-> Proxy qr
-> Application
graphQLAppQuery svr _
@ -96,7 +97,7 @@ graphQLAppTransQuery ::
forall qr m p chn hs.
( GraphQLApp p ('Just qr) 'Nothing 'Nothing m chn hs )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr
-> Application
graphQLAppTransQuery f svr _
@ -108,7 +109,7 @@ graphQLAppTransQuery f svr _
graphQLAppTrans ::
( GraphQLApp p qr mut sub m chn hs )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -121,7 +122,7 @@ graphQLAppTrans f server q m s
httpGraphQLAppTrans ::
( GraphQLApp p qr mut sub m chn hs )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -164,7 +165,7 @@ httpGraphQLAppTrans f server q m s req res =
wsGraphQLAppTrans
:: ( GraphQLApp p qr mut sub m chn hs )
=> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -179,7 +180,7 @@ wsGraphQLAppTrans f server q m s conn
runGraphQLAppSettings ::
( GraphQLApp p qr mut sub ServerErrorIO chn hs )
=> Settings
-> ServerT chn p ServerErrorIO hs
-> ServerT chn GQL.Field p ServerErrorIO hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -190,7 +191,7 @@ runGraphQLAppSettings st svr q m s = runSettings st (graphQLApp svr q m s)
runGraphQLApp ::
( GraphQLApp p qr mut sub ServerErrorIO chn hs )
=> Port
-> ServerT chn p ServerErrorIO hs
-> ServerT chn GQL.Field p ServerErrorIO hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -202,7 +203,7 @@ runGraphQLAppTrans ::
( GraphQLApp p qr mut sub m chn hs )
=> Port
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn p m hs
-> ServerT chn GQL.Field p m hs
-> Proxy qr
-> Proxy mut
-> Proxy sub
@ -213,7 +214,7 @@ runGraphQLAppTrans port f svr q m s = run port (graphQLAppTrans f svr q m s)
runGraphQLAppQuery ::
( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs )
=> Port
-> ServerT chn p ServerErrorIO hs
-> ServerT chn GQL.Field p ServerErrorIO hs
-> Proxy qr
-> IO ()
runGraphQLAppQuery port svr q = run port (graphQLAppQuery svr q)

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

@ -70,7 +70,7 @@ runGRpcApp
protocol ServerErrorIO chn services handlers )
=> Proxy protocol
-> Port
-> ServerT chn ('Package ('Just name) services) ServerErrorIO handlers
-> ServerT chn () ('Package ('Just name) services) ServerErrorIO handlers
-> IO ()
runGRpcApp protocol port = runGRpcAppTrans protocol port id
@ -82,7 +82,7 @@ runGRpcAppTrans
=> Proxy protocol
-> Port
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn ('Package ('Just name) services) m handlers
-> ServerT chn () ('Package ('Just name) services) m handlers
-> IO ()
runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
@ -96,7 +96,7 @@ runGRpcAppSettings
=> Proxy protocol
-> Settings
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn ('Package ('Just name) services) m handlers
-> ServerT chn () ('Package ('Just name) services) m handlers
-> IO ()
runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr)
@ -111,7 +111,7 @@ runGRpcAppTLS
=> Proxy protocol
-> TLSSettings -> Settings
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn ('Package ('Just name) services) m handlers
-> ServerT chn () ('Package ('Just name) services) m handlers
-> IO ()
runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr)
@ -125,7 +125,7 @@ gRpcApp
, GRpcServiceHandlers ('Package ('Just name) services)
protocol ServerErrorIO chn services handlers )
=> Proxy protocol
-> ServerT chn ('Package ('Just name) services) ServerErrorIO handlers
-> ServerT chn () ('Package ('Just name) services) ServerErrorIO handlers
-> Application
gRpcApp protocol = gRpcAppTrans protocol id
@ -140,7 +140,7 @@ gRpcAppTrans
protocol m chn services handlers )
=> Proxy protocol
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn ('Package ('Just name) services) m handlers
-> ServerT chn () ('Package ('Just name) services) m handlers
-> Application
gRpcAppTrans protocol f svr
= Wai.grpcApp [uncompressed, gzip]
@ -153,7 +153,7 @@ gRpcServerHandlers
protocol m chn services handlers )
=> Proxy protocol
-> (forall a. m a -> ServerErrorIO a)
-> ServerT chn ('Package ('Just name) services) m handlers
-> ServerT chn () ('Package ('Just name) services) m handlers
-> [ServiceHandler]
gRpcServerHandlers pr f (Services svr)
= gRpcServiceHandlers f (Proxy @('Package ('Just name) services)) pr packageName svr
@ -165,7 +165,7 @@ class GRpcServiceHandlers (fullP :: Package snm mnm anm (TypeRef snm))
(ss :: [Service snm mnm anm (TypeRef snm)]) (hs :: [[Type]]) where
gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a)
-> Proxy fullP -> Proxy p -> ByteString
-> ServicesT chn ss m hs -> [ServiceHandler]
-> ServicesT chn () ss m hs -> [ServiceHandler]
instance GRpcServiceHandlers fullP p m chn '[] '[] where
gRpcServiceHandlers _ _ _ _ S0 = []
@ -188,7 +188,7 @@ class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm))
(ms :: [Method snm mnm anm (TypeRef snm)]) (hs :: [Type]) where
gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a)
-> Proxy fullP -> Proxy fullS -> Proxy p -> ByteString -> ByteString
-> HandlersT chn inh ms m hs -> [ServiceHandler]
-> HandlersT chn () inh ms m hs -> [ServiceHandler]
instance GRpcMethodHandlers fullP fullS p m chn inh '[] '[] where
gRpcMethodHandlers _ _ _ _ _ _ H0 = []
@ -203,7 +203,7 @@ instance ( KnownName name, MkRPC p
(h reflectInfo ())
: gRpcMethodHandlers f pfullP pfullS pr p s rest
where methodName = BS.pack (nameVal (Proxy @name))
reflectInfo = reflectRpcInfo pfullP pfullS (Proxy @('Method name args r))
reflectInfo = reflectRpcInfo pfullP pfullS (Proxy @('Method name args r)) ()
class GRpcMethodHandler p m (args :: [Argument snm anm (TypeRef snm)]) r h where
gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a)

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

@ -41,15 +41,15 @@ initPrometheus prefix =
defaultBuckets)
prometheus :: (MonadBaseControl IO m, MonadMonitor m)
=> MuMetrics -> ServerT chn p m topHs -> ServerT chn p m topHs
=> MuMetrics -> ServerT chn info p m topHs -> ServerT chn info p m topHs
prometheus m = wrapServer (prometheusMetrics m)
prometheusMetrics :: forall m a. (MonadBaseControl IO m, MonadMonitor m)
=> MuMetrics -> RpcInfo -> m a -> m a
prometheusMetrics :: forall m a info. (MonadBaseControl IO m, MonadMonitor m)
=> MuMetrics -> RpcInfo info -> m a -> m a
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 (Service sname _) (Method mname _ _) _) run = do
incGauge (activeCalls metrics)
withLabel (messagesReceived metrics) (sname, mname) incCounter
( do -- We are forced to use a MVar because 'withLabel' only allows IO ()