mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Add parameter to RpcInfo (#205)
This commit is contained in:
parent
1d7a52a2a6
commit
bf00ed67d8
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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 ()
|
||||
|
Loading…
Reference in New Issue
Block a user