mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-08-16 18:00:33 +03:00
Annotations, information on RPC, and Prometheus (#198)
This commit is contained in:
Alejandro Serrano
GitHub
parent
c6b67332f2
commit
d6ade8e6ed
@ -1 +1,6 @@
|
||||
cradle: { stack: { component: "mu-avro:lib" } }
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "mu-avro:lib"
|
||||
- path: "./test"
|
||||
component: "mu-avro:exe:test-avro"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-avro
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: Avro serialization support for Mu microservices
|
||||
description:
|
||||
You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell
|
||||
@ -35,7 +35,7 @@ library
|
||||
, containers
|
||||
, deepseq
|
||||
, language-avro >=0.1.3.1
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
, sop-core
|
||||
, tagged
|
||||
|
||||
@ -195,7 +195,7 @@ avroMethodToType schemaName m
|
||||
= fail "only named types may be used as results"
|
||||
|
||||
typesToList :: [Type] -> Type
|
||||
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT
|
||||
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s = litT $ strTyLit $ T.unpack s
|
||||
|
||||
@ -1 +1,6 @@
|
||||
cradle: { stack: { component: "mu-protobuf:lib" } }
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "mu-protobuf:lib"
|
||||
- path: "./test"
|
||||
component: "mu-protobuf:exe:test-protobuf"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-protobuf
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis:
|
||||
Protocol Buffers serialization and gRPC schema import for Mu microservices
|
||||
|
||||
@ -37,7 +37,7 @@ library
|
||||
, http-client
|
||||
, http2-grpc-proto3-wire
|
||||
, language-protobuf
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
, proto3-wire
|
||||
, servant-client-core
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language KindSignatures #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-|
|
||||
@ -16,6 +17,7 @@ module Mu.Quasi.GRpc (
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import Language.Haskell.TH
|
||||
import Language.ProtocolBuffers.Parser
|
||||
import qualified Language.ProtocolBuffers.Types as P
|
||||
@ -70,7 +72,7 @@ pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
||||
pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
|
||||
pbServiceDeclToType pkg schema (P.Service nm _ methods)
|
||||
= [t| 'Package $(pkgType pkg)
|
||||
'[ 'Service $(textToStrLit nm) '[]
|
||||
'[ 'Service $(textToStrLit nm)
|
||||
$(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
|
||||
where
|
||||
pkgType Nothing = [t| 'Nothing |]
|
||||
@ -78,15 +80,15 @@ pbServiceDeclToType pkg schema (P.Service nm _ methods)
|
||||
|
||||
pbMethodToType :: Name -> P.Method -> Q Type
|
||||
pbMethodToType s (P.Method nm vr v rr r _)
|
||||
= [t| 'Method $(textToStrLit nm) '[]
|
||||
= [t| 'Method $(textToStrLit nm)
|
||||
$(argToType vr v) $(retToType rr r) |]
|
||||
where
|
||||
argToType P.Single (P.TOther ["google","protobuf","Empty"])
|
||||
= [t| '[ ] |]
|
||||
argToType P.Single (P.TOther a)
|
||||
= [t| '[ 'ArgSingle 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
= [t| '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
argToType P.Stream (P.TOther a)
|
||||
= [t| '[ 'ArgStream 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
= [t| '[ 'ArgStream ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||
argToType _ _
|
||||
= fail "only message types may be used as arguments"
|
||||
|
||||
@ -104,7 +106,7 @@ schemaTy schema = pure $ ConT schema
|
||||
|
||||
typesToList :: [Type] -> Type
|
||||
typesToList
|
||||
= foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
= foldr (AppT . AppT PromotedConsT) PromotedNilT
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s
|
||||
= pure $ LitT $ StrTyLit $ T.unpack s
|
||||
|
||||
@ -17,8 +17,9 @@ packages: compendium-client/
|
||||
grpc/client/
|
||||
grpc/server/
|
||||
graphql/
|
||||
instrumentation/prometheus
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/hasura/graphql-parser-hs.git
|
||||
tag: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
tag: ba2379640248ce67cdfe700cbb79acd91c644bdb
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-rpc
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: Protocol-independent declaration of services and servers.
|
||||
description:
|
||||
Protocol-independent declaration of services and servers for mu-haskell.
|
||||
@ -23,6 +23,7 @@ source-repository head
|
||||
library
|
||||
exposed-modules:
|
||||
Mu.Rpc
|
||||
Mu.Rpc.Annotations
|
||||
Mu.Rpc.Examples
|
||||
Mu.Server
|
||||
|
||||
|
||||
@ -1,8 +1,13 @@
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language ExistentialQuantification #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
@ -16,46 +21,46 @@ and protocol.
|
||||
module Mu.Rpc (
|
||||
Package', Package(..)
|
||||
, Service', Service(..), Object
|
||||
, ServiceAnnotation, Method', Method(..), ObjectField
|
||||
, Method', Method(..), ObjectField
|
||||
, LookupService, LookupMethod
|
||||
, TypeRef(..), Argument', Argument(..), Return(..)
|
||||
, TyInfo(..), RpcInfo(..), ReflectRpcInfo(..)
|
||||
) where
|
||||
|
||||
import Data.Kind
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import Type.Reflection
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Registry
|
||||
|
||||
-- | Packages whose names are given by type-level strings.
|
||||
type Package' = Package Symbol Symbol Symbol
|
||||
type Package' = Package Symbol Symbol Symbol (TypeRef Symbol)
|
||||
-- | Services whose names are given by type-level strings.
|
||||
type Service' = Service Symbol Symbol Symbol
|
||||
type Service' = Service Symbol Symbol Symbol (TypeRef Symbol)
|
||||
-- | Methods whose names are given by type-level strings.
|
||||
type Method' = Method Symbol Symbol Symbol
|
||||
type Method' = Method Symbol Symbol Symbol (TypeRef Symbol)
|
||||
-- | Arguments whose names are given by type-level strings.
|
||||
type Argument' = Argument Symbol Symbol
|
||||
-- | Annotations for services. At this moment, such
|
||||
-- annotations can be of any type.
|
||||
type ServiceAnnotation = Type
|
||||
type Argument' = Argument Symbol Symbol (TypeRef Symbol)
|
||||
|
||||
-- | A package is a set of services.
|
||||
data Package serviceName methodName argName
|
||||
data Package serviceName methodName argName tyRef
|
||||
= Package (Maybe serviceName)
|
||||
[Service serviceName methodName argName]
|
||||
[Service serviceName methodName argName tyRef]
|
||||
|
||||
-- | A service is a set of methods.
|
||||
data Service serviceName methodName argName
|
||||
data Service serviceName methodName argName tyRef
|
||||
= Service serviceName
|
||||
[ServiceAnnotation]
|
||||
[Method serviceName methodName argName]
|
||||
[Method serviceName methodName argName tyRef]
|
||||
|
||||
-- | A method is defined by its name, arguments, and return type.
|
||||
data Method serviceName methodName argName
|
||||
= Method methodName [ServiceAnnotation]
|
||||
[Argument serviceName argName]
|
||||
(Return serviceName)
|
||||
data Method serviceName methodName argName tyRef
|
||||
= Method methodName
|
||||
[Argument serviceName argName tyRef]
|
||||
(Return serviceName tyRef)
|
||||
|
||||
-- Synonyms for GraphQL
|
||||
-- | An object is a set of fields, in GraphQL lingo.
|
||||
@ -66,16 +71,18 @@ type Object = 'Service
|
||||
type ObjectField = 'Method
|
||||
|
||||
-- | Look up a service in a package definition using its name.
|
||||
type family LookupService (ss :: [Service snm mnm anm]) (s :: snm) :: Service snm mnm anm where
|
||||
type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm)
|
||||
:: Service snm mnm anm tr where
|
||||
LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)
|
||||
LookupService ('Service s anns ms ': ss) s = 'Service s anns ms
|
||||
LookupService (other ': ss) s = LookupService ss s
|
||||
LookupService ('Service s ms ': ss) s = 'Service s ms
|
||||
LookupService (other ': ss) s = LookupService ss s
|
||||
|
||||
-- | Look up a method in a service definition using its name.
|
||||
type family LookupMethod (s :: [Method snm mnm anm]) (m :: mnm) :: Method snm mnm anm where
|
||||
type family LookupMethod (s :: [Method snm mnm anm tr]) (m :: mnm)
|
||||
:: Method snm mnm anm tr where
|
||||
LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)
|
||||
LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r
|
||||
LookupMethod (other ': ms) m = LookupMethod ms m
|
||||
LookupMethod ('Method m args r ': ms) m = 'Method m args r
|
||||
LookupMethod (other ': ms) m = LookupMethod ms m
|
||||
|
||||
-- | Defines a reference to a type, either primitive or coming from the schema.
|
||||
-- 'TypeRef's are used to define arguments and result types.
|
||||
@ -96,23 +103,149 @@ data TypeRef serviceName where
|
||||
-- | Represents a possibly-missing value.
|
||||
OptionalRef :: TypeRef serviceName -> TypeRef serviceName
|
||||
|
||||
instance Show (TypeRef s) where
|
||||
show _ = "ty"
|
||||
|
||||
-- | Defines the way in which arguments are handled.
|
||||
data Argument serviceName argName where
|
||||
data Argument serviceName argName tyRef where
|
||||
-- | Use a single value.
|
||||
ArgSingle :: Maybe argName -> [ServiceAnnotation]
|
||||
-> TypeRef serviceName -> Argument serviceName argName
|
||||
ArgSingle :: Maybe argName
|
||||
-> tyRef
|
||||
-> Argument serviceName argName tyRef
|
||||
-- | Consume a stream of values.
|
||||
ArgStream :: Maybe argName -> [ServiceAnnotation]
|
||||
-> TypeRef serviceName -> Argument serviceName argName
|
||||
ArgStream :: Maybe argName
|
||||
-> tyRef
|
||||
-> Argument serviceName argName tyRef
|
||||
|
||||
-- | Defines the different possibilities for returning
|
||||
-- information from a method.
|
||||
data Return serviceName where
|
||||
data Return serviceName tyRef where
|
||||
-- | Fire and forget.
|
||||
RetNothing :: Return serviceName
|
||||
RetNothing :: Return serviceName tyRef
|
||||
-- | Return a single value.
|
||||
RetSingle :: TypeRef serviceName -> Return serviceName
|
||||
RetSingle :: tyRef -> Return serviceName tyRef
|
||||
-- | Return a stream of values.
|
||||
RetStream :: TypeRef serviceName -> Return serviceName
|
||||
RetStream :: tyRef -> Return serviceName tyRef
|
||||
-- | Return a value or an error.
|
||||
RetThrows :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName
|
||||
RetThrows :: tyRef -> tyRef -> Return serviceName tyRef
|
||||
|
||||
-- | Reflection
|
||||
|
||||
data RpcInfo
|
||||
= NoRpcInfo
|
||||
| RpcInfo { packageInfo :: Package Text Text Text TyInfo
|
||||
, serviceInfo :: Service Text Text Text TyInfo
|
||||
, methodInfo :: Method Text Text Text TyInfo
|
||||
}
|
||||
|
||||
data TyInfo
|
||||
= TyList TyInfo
|
||||
| TyOption TyInfo
|
||||
| TyTy Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Show RpcInfo where
|
||||
show NoRpcInfo
|
||||
= "<no info>"
|
||||
show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _))
|
||||
= T.unpack (s <> ":" <> m)
|
||||
show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _))
|
||||
= T.unpack (p <> ":" <> s <> ":" <> m)
|
||||
|
||||
class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
|
||||
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RpcInfo
|
||||
class ReflectService (s :: Service') where
|
||||
reflectService :: Proxy s -> Service Text Text Text TyInfo
|
||||
class ReflectMethod (m :: Method') where
|
||||
reflectMethod :: Proxy m -> Method Text Text Text TyInfo
|
||||
class ReflectArg (arg :: Argument') where
|
||||
reflectArg :: Proxy arg -> Argument Text Text TyInfo
|
||||
class ReflectReturn (r :: Return Symbol (TypeRef Symbol)) where
|
||||
reflectReturn :: Proxy r -> Return Text TyInfo
|
||||
class ReflectTyRef (r :: TypeRef Symbol) where
|
||||
reflectTyRef :: Proxy r -> TyInfo
|
||||
|
||||
class KnownMaySymbol (m :: Maybe Symbol) where
|
||||
maySymbolVal :: Proxy m -> Maybe Text
|
||||
instance KnownMaySymbol 'Nothing where
|
||||
maySymbolVal _ = Nothing
|
||||
instance (KnownSymbol s) => KnownMaySymbol ('Just s) where
|
||||
maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
|
||||
|
||||
class ReflectServices (ss :: [Service']) where
|
||||
reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]
|
||||
instance ReflectServices '[] where
|
||||
reflectServices _ = []
|
||||
instance (ReflectService s, ReflectServices ss)
|
||||
=> ReflectServices (s ': ss) where
|
||||
reflectServices _ = reflectService (Proxy @s) : reflectServices (Proxy @ss)
|
||||
|
||||
class ReflectMethods (ms :: [Method']) where
|
||||
reflectMethods :: Proxy ms -> [Method Text Text Text TyInfo]
|
||||
instance ReflectMethods '[] where
|
||||
reflectMethods _ = []
|
||||
instance (ReflectMethod m, ReflectMethods ms)
|
||||
=> ReflectMethods (m ': ms) where
|
||||
reflectMethods _ = reflectMethod (Proxy @m) : reflectMethods (Proxy @ms)
|
||||
|
||||
class ReflectArgs (ms :: [Argument']) where
|
||||
reflectArgs :: Proxy ms -> [Argument Text Text TyInfo]
|
||||
instance ReflectArgs '[] where
|
||||
reflectArgs _ = []
|
||||
instance (ReflectArg m, ReflectArgs ms)
|
||||
=> ReflectArgs (m ': ms) where
|
||||
reflectArgs _ = reflectArg (Proxy @m) : reflectArgs (Proxy @ms)
|
||||
|
||||
instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMethod m)
|
||||
=> ReflectRpcInfo ('Package pname ss) s m where
|
||||
reflectRpcInfo _ ps pm
|
||||
= RpcInfo (Package (maySymbolVal (Proxy @pname))
|
||||
(reflectServices (Proxy @ss)))
|
||||
(reflectService ps) (reflectMethod pm)
|
||||
|
||||
instance (KnownSymbol sname, ReflectMethods ms)
|
||||
=> ReflectService ('Service sname ms) where
|
||||
reflectService _
|
||||
= Service (T.pack $ symbolVal (Proxy @sname))
|
||||
(reflectMethods (Proxy @ms))
|
||||
|
||||
instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)
|
||||
=> ReflectMethod ('Method mname args r) where
|
||||
reflectMethod _
|
||||
= Method (T.pack $ symbolVal (Proxy @mname))
|
||||
(reflectArgs (Proxy @args)) (reflectReturn (Proxy @r))
|
||||
|
||||
instance (KnownMaySymbol aname, ReflectTyRef t)
|
||||
=> ReflectArg ('ArgSingle aname t) where
|
||||
reflectArg _
|
||||
= ArgSingle (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t))
|
||||
instance (KnownMaySymbol aname, ReflectTyRef t)
|
||||
=> ReflectArg ('ArgStream aname t) where
|
||||
reflectArg _
|
||||
= ArgStream (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t))
|
||||
|
||||
instance ReflectReturn 'RetNothing where
|
||||
reflectReturn _ = RetNothing
|
||||
instance (ReflectTyRef t)
|
||||
=> ReflectReturn ('RetSingle t) where
|
||||
reflectReturn _ = RetSingle (reflectTyRef (Proxy @t))
|
||||
instance (ReflectTyRef t)
|
||||
=> ReflectReturn ('RetStream t) where
|
||||
reflectReturn _ = RetStream (reflectTyRef (Proxy @t))
|
||||
instance (ReflectTyRef e, ReflectTyRef t)
|
||||
=> ReflectReturn ('RetThrows e t) where
|
||||
reflectReturn _ = RetThrows (reflectTyRef (Proxy @e))
|
||||
(reflectTyRef (Proxy @t))
|
||||
|
||||
instance ReflectTyRef t => ReflectTyRef ('ListRef t) where
|
||||
reflectTyRef _ = TyList (reflectTyRef (Proxy @t))
|
||||
instance ReflectTyRef t => ReflectTyRef ('OptionalRef t) where
|
||||
reflectTyRef _ = TyOption (reflectTyRef (Proxy @t))
|
||||
instance Typeable t => ReflectTyRef ('PrimitiveRef t) where
|
||||
reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t)
|
||||
instance KnownSymbol s => ReflectTyRef ('ObjectRef s) where
|
||||
reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s)
|
||||
instance KnownSymbol s => ReflectTyRef ('SchemaRef sch s) where
|
||||
reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s)
|
||||
instance Typeable t => ReflectTyRef ('RegistryRef r t n) where
|
||||
reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t)
|
||||
|
||||
86
core/rpc/src/Mu/Rpc/Annotations.hs
Normal file
86
core/rpc/src/Mu/Rpc/Annotations.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-|
|
||||
Description : Protocol-defined annotations.
|
||||
|
||||
Libraries can define custom annotations to
|
||||
indicate additional information not found
|
||||
in the 'Package' itself. For example, GraphQL
|
||||
has optional default values for arguments.
|
||||
-}
|
||||
module Mu.Rpc.Annotations (
|
||||
RpcAnnotation(..)
|
||||
, AnnotatedPackage
|
||||
, GetPackageAnnotation
|
||||
, GetServiceAnnotation
|
||||
, GetMethodAnnotation
|
||||
, GetArgAnnotation
|
||||
, GetArgAnnotationMay
|
||||
) where
|
||||
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Rpc
|
||||
|
||||
-- | Annotations proper.
|
||||
data RpcAnnotation domain serviceName methodName argName where
|
||||
-- | Annotation over the whole package.
|
||||
AnnPackage :: domain
|
||||
-> RpcAnnotation domain serviceName methodName argName
|
||||
-- | Annotation over a service.
|
||||
AnnService :: serviceName -> domain
|
||||
-> RpcAnnotation domain serviceName methodName argName
|
||||
-- | Annotation over a method.
|
||||
AnnMethod :: serviceName -> methodName -> domain
|
||||
-> RpcAnnotation domain serviceName methodName argName
|
||||
-- | Annotation over an argument.
|
||||
AnnArg :: serviceName -> methodName -> argName -> domain
|
||||
-> RpcAnnotation domain serviceName methodName argName
|
||||
|
||||
-- | This type family links each schema to
|
||||
-- its corresponding annotations from one domain.
|
||||
type family AnnotatedPackage domain (sch :: Package serviceName methodName argName tyRef)
|
||||
:: [RpcAnnotation domain serviceName methodName argName]
|
||||
|
||||
-- | Find the annotation over the package in the given set.
|
||||
-- If the annotation cannot be found, raise a 'TypeError'.
|
||||
type family GetPackageAnnotation (anns :: [RpcAnnotation domain s m a]) :: domain where
|
||||
GetPackageAnnotation '[]
|
||||
= TypeError ('Text "cannot find schema annotation")
|
||||
GetPackageAnnotation ('AnnPackage d ': rs) = d
|
||||
GetPackageAnnotation (r ': rs) = GetPackageAnnotation rs
|
||||
|
||||
-- | Find the annotation over the given service in the given set.
|
||||
-- If the annotation cannot be found, raise a 'TypeError'.
|
||||
type family GetServiceAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) :: domain where
|
||||
GetServiceAnnotation '[] snm
|
||||
= TypeError ('Text "cannot find annotation for " ':<>: 'ShowType snm)
|
||||
GetServiceAnnotation ('AnnService snm d ': rs) snm = d
|
||||
GetServiceAnnotation (r ': rs) snm = GetServiceAnnotation rs snm
|
||||
|
||||
-- | Find the annotation over the given method in the given service.
|
||||
-- If the annotation cannot be found, raise a 'TypeError'.
|
||||
type family GetMethodAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) :: domain where
|
||||
GetMethodAnnotation '[] snm mnm
|
||||
= TypeError ('Text "cannot find annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm)
|
||||
GetMethodAnnotation ('AnnMethod snm mnm d ': rs) snm mnm = d
|
||||
GetMethodAnnotation (r ': rs) snm mnm = GetMethodAnnotation rs snm mnm
|
||||
|
||||
-- | Find the annotation over the given argument in te given method in the given service.
|
||||
-- If the annotation cannot be found, raise a 'TypeError'.
|
||||
type family GetArgAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: domain where
|
||||
GetArgAnnotation '[] snm mnm anm
|
||||
= TypeError ('Text "cannot find annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm ':<>: 'Text "/" ':<>: 'ShowType anm)
|
||||
GetArgAnnotation ('AnnArg snm mnm anm d ': rs) snm mnm anm = d
|
||||
GetArgAnnotation (r ': rs) snm mnm anm = GetArgAnnotation rs snm mnm anm
|
||||
|
||||
-- | Find the annotation over the given argument in te given method in the given service.
|
||||
-- If the annotation cannot be found, raise a 'TypeError'.
|
||||
type family GetArgAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: Maybe domain where
|
||||
GetArgAnnotationMay '[] snm mnm anm = 'Nothing
|
||||
GetArgAnnotationMay ('AnnArg snm mnm anm d ': rs) snm mnm anm = 'Just d
|
||||
GetArgAnnotationMay (r ': rs) snm mnm anm = GetArgAnnotationMay rs snm mnm anm
|
||||
@ -24,6 +24,7 @@ import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
@ -43,15 +44,15 @@ type QuickstartSchema
|
||||
|
||||
type QuickStartService
|
||||
= 'Package ('Just "helloworld")
|
||||
'[ 'Service "Greeter" '[]
|
||||
'[ 'Method "SayHello" '[]
|
||||
'[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ]
|
||||
'[ 'Service "Greeter"
|
||||
'[ 'Method "SayHello"
|
||||
'[ 'ArgSingle ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HelloRequest") ]
|
||||
('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayHi" '[]
|
||||
'[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")]
|
||||
, 'Method "SayHi"
|
||||
'[ 'ArgSingle ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HiRequest")]
|
||||
('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||
, 'Method "SayManyHellos" '[]
|
||||
'[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")]
|
||||
, 'Method "SayManyHellos"
|
||||
'[ 'ArgStream ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HelloRequest")]
|
||||
('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]
|
||||
|
||||
newtype HelloRequest = HelloRequest { name :: T.Text }
|
||||
@ -94,13 +95,13 @@ quickstartServer
|
||||
-- From https://www.apollographql.com/docs/apollo-server/schema/schema/
|
||||
type ApolloService
|
||||
= 'Package ('Just "apollo")
|
||||
'[ Object "Book" '[]
|
||||
'[ ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))
|
||||
'[ Object "Book"
|
||||
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
|
||||
]
|
||||
, Object "Author" '[]
|
||||
'[ ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
|
||||
, Object "Author"
|
||||
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
@ -49,11 +49,16 @@ We recommend you to catch exceptions and return custom
|
||||
module Mu.Server (
|
||||
-- * Servers and handlers
|
||||
MonadServer, ServiceChain, noContext
|
||||
, wrapServer
|
||||
-- ** Definitions by name
|
||||
, singleService, method, resolver, object, field, NamedList(..)
|
||||
, singleService
|
||||
, method, methodWithInfo
|
||||
, resolver, object
|
||||
, field, fieldWithInfo
|
||||
, NamedList(..)
|
||||
-- ** Definitions by position
|
||||
, SingleServerT, pattern Server
|
||||
, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:))
|
||||
, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))
|
||||
-- ** Simple servers using only IO
|
||||
, ServerErrorIO, ServerIO
|
||||
-- * Errors which might be raised
|
||||
@ -96,8 +101,8 @@ alwaysOk = liftIO
|
||||
|
||||
-- | To declare that the function doesn't use
|
||||
-- its context.
|
||||
noContext :: b -> a -> b
|
||||
noContext = const
|
||||
noContext :: b -> a1 -> a2 -> b
|
||||
noContext x _ _ = x
|
||||
|
||||
-- | Errors raised in a handler.
|
||||
data ServerError
|
||||
@ -128,26 +133,25 @@ 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)
|
||||
data ServerT (chn :: ServiceChain snm) (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
|
||||
|
||||
pattern Server :: (MappingRight chn sname ~ ())
|
||||
=> HandlersT chn () methods m hs
|
||||
-> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]
|
||||
-> ServerT chn ('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])
|
||||
data ServicesT (chn :: ServiceChain snm) (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 anns methods ': rest) m (hs ': hss)
|
||||
-> ServicesT chn ('Service sname methods ': rest) m (hs ': hss)
|
||||
|
||||
infixr 4 :<||>:
|
||||
-- | 'HandlersT' is a sequence of handlers.
|
||||
-- Note that the handlers for your service
|
||||
-- must appear __in the same order__ as they
|
||||
@ -168,24 +172,35 @@ infixr 4 :<||>:
|
||||
-- of type @Conduit t Void m ()@. This stream should
|
||||
-- be connected to a source to get the elements.
|
||||
data HandlersT (chn :: ServiceChain snm)
|
||||
(inh :: *) (methods :: [Method snm mnm anm])
|
||||
(inh :: *) (methods :: [Method snm mnm anm (TypeRef snm)])
|
||||
(m :: Type -> Type) (hs :: [Type]) where
|
||||
H0 :: HandlersT chn inh '[] m '[]
|
||||
(:<||>:) :: Handles chn args ret m h
|
||||
=> (inh -> h) -> HandlersT chn inh ms m hs
|
||||
-> HandlersT chn inh ('Method name anns args ret ': ms) m (h ': hs)
|
||||
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)
|
||||
|
||||
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)
|
||||
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 anns args ret ': ms) m (h ': hs)
|
||||
pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where
|
||||
-> HandlersT chn () ('Method name args ret ': ms) m (h ': hs)
|
||||
pattern x :<|>: xs <- (($ ()) . ($ NoRpcInfo) -> x) :<||>: xs where
|
||||
x :<|>: xs = noContext x :<||>: xs
|
||||
|
||||
-- | Defines a relation for handling.
|
||||
class Handles (chn :: ServiceChain snm)
|
||||
(args :: [Argument snm anm]) (ret :: Return snm)
|
||||
(m :: Type -> Type) (h :: Type)
|
||||
(args :: [Argument snm anm (TypeRef snm)])
|
||||
(ret :: Return snm (TypeRef snm))
|
||||
(m :: Type -> Type) (h :: Type) where
|
||||
wrapHandler :: Proxy '(chn, m) -> Proxy args -> Proxy ret
|
||||
-> (forall a. m a -> m a) -> h -> h
|
||||
-- | Defines whether a given type @t@
|
||||
-- can be turned into the 'TypeRef' @ref@.
|
||||
class ToRef (chn :: ServiceChain snm)
|
||||
@ -211,21 +226,30 @@ instance (FromRef chn ref t, [t] ~ s) => FromRef chn ('ListRef ref) s
|
||||
instance (FromRef chn ref t, Maybe t ~ s) => FromRef chn ('OptionalRef ref) s
|
||||
|
||||
-- Arguments
|
||||
instance (FromRef chn ref t, Handles chn args ret m h,
|
||||
handler ~ (t -> h))
|
||||
=> Handles chn ('ArgSingle aname anns ref ': args) ret m handler
|
||||
instance forall chn ref args ret m handler h t aname.
|
||||
( FromRef chn ref t, Handles chn args ret m h
|
||||
, handler ~ (t -> h) )
|
||||
=> Handles chn ('ArgSingle aname ref ': args) ret m handler where
|
||||
wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h
|
||||
instance (MonadError ServerError m, FromRef chn ref t, Handles chn args ret m h,
|
||||
handler ~ (ConduitT () t m () -> h))
|
||||
=> Handles chn ('ArgStream aname anns ref ': args) ret m handler
|
||||
=> Handles chn ('ArgStream aname ref ': args) ret m handler where
|
||||
wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h
|
||||
-- Result with exception
|
||||
instance (MonadError ServerError m, handler ~ m ())
|
||||
=> Handles chn '[] 'RetNothing m handler
|
||||
instance (MonadError ServerError m, ToRef chn eref e, ToRef chn vref v, handler ~ m (Either e v))
|
||||
=> Handles chn '[] ('RetThrows eref vref) m handler
|
||||
=> Handles chn '[] 'RetNothing m handler where
|
||||
wrapHandler _ _ _ f h = f h
|
||||
instance ( MonadError ServerError m, ToRef chn eref e, ToRef chn vref v
|
||||
, handler ~ m (Either e v) )
|
||||
=> Handles chn '[] ('RetThrows eref vref) m handler where
|
||||
wrapHandler _ _ _ f h = f h
|
||||
instance (MonadError ServerError m, ToRef chn ref v, handler ~ m v)
|
||||
=> Handles chn '[] ('RetSingle ref) m handler
|
||||
instance (MonadError ServerError m, ToRef chn ref v, handler ~ (ConduitT v Void m () -> m ()))
|
||||
=> Handles chn '[] ('RetStream ref) m handler
|
||||
=> Handles chn '[] ('RetSingle ref) m handler where
|
||||
wrapHandler _ _ _ f h = f h
|
||||
instance ( MonadError ServerError m, ToRef chn ref v
|
||||
, handler ~ (ConduitT v Void m () -> m ()) )
|
||||
=> Handles chn '[] ('RetStream ref) m handler where
|
||||
wrapHandler _ _ _ f h = f . h
|
||||
|
||||
-- SIMPLER WAY TO DECLARE SERVICES
|
||||
|
||||
@ -233,15 +257,31 @@ instance (MonadError ServerError m, ToRef chn ref v, handler ~ (ConduitT v Void
|
||||
-- Intended to be used with @TypeApplications@:
|
||||
--
|
||||
-- > method @"myMethod" myHandler
|
||||
method :: forall n p. p -> Named n (() -> p)
|
||||
method f = Named (\() -> f)
|
||||
method :: forall n a p. p -> Named n (a -> () -> p)
|
||||
method f = Named (\_ _ -> f)
|
||||
|
||||
-- | Declares the handler for a method in the service,
|
||||
-- which is passed additional information about the call.
|
||||
-- Intended to be used with @TypeApplications@:
|
||||
--
|
||||
-- > methodWithInfo @"myMethod" myHandler
|
||||
methodWithInfo :: forall n p. (RpcInfo -> p) -> Named n (RpcInfo -> () -> 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 h
|
||||
field = Named
|
||||
field :: forall n h. h -> Named n (RpcInfo -> h)
|
||||
field f = Named (const f)
|
||||
|
||||
-- | Declares the handler for a field in an object,
|
||||
-- which is passed additional information about the call.
|
||||
-- Intended to be used with @TypeApplications@:
|
||||
--
|
||||
-- > fieldWithInfo @"myField" myHandler
|
||||
fieldWithInfo :: forall n h. (RpcInfo -> h) -> Named n (RpcInfo -> h)
|
||||
fieldWithInfo = Named
|
||||
|
||||
-- | Defines a server for a package with a single service.
|
||||
-- Intended to be used with a tuple of 'method's:
|
||||
@ -249,7 +289,7 @@ field = 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 sanns methods ]) m '[hs]
|
||||
=> p -> ServerT chn ('Package pname '[ 'Service sname methods ]) m '[hs]
|
||||
singleService nl = Server $ toHandlers $ toNamedList nl
|
||||
|
||||
-- | Defines the implementation of a single GraphQL object,
|
||||
@ -331,16 +371,16 @@ class ToHandlers chn inh ms m hs nl | chn inh ms m nl -> hs where
|
||||
instance ToHandlers chn 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 anns args ret ': ms) m (h ': hs) nl where
|
||||
=> ToHandlers chn 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 -> inh -> h
|
||||
findHandler :: Proxy name -> NamedList nl -> RpcInfo -> inh -> h
|
||||
instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))
|
||||
=> FindHandler name inh h '[] where
|
||||
findHandler = error "this should never be called"
|
||||
instance {-# OVERLAPS #-} (inh ~ inh', h ~ h')
|
||||
=> FindHandler name inh h ( '(name, inh' -> h') ': rest ) where
|
||||
instance {-# OVERLAPS #-} (RpcInfo ~ rpc', inh ~ inh', h ~ h')
|
||||
=> FindHandler name 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
|
||||
@ -354,7 +394,7 @@ instance ToServices chn '[] 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 anns methods ': ss) m (h ': hs) nl where
|
||||
=> ToServices chn ('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
|
||||
@ -368,3 +408,26 @@ instance {-# OVERLAPS #-} (h ~ h')
|
||||
instance {-# OVERLAPPABLE #-} FindService name h rest
|
||||
=> FindService name h (thing ': rest) where
|
||||
findService p (_ :|: rest) = findService p 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
|
||||
wrapServer f (Services ss) = Services (wrapServices ss)
|
||||
where
|
||||
wrapServices :: forall ss hs.
|
||||
ServicesT chn ss m hs -> ServicesT chn 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
|
||||
wrapHandlers H0 = H0
|
||||
wrapHandlers (Hmore pargs pret h rest)
|
||||
= Hmore pargs pret
|
||||
(\rpc inh -> wrapHandler (Proxy @'(chn, m)) pargs pret (f rpc) (h rpc inh))
|
||||
(wrapHandlers rest)
|
||||
|
||||
@ -27,6 +27,7 @@ executable health-server
|
||||
, deferred-folds
|
||||
, mu-graphql
|
||||
, mu-grpc-server >=0.3.0
|
||||
, mu-prometheus
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-schema >=0.3.0
|
||||
@ -35,6 +36,7 @@ executable health-server
|
||||
, stm-containers
|
||||
, text
|
||||
, wai
|
||||
, warp
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -8,17 +8,20 @@ module Main where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
import DeferredFolds.UnfoldlM
|
||||
import qualified StmContainers.Map as M
|
||||
import Network.Wai.Handler.Warp
|
||||
import qualified StmContainers.Map as M
|
||||
|
||||
import Mu.GraphQL.Server
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Instrumentation.Prometheus
|
||||
import Mu.Server
|
||||
|
||||
import Definition
|
||||
@ -27,12 +30,14 @@ main :: IO ()
|
||||
main = do
|
||||
m <- M.newIO
|
||||
upd <- newTBMChanIO 100
|
||||
met <- initPrometheus "health"
|
||||
putStrLn "running health check application"
|
||||
let s = server m upd
|
||||
let s = prometheus met (server m upd)
|
||||
runConcurrently $ (\_ _ _ -> ())
|
||||
<$> Concurrently (runGRpcApp msgProtoBuf 50051 s)
|
||||
<*> Concurrently (runGRpcApp msgAvro 50052 s)
|
||||
<*> Concurrently (runGraphQLAppQuery 50053 s (Proxy @"HealthCheckServiceFS2"))
|
||||
<$> Concurrently (runner 50051 (gRpcApp msgProtoBuf s))
|
||||
<*> Concurrently (runner 50052 (gRpcApp msgAvro s))
|
||||
<*> Concurrently (runner 50053 (graphQLAppQuery s (Proxy @"HealthCheckServiceFS2")))
|
||||
where runner p app = run p (prometheusWai ["metrics"] app)
|
||||
|
||||
-- Server implementation
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/health-check-unary/src/main/scala/higherkindness/mu/rpc/healthcheck/unary/handler/HealthServiceImpl.scala
|
||||
@ -42,7 +47,8 @@ type StatusUpdates = TBMChan HealthStatusMsg
|
||||
|
||||
server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _
|
||||
server m upd
|
||||
= singleService ( method @"setStatus" $ setStatus_ m upd
|
||||
= wrapServer (\info h -> liftIO (print info) >> h) $
|
||||
singleService ( method @"setStatus" $ setStatus_ m upd
|
||||
, method @"check" $ checkH_ m
|
||||
, method @"clearStatus" $ clearStatus_ m
|
||||
, method @"checkAll" $ checkAll_ m
|
||||
|
||||
@ -8,6 +8,7 @@
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TupleSections #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
|
||||
|
||||
|
||||
@ -1 +0,0 @@
|
||||
cradle: { stack: { component: "mu-graphql:exe:library-graphql" } }
|
||||
6
graphql/hie.yaml
Normal file
6
graphql/hie.yaml
Normal file
@ -0,0 +1,6 @@
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "mu-graphql:lib"
|
||||
- path: "./exe"
|
||||
component: "mu-graphql:exe:library-graphql"
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-graphql
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: GraphQL support for Mu
|
||||
description: GraphQL servers and clients for Mu-Haskell
|
||||
cabal-version: >=1.10
|
||||
@ -40,8 +40,8 @@ library
|
||||
, http-types
|
||||
, list-t
|
||||
, mtl
|
||||
, mu-rpc
|
||||
, mu-schema
|
||||
, mu-rpc >=0.4
|
||||
, mu-schema >=0.3
|
||||
, parsers
|
||||
, scientific
|
||||
, sop-core
|
||||
|
||||
@ -17,9 +17,10 @@ to provide this additional information.
|
||||
-}
|
||||
module Mu.GraphQL.Annotations (
|
||||
ValueConst(..)
|
||||
, DefaultValue
|
||||
, DefaultValue(..)
|
||||
, ReflectValueConst(..)
|
||||
, fromGQLValueConst
|
||||
, module Mu.Rpc.Annotations
|
||||
) where
|
||||
|
||||
import Control.Applicative (Alternative (..))
|
||||
@ -29,9 +30,12 @@ import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||
|
||||
import Mu.Rpc.Annotations
|
||||
|
||||
-- | Specifies the default value of an argument.
|
||||
-- To be used as an annotation.
|
||||
data DefaultValue (v :: ValueConst Nat Symbol)
|
||||
newtype DefaultValue
|
||||
= DefaultValue (ValueConst Nat Symbol)
|
||||
|
||||
-- | Type-level GraphQL constant values.
|
||||
-- Due to limitations in type-level literal values
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TupleSections #-}
|
||||
{-# language ViewPatterns #-}
|
||||
{-|
|
||||
Description : Quasi-quoters for GraphQL schemas
|
||||
@ -17,6 +18,7 @@ import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (catMaybes)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
import Data.UUID (UUID)
|
||||
@ -50,8 +52,8 @@ type SchemaMap = HM.HashMap T.Text GQL.OperationType
|
||||
|
||||
data Result =
|
||||
GQLScalar
|
||||
| GQLSchema Type
|
||||
| GQLService Type
|
||||
| GQLSchema Type
|
||||
| GQLService Type [(T.Text, (T.Text, (T.Text, Type)))]
|
||||
|
||||
data GQLType =
|
||||
Enum
|
||||
@ -72,12 +74,18 @@ classify :: [GQL.TypeDefinition] -> TypeMap
|
||||
classify = HM.fromList . (typeToKeyValue <$>)
|
||||
where
|
||||
typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType)
|
||||
typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ (coerce -> name) _)) = (name, Scalar)
|
||||
typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition _ (coerce -> name) _ _ _)) = (name, Object)
|
||||
typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition _ (coerce -> name) _ _)) = (name, Other)
|
||||
typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition _ (coerce -> name) _ _)) = (name, Other)
|
||||
typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition _ (coerce -> name) _ _)) = (name, Enum)
|
||||
typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition _ (coerce -> name) _ _)) = (name, InputObject)
|
||||
typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ name _))
|
||||
= (coerce name, Scalar)
|
||||
typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition _ name _ _ _))
|
||||
= (coerce name, Object)
|
||||
typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition _ name _ _))
|
||||
= (coerce name, Other)
|
||||
typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition _ name _ _))
|
||||
= (coerce name, Other)
|
||||
typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition _ name _ _))
|
||||
= (coerce name, Enum)
|
||||
typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition _ name _ _))
|
||||
= (coerce name, InputObject)
|
||||
|
||||
-- | Constructs the GraphQL tree splitting between Schemas and Services.
|
||||
graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec]
|
||||
@ -90,48 +98,69 @@ graphqlToDecls schemaName serviceName allTypes = do
|
||||
schMap = classifySchema schTypes
|
||||
rs <- traverse (typeToDec schemaName' typeMap schMap) types
|
||||
let schemaTypes = [x | GQLSchema x <- rs]
|
||||
serviceTypes = [x | GQLService x <- rs]
|
||||
serviceTypes = [x | GQLService x _ <- rs]
|
||||
defaultDefs = concat [d | GQLService _ d <- rs]
|
||||
schemaDec <- tySynD schemaName' [] (pure $ typesToList schemaTypes)
|
||||
serviceDec <- tySynD serviceName' []
|
||||
[t| 'Package ('Just $(textToStrLit $ T.pack serviceName))
|
||||
$(pure $ typesToList serviceTypes) |]
|
||||
pure [schemaDec, serviceDec]
|
||||
pkgTy <- [t| 'Package ('Just $(textToStrLit $ T.pack serviceName))
|
||||
$(pure $ typesToList serviceTypes) |]
|
||||
serviceDec <- tySynD serviceName' [] (pure pkgTy)
|
||||
defaultDec <- [d| type instance AnnotatedPackage DefaultValue $(pure pkgTy) =
|
||||
$(typesToList <$> traverse defaultDeclToTy defaultDefs) |]
|
||||
pure $ schemaDec : serviceDec : defaultDec
|
||||
|
||||
defaultDeclToTy :: (T.Text, (T.Text, (T.Text, Type))) -> Q Type
|
||||
defaultDeclToTy (sn, (mn, (an, dv)))
|
||||
= [t| 'AnnArg $(textToStrLit sn) $(textToStrLit mn) $(textToStrLit an) $(pure dv) |]
|
||||
|
||||
-- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'.
|
||||
typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result
|
||||
typeToDec _ _ _ (GQL.TypeDefinitionInterface _)
|
||||
= fail "interface types are not supported"
|
||||
typeToDec _ _ _ (GQL.TypeDefinitionUnion _)
|
||||
= fail "union types are not supported"
|
||||
typeToDec schemaName tm _ (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ s _)) =
|
||||
GQLScalar <$ gqlTypeToType s tm schemaName
|
||||
typeToDec schemaName tm sm (GQL.TypeDefinitionObject objs) = objToDec objs
|
||||
where
|
||||
objToDec :: GQL.ObjectTypeDefinition -> Q Result
|
||||
objToDec (GQL.ObjectTypeDefinition _ (coerce -> nm) _ _ flds) =
|
||||
GQLService <$> [t| 'Service $(textToStrLit nm) '[]
|
||||
$(typesToList <$> traverse (gqlFieldToType nm) flds) |]
|
||||
gqlFieldToType :: T.Text -> GQL.FieldDefinition -> Q Type
|
||||
gqlFieldToType sn (GQL.FieldDefinition _ (coerce -> fnm) args ftyp _) =
|
||||
[t| 'Method $(textToStrLit fnm) '[]
|
||||
$(typesToList <$> traverse argToType args)
|
||||
$(returnType sn ftyp)|]
|
||||
objToDec (GQL.ObjectTypeDefinition _ (coerce -> nm) _ _ flds) = do
|
||||
(fieldInfos, defaults) <- unzip <$> traverse (gqlFieldToType nm) flds
|
||||
GQLService <$> [t| 'Service $(textToStrLit nm)
|
||||
$(pure $ typesToList fieldInfos) |]
|
||||
<*> pure ((nm,) <$> concat defaults)
|
||||
gqlFieldToType :: T.Text -> GQL.FieldDefinition
|
||||
-> Q (Type, [(T.Text, (T.Text, Type))])
|
||||
gqlFieldToType sn (GQL.FieldDefinition _ (coerce -> fnm) args ftyp _) = do
|
||||
(argInfos, defaults) <- unzip <$> traverse argToType args
|
||||
(,) <$> [t| 'Method $(textToStrLit fnm)
|
||||
$(pure $ typesToList argInfos)
|
||||
$(returnType sn ftyp) |]
|
||||
<*> pure ((fnm,) <$> catMaybes defaults)
|
||||
returnType :: T.Text -> GQL.GType -> Q Type
|
||||
returnType serviceName typ =
|
||||
case HM.lookup serviceName sm of
|
||||
Just GQL.OperationTypeSubscription -> [t|'RetStream $(retToType typ)|]
|
||||
_ -> [t|'RetSingle $(retToType typ)|]
|
||||
argToType :: GQL.InputValueDefinition -> Q Type
|
||||
argToType :: GQL.InputValueDefinition -> Q (Type, Maybe (T.Text, Type))
|
||||
argToType (GQL.InputValueDefinition _ (coerce -> aname) atype Nothing) =
|
||||
[t| 'ArgSingle ('Just $(textToStrLit aname)) '[] $(retToType atype) |]
|
||||
(, Nothing) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |]
|
||||
argToType (GQL.InputValueDefinition _ (coerce -> aname) atype (Just defs)) =
|
||||
[t| 'ArgSingle ('Just $(textToStrLit aname))
|
||||
'[DefaultValue $( defToVConst defs )] $(retToType atype) |]
|
||||
(,) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |]
|
||||
<*> (Just . (aname,) <$> [t| 'DefaultValue $( defToVConst defs ) |])
|
||||
defToVConst :: GQL.DefaultValue -> Q Type
|
||||
defToVConst (GQL.VCInt _) = [t| 'VCInt |]
|
||||
defToVConst (GQL.VCFloat _) = fail "floats as default arguments are not supported"
|
||||
defToVConst (GQL.VCString (coerce -> s)) = [t| 'VCString $(textToStrLit s) |]
|
||||
defToVConst (GQL.VCBoolean _) = [t| 'VCBoolean|]
|
||||
defToVConst GQL.VCNull = [t| 'VCNull |]
|
||||
defToVConst (GQL.VCEnum (coerce -> e)) = [t| 'VCEnum $(textToStrLit e) |]
|
||||
defToVConst (GQL.VCList (GQL.ListValueG xs)) = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |]
|
||||
defToVConst (GQL.VCObject (GQL.ObjectValueG obj)) = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]
|
||||
defToVConst (GQL.VCBoolean _) = [t| 'VCBoolean|]
|
||||
defToVConst GQL.VCNull = [t| 'VCNull |]
|
||||
defToVConst (GQL.VCInt _) = [t| 'VCInt |]
|
||||
defToVConst (GQL.VCFloat _)
|
||||
= fail "floats as default arguments are not supported"
|
||||
defToVConst (GQL.VCString (coerce -> s))
|
||||
= [t| 'VCString $(textToStrLit s) |]
|
||||
defToVConst (GQL.VCEnum (coerce -> e))
|
||||
= [t| 'VCEnum $(textToStrLit e) |]
|
||||
defToVConst (GQL.VCList (GQL.ListValueG xs))
|
||||
= [t| 'VCList $(typesToList <$> traverse defToVConst xs) |]
|
||||
defToVConst (GQL.VCObject (GQL.ObjectValueG obj))
|
||||
= [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]
|
||||
fromGQLField :: GQL.ObjectFieldG GQL.ValueConst -> Q Type
|
||||
fromGQLField (GQL.ObjectFieldG (coerce -> n) v) = [t| ($(textToStrLit n), $(defToVConst v)) |]
|
||||
retToType :: GQL.GType -> Q Type
|
||||
@ -144,8 +173,6 @@ typeToDec schemaName tm sm (GQL.TypeDefinitionObject objs) = objToDec objs
|
||||
retToType (GQL.TypeList (coerce -> True) (coerce -> a)) =
|
||||
[t| 'OptionalRef ('ListRef $(retToType a)) |]
|
||||
retToType _ = fail "this should not happen, please, file an issue"
|
||||
typeToDec _ _ _ (GQL.TypeDefinitionInterface _) = fail "interface types are not supported"
|
||||
typeToDec _ _ _ (GQL.TypeDefinitionUnion _) = fail "union types are not supported"
|
||||
typeToDec _ _ _ (GQL.TypeDefinitionEnum enums) = enumToDecl enums
|
||||
where
|
||||
enumToDecl :: GQL.EnumTypeDefinition -> Q Result
|
||||
|
||||
@ -12,57 +12,62 @@ import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
data Document (p :: Package snm mnm anm)
|
||||
data Document (p :: Package snm mnm anm (TypeRef snm))
|
||||
(qr :: Maybe snm) (mut :: Maybe snm) (sub :: Maybe snm) where
|
||||
QueryDoc
|
||||
:: LookupService ss qr ~ 'Service qr qanns qms
|
||||
:: LookupService ss qr ~ 'Service qr qms
|
||||
=> ServiceQuery ('Package pname ss) (LookupService ss qr)
|
||||
-> Document ('Package pname ss) ('Just qr) mut sub
|
||||
MutationDoc
|
||||
:: LookupService ss mut ~ 'Service mut manns mms
|
||||
:: LookupService ss mut ~ 'Service mut mms
|
||||
=> ServiceQuery ('Package pname ss) (LookupService ss mut)
|
||||
-> Document ('Package pname ss) qr ('Just mut) sub
|
||||
SubscriptionDoc
|
||||
:: LookupService ss sub ~ 'Service sub manns mms
|
||||
:: LookupService ss sub ~ 'Service sub mms
|
||||
=> OneMethodQuery ('Package pname ss) (LookupService ss sub)
|
||||
-> Document ('Package pname ss) qr mut ('Just sub)
|
||||
|
||||
type ServiceQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm)
|
||||
type ServiceQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(s :: Service snm mnm anm (TypeRef snm))
|
||||
= [OneMethodQuery p s]
|
||||
|
||||
data OneMethodQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm) where
|
||||
data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(s :: Service snm mnm anm (TypeRef snm)) where
|
||||
OneMethodQuery
|
||||
:: Maybe Text
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
-- the special '__typename' field
|
||||
TypeNameQuery
|
||||
:: Maybe Text
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
-- introspection fields
|
||||
SchemaQuery
|
||||
:: Maybe Text
|
||||
-> GQL.SelectionSet
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
TypeQuery
|
||||
:: Maybe Text
|
||||
-> Text
|
||||
-> GQL.SelectionSet
|
||||
-> OneMethodQuery p ('Service nm anns ms)
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
|
||||
data ChosenMethodQuery (p :: Package snm mnm anm) (m :: Method snm mnm anm) where
|
||||
data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(m :: Method snm mnm anm (TypeRef snm)) where
|
||||
ChosenMethodQuery
|
||||
:: NP (ArgumentValue p) args
|
||||
-> ReturnQuery p r
|
||||
-> ChosenMethodQuery p ('Method mname anns args r)
|
||||
-> ChosenMethodQuery p ('Method mname args r)
|
||||
|
||||
data ArgumentValue (p :: Package snm mnm anm) (a :: Argument snm anm) where
|
||||
data ArgumentValue (p :: Package snm mnm anm (TypeRef snm))
|
||||
(a :: Argument snm anm (TypeRef snm)) where
|
||||
ArgumentValue :: ArgumentValue' p r
|
||||
-> ArgumentValue p ('ArgSingle aname anns r)
|
||||
-> ArgumentValue p ('ArgSingle aname r)
|
||||
ArgumentStream :: ArgumentValue' p ('ListRef r)
|
||||
-> ArgumentValue p ('ArgStream aname anns r)
|
||||
-> ArgumentValue p ('ArgStream aname r)
|
||||
|
||||
data ArgumentValue' (p :: Package snm mnm anm) (r :: TypeRef snm) where
|
||||
data ArgumentValue' (p :: Package snm mnm anm (TypeRef snm))
|
||||
(r :: TypeRef snm) where
|
||||
ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t)
|
||||
ArgSchema :: Term sch (sch :/: sty)
|
||||
-> ArgumentValue' p ('SchemaRef sch sty)
|
||||
@ -71,12 +76,14 @@ data ArgumentValue' (p :: Package snm mnm anm) (r :: TypeRef snm) where
|
||||
ArgOptional :: Maybe (ArgumentValue' p r)
|
||||
-> ArgumentValue' p ('OptionalRef r)
|
||||
|
||||
data ReturnQuery (p :: Package snm mnm anm) (r :: Return snm) where
|
||||
data ReturnQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(r :: Return snm (TypeRef snm)) where
|
||||
RNothing :: ReturnQuery p 'RetNothing
|
||||
RSingle :: ReturnQuery' p r -> ReturnQuery p ('RetSingle r)
|
||||
RStream :: ReturnQuery' p r -> ReturnQuery p ('RetStream r)
|
||||
|
||||
data ReturnQuery' (p :: Package snm mnm anm) (r :: TypeRef snm) where
|
||||
data ReturnQuery' (p :: Package snm mnm anm (TypeRef snm))
|
||||
(r :: TypeRef snm) where
|
||||
RetPrimitive :: ReturnQuery' p ('PrimitiveRef t)
|
||||
RetSchema :: SchemaQuery sch (sch :/: sty)
|
||||
-> ReturnQuery' p ('SchemaRef sch sty)
|
||||
|
||||
@ -167,7 +167,7 @@ instance IntrospectServices '[] sub where
|
||||
instance ( KnownSymbol sname
|
||||
, IntrospectFields smethods (IsSub sname sub)
|
||||
, IntrospectServices ss sub )
|
||||
=> IntrospectServices ('Service sname sanns smethods ': ss) sub where
|
||||
=> IntrospectServices ('Service sname smethods ': ss) sub where
|
||||
introspectServices _ psub = do
|
||||
let name = T.pack $ symbolVal (Proxy @sname)
|
||||
fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub))
|
||||
@ -186,7 +186,7 @@ instance ( KnownSymbol mname
|
||||
, IntrospectInputs margs
|
||||
, IntrospectReturn mret isSub
|
||||
, IntrospectFields fs isSub)
|
||||
=> IntrospectFields ('Method mname manns margs mret ': fs) isSub where
|
||||
=> IntrospectFields ('Method mname margs mret ': fs) isSub where
|
||||
introspectFields _ pIsSub = do
|
||||
let name = T.pack $ symbolVal (Proxy @mname)
|
||||
inputs <- introspectInputs (Proxy @margs)
|
||||
@ -202,7 +202,7 @@ instance IntrospectInputs '[] where
|
||||
instance ( KnownMaybeSymbol nm
|
||||
, IntrospectTypeRef r
|
||||
, IntrospectInputs args )
|
||||
=> IntrospectInputs ('ArgSingle nm anns r ': args) where
|
||||
=> IntrospectInputs ('ArgSingle nm r ': args) where
|
||||
introspectInputs _ = do
|
||||
let nm = maybeSymbolVal (Proxy @nm)
|
||||
t <- introspectTypeRef (Proxy @r) False
|
||||
@ -212,7 +212,7 @@ instance ( KnownMaybeSymbol nm
|
||||
instance ( KnownMaybeSymbol nm
|
||||
, IntrospectTypeRef r
|
||||
, IntrospectInputs args )
|
||||
=> IntrospectInputs ('ArgStream nm anns r ': args) where
|
||||
=> IntrospectInputs ('ArgStream nm r ': args) where
|
||||
introspectInputs _ = do
|
||||
let nm = maybeSymbolVal (Proxy @nm)
|
||||
t <- tList <$> introspectTypeRef (Proxy @r) False
|
||||
@ -220,7 +220,7 @@ instance ( KnownMaybeSymbol nm
|
||||
let this = Input (fromMaybe "arg" nm) Nothing t
|
||||
(this :) <$> introspectInputs (Proxy @args)
|
||||
|
||||
class IntrospectReturn (r :: Return Symbol) (isSub :: Bool) where
|
||||
class IntrospectReturn (r :: Return Symbol (TypeRef Symbol)) (isSub :: Bool) where
|
||||
introspectReturn
|
||||
:: Proxy r -> Proxy isSub -> Writer TypeMap Type
|
||||
|
||||
|
||||
@ -20,11 +20,10 @@ import Data.Coerce (coerce)
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Int (Int32)
|
||||
import Data.Kind
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.Scientific (floatingOrInteger)
|
||||
import Data.Scientific (Scientific, floatingOrInteger, toRealFloat)
|
||||
import Data.SOP.NS
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
@ -43,7 +42,10 @@ instance A.FromJSON GQL.ValueConst where
|
||||
parseJSON A.Null = pure GQL.VCNull
|
||||
parseJSON (A.Bool b) = pure $ GQL.VCBoolean b
|
||||
parseJSON (A.String s) = pure $ GQL.VCString $ coerce s
|
||||
parseJSON (A.Number n) = pure $ either GQL.VCFloat GQL.VCInt $ floatingOrInteger n
|
||||
parseJSON (A.Number n)
|
||||
| (Right i :: Either Double Integer) <- floatingOrInteger n
|
||||
= pure $ GQL.VCInt i
|
||||
| otherwise = pure $ GQL.VCFloat n
|
||||
parseJSON (A.Array xs) = GQL.VCList . GQL.ListValueG . F.toList <$> traverse A.parseJSON xs
|
||||
parseJSON (A.Object o) = GQL.VCObject . GQL.ObjectValueG . fmap toObjFld . HM.toList <$> traverse A.parseJSON o
|
||||
where
|
||||
@ -118,12 +120,12 @@ class ParseTypedDoc (p :: Package')
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
KnownName qr, ParseMethod p qmethods,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
KnownName mut, ParseMethod p mmethods,
|
||||
LookupService ss sub ~ 'Service sub sanns smethods,
|
||||
KnownName sub, ParseMethod p smethods
|
||||
LookupService ss qr ~ 'Service qr qmethods,
|
||||
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods,
|
||||
LookupService ss mut ~ 'Service mut mmethods,
|
||||
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods,
|
||||
LookupService ss sub ~ 'Service sub smethods,
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
@ -137,10 +139,10 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
KnownName qr, ParseMethod p qmethods,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
KnownName mut, ParseMethod p mmethods
|
||||
LookupService ss qr ~ 'Service qr qmethods,
|
||||
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods,
|
||||
LookupService ss mut ~ 'Service mut mmethods,
|
||||
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods
|
||||
) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
@ -151,10 +153,10 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
KnownName qr, ParseMethod p qmethods,
|
||||
LookupService ss sub ~ 'Service sub sanns smethods,
|
||||
KnownName sub, ParseMethod p smethods
|
||||
LookupService ss qr ~ 'Service qr qmethods,
|
||||
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods,
|
||||
LookupService ss sub ~ 'Service sub smethods,
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
@ -168,8 +170,8 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||
KnownName qr, ParseMethod p qmethods
|
||||
LookupService ss qr ~ 'Service qr qmethods,
|
||||
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods
|
||||
) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
@ -180,10 +182,10 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
KnownName mut, ParseMethod p mmethods,
|
||||
LookupService ss sub ~ 'Service sub sanns smethods,
|
||||
KnownName sub, ParseMethod p smethods
|
||||
LookupService ss mut ~ 'Service mut mmethods,
|
||||
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods,
|
||||
LookupService ss sub ~ 'Service sub smethods,
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p 'Nothing ('Just mut) ('Just sub) where
|
||||
parseTypedDocQuery _ _ _
|
||||
= throwError "no queries are defined in the schema"
|
||||
@ -197,8 +199,8 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||
KnownName mut, ParseMethod p mmethods
|
||||
LookupService ss mut ~ 'Service mut mmethods,
|
||||
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods
|
||||
) => ParseTypedDoc p 'Nothing ('Just mut) 'Nothing where
|
||||
parseTypedDocQuery _ _ _
|
||||
= throwError "no queries are defined in the schema"
|
||||
@ -209,8 +211,8 @@ instance
|
||||
|
||||
instance
|
||||
( p ~ 'Package pname ss,
|
||||
LookupService ss sub ~ 'Service sub sanns smethods,
|
||||
KnownName sub, ParseMethod p smethods
|
||||
LookupService ss sub ~ 'Service sub smethods,
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p 'Nothing 'Nothing ('Just sub) where
|
||||
parseTypedDocQuery _ _ _
|
||||
= throwError "no queries are defined in the schema"
|
||||
@ -250,10 +252,10 @@ constToValue (GQL.VCObject (GQL.ObjectValueG n))
|
||||
[ GQL.ObjectFieldG a (constToValue v) | GQL.ObjectFieldG a v <- n ]
|
||||
|
||||
parseQuery ::
|
||||
forall (p :: Package') (s :: Symbol) pname ss sanns methods f.
|
||||
forall (p :: Package') (s :: Symbol) pname ss methods f.
|
||||
( MonadError T.Text f, p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s sanns methods,
|
||||
KnownName s, ParseMethod p methods
|
||||
LookupService ss s ~ 'Service s methods,
|
||||
KnownName s, ParseMethod p ('Service s methods) methods
|
||||
) =>
|
||||
Proxy p ->
|
||||
Proxy s ->
|
||||
@ -264,7 +266,7 @@ parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
|
||||
= (++) <$> (maybeToList <$> fieldToMethod fld)
|
||||
<*> parseQuery pp ps vmap frmap ss
|
||||
where
|
||||
fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname sanns methods)))
|
||||
fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))
|
||||
fieldToMethod (GQL.Field alias name args dirs sels)
|
||||
| any (shouldSkip vmap) dirs
|
||||
= pure Nothing
|
||||
@ -289,7 +291,7 @@ parseQuery pp ps vmap frmap (GQL.SelectionField fld : ss)
|
||||
_ -> throwError "__type requires one single argument"
|
||||
| otherwise
|
||||
= Just . OneMethodQuery (GQL.unName . GQL.unAlias <$> alias)
|
||||
<$> selectMethod (T.pack $ nameVal (Proxy @s)) vmap frmap name args sels
|
||||
<$> selectMethod (Proxy @('Service s methods)) (T.pack $ nameVal (Proxy @s)) vmap frmap name args sels
|
||||
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)
|
||||
@ -328,9 +330,10 @@ unFragment frmap (GQL.SelectionField (GQL.Field al nm args dir innerss) : ss)
|
||||
unFragment _ _
|
||||
= throwError "inline fragments are not (yet) supported"
|
||||
|
||||
class ParseMethod (p :: Package') (ms :: [Method']) where
|
||||
class ParseMethod (p :: Package') (s :: Service') (ms :: [Method']) where
|
||||
selectMethod ::
|
||||
MonadError T.Text f =>
|
||||
Proxy s ->
|
||||
T.Text ->
|
||||
VariableMap ->
|
||||
FragmentMap ->
|
||||
@ -339,82 +342,89 @@ class ParseMethod (p :: Package') (ms :: [Method']) where
|
||||
GQL.SelectionSet ->
|
||||
f (NS (ChosenMethodQuery p) ms)
|
||||
|
||||
instance ParseMethod p '[] where
|
||||
selectMethod tyName _ _ (GQL.unName -> wanted) _ _
|
||||
instance ParseMethod p s '[] where
|
||||
selectMethod _ tyName _ _ (GQL.unName -> wanted) _ _
|
||||
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
|
||||
instance
|
||||
(KnownSymbol mname, ParseMethod p ms, ParseArgs p args, ParseDifferentReturn p r) =>
|
||||
ParseMethod p ('Method mname manns args r ': ms)
|
||||
( KnownSymbol mname, ParseMethod p s ms
|
||||
, ParseArgs p s ('Method mname args r) args
|
||||
, ParseDifferentReturn p r) =>
|
||||
ParseMethod p s ('Method mname args r ': ms)
|
||||
where
|
||||
selectMethod tyName vmap frmap w@(GQL.unName -> wanted) args sels
|
||||
selectMethod s tyName vmap frmap w@(GQL.unName -> wanted) args sels
|
||||
| wanted == mname
|
||||
= Z <$> (ChosenMethodQuery <$> parseArgs vmap args
|
||||
= Z <$> (ChosenMethodQuery <$> parseArgs (Proxy @s) (Proxy @('Method mname args r))
|
||||
vmap args
|
||||
<*> parseDiffReturn vmap frmap wanted sels)
|
||||
| otherwise
|
||||
= S <$> selectMethod tyName vmap frmap w args sels
|
||||
= S <$> selectMethod s tyName vmap frmap w args sels
|
||||
where
|
||||
mname = T.pack $ nameVal (Proxy @mname)
|
||||
|
||||
class ParseArgs (p :: Package') (args :: [Argument']) where
|
||||
class ParseArgs (p :: Package') (s :: Service') (m :: Method') (args :: [Argument']) where
|
||||
parseArgs :: MonadError T.Text f
|
||||
=> VariableMap
|
||||
=> Proxy s -> Proxy m
|
||||
-> VariableMap
|
||||
-> [GQL.Argument]
|
||||
-> f (NP (ArgumentValue p) args)
|
||||
|
||||
instance ParseArgs p '[] where
|
||||
parseArgs _ _ = pure Nil
|
||||
instance ParseArgs p s m '[] where
|
||||
parseArgs _ _ _ _ = pure Nil
|
||||
-- one single argument without name
|
||||
instance ParseArg p a
|
||||
=> ParseArgs p '[ 'ArgSingle 'Nothing anns a ] where
|
||||
parseArgs vmap [GQL.Argument _ x]
|
||||
=> ParseArgs p s m '[ 'ArgSingle 'Nothing a ] where
|
||||
parseArgs _ _ vmap [GQL.Argument _ x]
|
||||
= (\v -> ArgumentValue v :* Nil) <$> parseArg' vmap "arg" x
|
||||
parseArgs _ _
|
||||
parseArgs _ _ _ _
|
||||
= throwError "this field receives one single argument"
|
||||
instance ParseArg p a
|
||||
=> ParseArgs p '[ 'ArgStream 'Nothing anns a ] where
|
||||
parseArgs vmap [GQL.Argument _ x]
|
||||
=> ParseArgs p s m '[ 'ArgStream 'Nothing a ] where
|
||||
parseArgs _ _ vmap [GQL.Argument _ x]
|
||||
= (\v -> ArgumentStream v :* Nil) <$> parseArg' vmap "arg" x
|
||||
parseArgs _ _
|
||||
parseArgs _ _ _ _
|
||||
= throwError "this field receives one single argument"
|
||||
-- more than one argument
|
||||
instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns)
|
||||
=> ParseArgs p ('ArgSingle ('Just aname) aanns a ': as) where
|
||||
parseArgs vmap args
|
||||
instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
, s ~ 'Service snm sms, m ~ 'Method mnm margs mr
|
||||
, ann ~ GetArgAnnotationMay (AnnotatedPackage DefaultValue p) snm mnm aname
|
||||
, FindDefaultArgValue ann )
|
||||
=> ParseArgs p s m ('ArgSingle ('Just aname) a ': as) where
|
||||
parseArgs ps pm vmap args
|
||||
= let aname = T.pack $ nameVal (Proxy @aname)
|
||||
in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of
|
||||
Just (GQL.Argument _ x)
|
||||
-> (:*) <$> (ArgumentValue <$> parseArg' vmap aname x)
|
||||
<*> parseArgs vmap args
|
||||
<*> parseArgs ps pm vmap args
|
||||
Nothing
|
||||
-> do x <- findDefaultArgValue (Proxy @aanns) aname
|
||||
-> do x <- findDefaultArgValue (Proxy @ann) aname
|
||||
(:*) <$> (ArgumentValue <$> parseArg' vmap aname (constToValue x))
|
||||
<*> parseArgs vmap args
|
||||
instance (KnownName aname, ParseArg p a, ParseArgs p as, FindDefaultArgValue aanns)
|
||||
=> ParseArgs p ('ArgStream ('Just aname) aanns a ': as) where
|
||||
parseArgs vmap args
|
||||
<*> parseArgs ps pm vmap args
|
||||
instance ( KnownName aname, ParseArg p a, ParseArgs p s m as
|
||||
, s ~ 'Service snm sms, m ~ 'Method mnm margs mr
|
||||
, ann ~ GetArgAnnotationMay (AnnotatedPackage DefaultValue p) snm mnm aname
|
||||
, FindDefaultArgValue ann )
|
||||
=> ParseArgs p s m ('ArgStream ('Just aname) a ': as) where
|
||||
parseArgs ps pm vmap args
|
||||
= let aname = T.pack $ nameVal (Proxy @aname)
|
||||
in case find ((== nameVal (Proxy @aname)) . T.unpack . GQL.unName . GQL._aName) args of
|
||||
Just (GQL.Argument _ x)
|
||||
-> (:*) <$> (ArgumentStream <$> parseArg' vmap aname x)
|
||||
<*> parseArgs vmap args
|
||||
<*> parseArgs ps pm vmap args
|
||||
Nothing
|
||||
-> do x <- findDefaultArgValue (Proxy @aanns) aname
|
||||
-> do x <- findDefaultArgValue (Proxy @ann) aname
|
||||
(:*) <$> (ArgumentStream <$> parseArg' vmap aname (constToValue x))
|
||||
<*> parseArgs vmap args
|
||||
<*> parseArgs ps pm vmap args
|
||||
|
||||
class FindDefaultArgValue (vs :: [Type]) where
|
||||
class FindDefaultArgValue (vs :: Maybe DefaultValue) where
|
||||
findDefaultArgValue :: MonadError T.Text f
|
||||
=> Proxy vs
|
||||
-> T.Text
|
||||
-> f GQL.ValueConst
|
||||
instance FindDefaultArgValue '[] where
|
||||
instance FindDefaultArgValue 'Nothing where
|
||||
findDefaultArgValue _ aname
|
||||
= throwError $ "argument '" <> aname <> "' was not given a value, and has no default one"
|
||||
instance {-# OVERLAPPABLE #-} FindDefaultArgValue xs
|
||||
=> FindDefaultArgValue (x ': xs) where
|
||||
findDefaultArgValue _ = findDefaultArgValue (Proxy @xs)
|
||||
instance {-# OVERLAPS #-} ReflectValueConst v
|
||||
=> FindDefaultArgValue (DefaultValue v ': xs) where
|
||||
instance ReflectValueConst v
|
||||
=> FindDefaultArgValue ('Just ('DefaultValue v)) where
|
||||
findDefaultArgValue _ _ = pure $ reflectValueConst (Proxy @v)
|
||||
|
||||
parseArg' :: (ParseArg p a, MonadError T.Text f)
|
||||
@ -442,22 +452,27 @@ instance (ParseArg p r) => ParseArg p ('ListRef r) where
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef Bool) where
|
||||
parseArg _ _ (GQL.VBoolean b)
|
||||
= pure (ArgPrimitive b)
|
||||
= pure $ ArgPrimitive b
|
||||
parseArg _ aname _
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef Int32) where
|
||||
parseArg _ _ (GQL.VInt b)
|
||||
= pure (ArgPrimitive b)
|
||||
= pure $ ArgPrimitive $ fromIntegral b
|
||||
parseArg _ aname _
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef Integer) where
|
||||
parseArg _ _ (GQL.VInt b)
|
||||
= pure $ ArgPrimitive $ fromIntegral b
|
||||
= pure $ ArgPrimitive b
|
||||
parseArg _ aname _
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef Scientific) where
|
||||
parseArg _ _ (GQL.VFloat b)
|
||||
= pure $ ArgPrimitive b
|
||||
parseArg _ aname _
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef Double) where
|
||||
parseArg _ _ (GQL.VFloat b)
|
||||
= pure (ArgPrimitive b)
|
||||
= pure $ ArgPrimitive $ toRealFloat b
|
||||
parseArg _ aname _
|
||||
= throwError $ "argument '" <> aname <> "' was not of right type"
|
||||
instance ParseArg p ('PrimitiveRef T.Text) where
|
||||
@ -570,19 +585,23 @@ instance ValueParser sch 'TNull where
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Bool) where
|
||||
valueParser _ _ (GQL.VBoolean b) = pure (FPrimitive b)
|
||||
valueParser _ _ (GQL.VBoolean b) = pure $ FPrimitive b
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Int32) where
|
||||
valueParser _ _ (GQL.VInt b) = pure (FPrimitive b)
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Integer) where
|
||||
valueParser _ _ (GQL.VInt b) = pure $ FPrimitive $ fromIntegral b
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Integer) where
|
||||
valueParser _ _ (GQL.VInt b) = pure $ FPrimitive b
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Scientific) where
|
||||
valueParser _ _ (GQL.VFloat b) = pure $ FPrimitive b
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive Double) where
|
||||
valueParser _ _ (GQL.VFloat b) = pure (FPrimitive b)
|
||||
valueParser _ _ (GQL.VFloat b) = pure $ FPrimitive $ toRealFloat b
|
||||
valueParser _ fname _
|
||||
= throwError $ "field '" <> fname <> "' was not of right type"
|
||||
instance ValueParser sch ('TPrimitive T.Text) where
|
||||
@ -610,7 +629,7 @@ instance (ObjectOrEnumParser sch (sch :/: sty), KnownName sty)
|
||||
valueParser vmap _ v
|
||||
= FSchematic <$> parseObjectOrEnum' vmap (T.pack $ nameVal (Proxy @sty)) v
|
||||
|
||||
class ParseDifferentReturn (p :: Package') (r :: Return Symbol) where
|
||||
class ParseDifferentReturn (p :: Package') (r :: Return Symbol (TypeRef Symbol)) where
|
||||
parseDiffReturn :: MonadError T.Text f
|
||||
=> VariableMap
|
||||
-> FragmentMap
|
||||
@ -654,8 +673,8 @@ instance ParseReturn p r
|
||||
parseReturn vmap frmap fname s
|
||||
= RetOptional <$> parseReturn vmap frmap fname s
|
||||
instance ( p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s sanns methods,
|
||||
KnownName s, ParseMethod p methods
|
||||
LookupService ss s ~ 'Service s methods,
|
||||
KnownName s, ParseMethod p ('Service s methods) methods
|
||||
) => ParseReturn p ('ObjectRef s) where
|
||||
parseReturn vmap frmap _ s
|
||||
= RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s
|
||||
|
||||
@ -229,10 +229,10 @@ yieldDocument f svr doc sink = do
|
||||
runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink
|
||||
|
||||
runQuery
|
||||
:: forall m p s pname ss hs sname sanns ms chn inh.
|
||||
:: forall m p s pname ss hs sname ms chn inh.
|
||||
( RunQueryFindHandler m p hs chn ss s hs
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ 'Service sname sanns ms
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> Intro.Schema -> ServerT chn p m hs
|
||||
@ -243,10 +243,10 @@ runQuery
|
||||
runQuery f sch whole@(Services ss) path = runQueryFindHandler f sch whole path ss
|
||||
|
||||
runSubscription
|
||||
:: forall m p s pname ss hs sname sanns ms chn inh.
|
||||
:: forall m p s pname ss hs sname ms chn inh.
|
||||
( RunQueryFindHandler m p hs chn ss s hs
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ 'Service sname sanns ms
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m hs
|
||||
@ -260,8 +260,8 @@ runSubscription f whole@(Services ss) path
|
||||
|
||||
class RunQueryFindHandler m p whole chn ss s hs where
|
||||
runQueryFindHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname sanns ms
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> Intro.Schema -> ServerT chn p m whole
|
||||
@ -271,8 +271,8 @@ class RunQueryFindHandler m p whole chn ss s hs where
|
||||
-> ServiceQuery p s
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runSubscriptionFindHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname sanns ms
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m whole
|
||||
@ -294,7 +294,9 @@ instance {-# OVERLAPPABLE #-}
|
||||
= runQueryFindHandler f sch whole path that
|
||||
runSubscriptionFindHandler f whole path (_ :<&>: that)
|
||||
= runSubscriptionFindHandler f whole path that
|
||||
instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMethod m p whole chn sname ms h)
|
||||
instance {-# OVERLAPS #-}
|
||||
( s ~ 'Service sname ms, KnownName sname
|
||||
, RunMethod m p whole chn s ms h )
|
||||
=> RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where
|
||||
runQueryFindHandler f sch whole path (this :<&>: _) inh queries
|
||||
= Aeson.object . catMaybes <$> mapM runOneQuery queries
|
||||
@ -302,7 +304,7 @@ instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMet
|
||||
-- if we include the signature we have to write
|
||||
-- an explicit type signature for 'runQueryFindHandler'
|
||||
runOneQuery (OneMethodQuery nm args)
|
||||
= runMethod f whole (Proxy @sname) path nm inh this args
|
||||
= runMethod f whole (Proxy @s) path nm inh this args
|
||||
-- handle __typename
|
||||
runOneQuery (TypeNameQuery nm)
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
@ -324,7 +326,7 @@ instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMet
|
||||
pure $ Just (realName, Aeson.Null)
|
||||
-- subscriptions should only have one element
|
||||
runSubscriptionFindHandler f whole path (this :<&>: _) inh (OneMethodQuery nm args) sink
|
||||
= runMethodSubscription f whole (Proxy @sname) path nm inh this args sink
|
||||
= runMethodSubscription f whole (Proxy @s) path nm inh this args sink
|
||||
runSubscriptionFindHandler _ _ _ _ _ (TypeNameQuery nm) sink
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))]
|
||||
@ -335,22 +337,24 @@ instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, KnownName sname, RunMet
|
||||
:: [Aeson.Value])
|
||||
.| sink
|
||||
|
||||
class RunMethod m p whole chn sname ms hs where
|
||||
class RunMethod m p whole chn s ms hs where
|
||||
runMethod
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname allMs
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m whole
|
||||
-> Proxy sname -> [T.Text] -> Maybe T.Text -> inh
|
||||
-> Proxy s -> [T.Text] -> Maybe T.Text -> inh
|
||||
-> HandlersT chn inh ms m hs
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value))
|
||||
runMethodSubscription
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname allMs
|
||||
, inh ~ MappingRight chn sname )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn p m whole
|
||||
-> Proxy sname -> [T.Text] -> Maybe T.Text -> inh
|
||||
-> Proxy s -> [T.Text] -> Maybe T.Text -> inh
|
||||
-> HandlersT chn inh ms m hs
|
||||
-> NS (ChosenMethodQuery p) ms
|
||||
-> ConduitT Aeson.Value Void IO ()
|
||||
@ -359,18 +363,23 @@ class RunMethod m p whole chn sname ms hs where
|
||||
instance RunMethod m p whole chn s '[] '[] where
|
||||
runMethod _ = error "this should never be called"
|
||||
runMethodSubscription _ = error "this should never be called"
|
||||
instance (RunMethod m p whole chn s ms hs, KnownName mname, RunHandler m p whole chn args r h)
|
||||
=> RunMethod m p whole chn s ('Method mname anns args r ': ms) (h ': hs) where
|
||||
instance ( RunMethod m p whole chn s ms hs
|
||||
, KnownName mname
|
||||
, RunHandler m p whole chn args r h
|
||||
, 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 inh) 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))
|
||||
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
|
||||
= runHandlerSubscription f whole (path ++ [realName]) (h inh) 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))
|
||||
runMethodSubscription f whole p path nm inh (_ :<||>: r) (S cont) sink
|
||||
= runMethodSubscription f whole p path nm inh r cont sink
|
||||
|
||||
@ -395,7 +404,7 @@ class Handles chn args r m h
|
||||
-> IO ()
|
||||
|
||||
instance (ArgumentConversion chn ref t, RunHandler m p whole chn rest r h)
|
||||
=> RunHandler m p whole chn ('ArgSingle aname aanns ref ': rest) r (t -> h) where
|
||||
=> RunHandler m p whole chn ('ArgSingle aname ref ': rest) r (t -> h) where
|
||||
runHandler f whole path h (ArgumentValue one :* rest)
|
||||
= runHandler f whole path (h (convertArg (Proxy @chn) one)) rest
|
||||
runHandlerSubscription f whole path h (ArgumentValue one :* rest)
|
||||
@ -404,7 +413,7 @@ instance ( MonadError ServerError m
|
||||
, FromRef chn ref t
|
||||
, ArgumentConversion chn ('ListRef ref) [t]
|
||||
, RunHandler m p whole chn rest r h )
|
||||
=> RunHandler m p whole chn ('ArgStream aname aanns ref ': rest) r (ConduitT () t m () -> h) where
|
||||
=> RunHandler m p whole chn ('ArgStream aname ref ': rest) r (ConduitT () t m () -> h) where
|
||||
runHandler f whole path h (ArgumentStream lst :* rest)
|
||||
= let converted :: [t] = convertArg (Proxy @chn) lst
|
||||
in runHandler f whole path (h (yieldMany converted)) rest
|
||||
@ -497,8 +506,8 @@ instance ( ToSchema sch l r
|
||||
= pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r
|
||||
instance ( MappingRight chn ref ~ t
|
||||
, MappingRight chn sname ~ t
|
||||
, LookupService ss ref ~ 'Service sname sanns ms
|
||||
, RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname sanns ms) whole)
|
||||
, LookupService ss ref ~ 'Service sname ms
|
||||
, RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname ms) whole)
|
||||
=> ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where
|
||||
convertResult f whole path (RetObject q) h
|
||||
= Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f
|
||||
|
||||
@ -1 +0,0 @@
|
||||
cradle: { stack: { component: "mu-graphql:lib" } }
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-grpc-client
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: gRPC clients from Mu definitions
|
||||
description:
|
||||
With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell!
|
||||
@ -38,10 +38,10 @@ library
|
||||
, http2-client
|
||||
, http2-client-grpc
|
||||
, http2-grpc-types
|
||||
, mu-grpc-common >=0.3.0
|
||||
, mu-grpc-common >=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
|
||||
, optics-core
|
||||
, sop-core
|
||||
|
||||
@ -46,11 +46,12 @@ setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient)
|
||||
setupGrpcClient' = runExceptT . setupGrpcClient
|
||||
|
||||
class GRpcServiceMethodCall (p :: GRpcMessageProtocol)
|
||||
(pkg :: snm) (s :: snm) (m :: Method snm mnm anm) h where
|
||||
(pkg :: snm) (s :: snm)
|
||||
(m :: Method snm mnm anm (TypeRef snm)) h where
|
||||
gRpcServiceMethodCall :: Proxy p -> Proxy pkg -> Proxy s -> Proxy m -> GrpcClient -> h
|
||||
instance ( KnownName serviceName, KnownName pkg, KnownName mname
|
||||
, GRpcMethodCall p ('Method mname manns margs mret) h, MkRPC p )
|
||||
=> GRpcServiceMethodCall p pkg serviceName ('Method mname manns margs mret) h where
|
||||
, GRpcMethodCall p ('Method mname margs mret) h, MkRPC p )
|
||||
=> GRpcServiceMethodCall p pkg serviceName ('Method mname margs mret) h where
|
||||
gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc
|
||||
where pkgName = BS.pack (nameVal (Proxy @pkg))
|
||||
svrName = BS.pack (nameVal (Proxy @serviceName))
|
||||
@ -137,7 +138,7 @@ class GRpcMethodCall (p :: GRpcMessageProtocol) (method :: Method') h where
|
||||
instance ( KnownName name
|
||||
, GRPCInput (RPCTy p) (), GRPCOutput (RPCTy p) ()
|
||||
, handler ~ IO (GRpcReply ()) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ ] 'RetNothing) handler where
|
||||
=> GRpcMethodCall p ('Method name '[ ] 'RetNothing) handler where
|
||||
gRpcMethodCall rpc _ client
|
||||
= simplifyResponse $
|
||||
buildGRpcReply1 <$>
|
||||
@ -146,7 +147,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r
|
||||
, handler ~ IO (GRpcReply r) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ ] ('RetSingle rref)) handler where
|
||||
=> GRpcMethodCall p ('Method name '[ ] ('RetSingle rref)) handler where
|
||||
gRpcMethodCall rpc _ client
|
||||
= fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $
|
||||
simplifyResponse $
|
||||
@ -156,7 +157,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r
|
||||
, handler ~ IO (ConduitT () (GRpcReply r) IO ()) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ ] ('RetStream rref)) handler where
|
||||
=> GRpcMethodCall p ('Method name '[ ] ('RetStream rref)) handler where
|
||||
gRpcMethodCall rpc _ client
|
||||
= do -- Create a new TMChan
|
||||
chan <- newTMChanIO :: IO (TMChan r)
|
||||
@ -185,7 +186,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
|
||||
, handler ~ (v -> IO (GRpcReply ())) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ]
|
||||
'RetNothing) handler where
|
||||
gRpcMethodCall rpc _ client x
|
||||
= simplifyResponse $
|
||||
@ -195,7 +196,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
, handler ~ (v -> IO (GRpcReply r)) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ]
|
||||
('RetSingle rref)) handler where
|
||||
gRpcMethodCall rpc _ client x
|
||||
= fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $
|
||||
@ -207,7 +208,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
, handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ]
|
||||
('RetStream rref)) handler where
|
||||
gRpcMethodCall rpc _ client x
|
||||
= do -- Create a new TMChan
|
||||
@ -237,7 +238,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
|
||||
, handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply ()))) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ]
|
||||
'RetNothing) handler where
|
||||
gRpcMethodCall rpc _ client compress
|
||||
= do -- Create a new TMChan
|
||||
@ -256,7 +257,7 @@ instance ( KnownName name
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
, handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ]
|
||||
('RetSingle rref)) handler where
|
||||
gRpcMethodCall rpc _ client compress
|
||||
= do -- Create a new TMChan
|
||||
@ -285,7 +286,7 @@ conduitFromChannel chan promise = go
|
||||
instance ( KnownName name
|
||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||
, handler ~ (CompressMode -> IO (ConduitT v (GRpcReply r) IO ())) )
|
||||
=> GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aans vref ]
|
||||
=> GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ]
|
||||
('RetStream rref)) handler where
|
||||
gRpcMethodCall rpc _ client compress
|
||||
= do -- Create a new TMChan
|
||||
|
||||
@ -68,11 +68,11 @@ initGRpc config _ = do
|
||||
Right c -> Right $ GRpcConnection c
|
||||
|
||||
instance forall (pkg :: Package') (pkgName :: Symbol)
|
||||
(service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation])
|
||||
(service :: Service') (serviceName :: Symbol)
|
||||
(methods :: [Method'])
|
||||
(p :: GRpcMessageProtocol) (m :: Symbol) t.
|
||||
( pkg ~ 'Package ('Just pkgName) '[service]
|
||||
, service ~ 'Service serviceName anns methods
|
||||
, service ~ 'Service serviceName methods
|
||||
, SearchMethodOptic p methods m t
|
||||
, KnownName serviceName
|
||||
, KnownName pkgName
|
||||
@ -96,11 +96,11 @@ class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method']) (m ::
|
||||
instance TypeError ('Text "could not find method " ':<>: ShowType m)
|
||||
=> SearchMethodOptic '[] m t where
|
||||
-}
|
||||
instance {-# OVERLAPS #-} MethodOptic p ('Method name anns ins outs) t
|
||||
=> SearchMethodOptic p ('Method name anns ins outs ': rest) name t where
|
||||
searchMethodOptic _ _ rpc = methodOptic @p rpc (Proxy @('Method name anns ins outs))
|
||||
instance {-# OVERLAPS #-} MethodOptic p ('Method name ins outs) t
|
||||
=> SearchMethodOptic p ('Method name ins outs ': rest) name t where
|
||||
searchMethodOptic _ _ rpc = methodOptic @p rpc (Proxy @('Method name ins outs))
|
||||
instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t
|
||||
=> SearchMethodOptic p ('Method other anns ins outs ': rest) name t where
|
||||
=> SearchMethodOptic p ('Method other ins outs ': rest) name t where
|
||||
searchMethodOptic _ = searchMethodOptic @p (Proxy @rest)
|
||||
|
||||
class GRpcMethodCall p method t
|
||||
@ -110,44 +110,44 @@ class GRpcMethodCall p method t
|
||||
methodOptic = gRpcMethodCall @p
|
||||
|
||||
-- No arguments
|
||||
instance forall (name :: Symbol) anns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) t p.
|
||||
( GRpcMethodCall p ('Method name '[ ] 'RetNothing) t
|
||||
, t ~ IO (GRpcReply ()) )
|
||||
=> MethodOptic p ('Method name anns '[ ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p.
|
||||
( GRpcMethodCall p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
, t ~ IO (GRpcReply (Term sch (sch :/: r))) )
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p.
|
||||
( GRpcMethodCall p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
, t ~ IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) )
|
||||
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||
-- Simple arguments
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname anns aanns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname t p.
|
||||
( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t
|
||||
, t ~ (Term sch (sch :/: v) -> IO (GRpcReply ())) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p.
|
||||
( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
, t ~ (Term sch (sch :/: v)
|
||||
-> IO (GRpcReply (Term sch (sch :/: r))) ) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p.
|
||||
( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
, t ~ (Term sch (sch :/: v)
|
||||
-> IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) ) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
-- Stream arguments
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p.
|
||||
( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
, t ~ (CompressMode
|
||||
-> IO (ConduitT (Term sch (sch :/: v))
|
||||
Void IO
|
||||
(GRpcReply (Term sch (sch :/: r))))) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname anns aanns t p.
|
||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p.
|
||||
( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
, t ~ (CompressMode
|
||||
-> IO (ConduitT (Term sch (sch :/: v))
|
||||
(GRpcReply (Term sch (sch :/: r))) IO ())) )
|
||||
=> MethodOptic p ('Method name anns '[ 'ArgStream aname aanns ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
=> MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||
|
||||
@ -52,9 +52,9 @@ import Mu.Rpc
|
||||
buildService :: forall (pro :: GRpcMessageProtocol)
|
||||
(pkg :: Package') (s :: Symbol) (p :: Symbol) t
|
||||
(pkgName :: Symbol) (ss :: [Service'])
|
||||
(anns :: [ServiceAnnotation]) (ms :: [Method']).
|
||||
(ms :: [Method']).
|
||||
( pkg ~ 'Package ('Just pkgName) ss
|
||||
, LookupService ss s ~ 'Service s anns ms
|
||||
, LookupService ss s ~ 'Service s ms
|
||||
, Generic t
|
||||
, BuildService pro pkgName s p ms (Rep t) )
|
||||
=> GrpcClient -> t
|
||||
@ -101,8 +101,10 @@ generateRecordFromService newRecordName fieldsPrefix tNamer serviceTyName
|
||||
|
||||
type Namer = String -> String
|
||||
|
||||
serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String String -> Q [Dec]
|
||||
serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods)
|
||||
serviceDefToDecl :: Name -> String -> String -> Namer
|
||||
-> Service String String String (TypeRef snm)
|
||||
-> Q [Dec]
|
||||
serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ methods)
|
||||
= do d <- dataD (pure [])
|
||||
(mkName complete)
|
||||
[]
|
||||
@ -117,26 +119,31 @@ serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods
|
||||
<*> pure []
|
||||
pure [d, s, FunD buildName [c]]
|
||||
|
||||
methodToDecl :: String -> Namer -> Method String String String -> Q (Name, Bang, Type)
|
||||
methodToDecl fieldsPrefix tNamer (Method mName _ args ret)
|
||||
methodToDecl :: String -> Namer
|
||||
-> Method String String String (TypeRef snm)
|
||||
-> Q (Name, Bang, Type)
|
||||
methodToDecl fieldsPrefix tNamer (Method mName args ret)
|
||||
= do let nm = firstLower (fieldsPrefix ++ mName)
|
||||
ty <- computeMethodType tNamer args ret
|
||||
pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty )
|
||||
|
||||
computeMethodType :: Namer -> [Argument String String] -> Return String -> Q Type
|
||||
computeMethodType :: Namer
|
||||
-> [Argument String String (TypeRef snm)]
|
||||
-> Return String (TypeRef snm)
|
||||
-> Q Type
|
||||
computeMethodType _ [] RetNothing
|
||||
= [t|IO (GRpcReply ())|]
|
||||
computeMethodType n [] (RetSingle r)
|
||||
= [t|IO (GRpcReply $(typeRefToType n r))|]
|
||||
computeMethodType n [ArgSingle _ _ v] RetNothing
|
||||
computeMethodType n [ArgSingle _ v] RetNothing
|
||||
= [t|$(typeRefToType n v) -> IO (GRpcReply ())|]
|
||||
computeMethodType n [ArgSingle _ _ v] (RetSingle r)
|
||||
computeMethodType n [ArgSingle _ v] (RetSingle r)
|
||||
= [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|]
|
||||
computeMethodType n [ArgStream _ _ v] (RetSingle r)
|
||||
computeMethodType n [ArgStream _ v] (RetSingle r)
|
||||
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|]
|
||||
computeMethodType n [ArgSingle _ _ v] (RetStream r)
|
||||
computeMethodType n [ArgSingle _ v] (RetStream r)
|
||||
= [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|]
|
||||
computeMethodType n [ArgStream _ _ v] (RetStream r)
|
||||
computeMethodType n [ArgStream _ v] (RetStream r)
|
||||
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
|
||||
computeMethodType _ _ _ = fail "method signature not supported"
|
||||
|
||||
@ -161,35 +168,33 @@ firstLower (x:rest) = toLower x : rest
|
||||
-- Parsing
|
||||
-- =======
|
||||
|
||||
typeToServiceDef :: Type -> Q (Maybe (Service String String String))
|
||||
typeToServiceDef :: Type -> Q (Maybe (Service String String String (TypeRef snm)))
|
||||
typeToServiceDef toplevelty
|
||||
= typeToServiceDef' <$> resolveTypeSynonyms toplevelty
|
||||
where
|
||||
typeToServiceDef' :: Type -> Maybe (Service String String String)
|
||||
typeToServiceDef' :: Type -> Maybe (Service String String String (TypeRef snm))
|
||||
typeToServiceDef' expanded
|
||||
= do (sn, _, methods) <- tyD3 'Service expanded
|
||||
methods' <- tyList methods
|
||||
Service <$> tyString sn
|
||||
<*> pure []
|
||||
<*> mapM typeToMethodDef methods'
|
||||
|
||||
typeToMethodDef :: Type -> Maybe (Method String String String)
|
||||
typeToMethodDef :: Type -> Maybe (Method String String String (TypeRef snm))
|
||||
typeToMethodDef ty
|
||||
= do (mn, _, args, ret) <- tyD4 'Method ty
|
||||
args' <- tyList args
|
||||
Method <$> tyString mn
|
||||
<*> pure []
|
||||
<*> mapM typeToArgDef args'
|
||||
<*> typeToRetDef ret
|
||||
|
||||
typeToArgDef :: Type -> Maybe (Argument String String)
|
||||
typeToArgDef :: Type -> Maybe (Argument String String (TypeRef snm))
|
||||
typeToArgDef ty
|
||||
= (do (n, _, t) <- tyD3 'ArgSingle ty
|
||||
ArgSingle <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t)
|
||||
ArgSingle <$> tyMaybeString n <*> typeToTypeRef t)
|
||||
<|> (do (n, _, t) <- tyD3 'ArgStream ty
|
||||
ArgStream <$> tyMaybeString n <*> pure [] <*> typeToTypeRef t)
|
||||
ArgStream <$> tyMaybeString n <*> typeToTypeRef t)
|
||||
|
||||
typeToRetDef :: Type -> Maybe (Return String)
|
||||
typeToRetDef :: Type -> Maybe (Return String (TypeRef snm))
|
||||
typeToRetDef ty
|
||||
= RetNothing <$ tyD0 'RetNothing ty
|
||||
<|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef)
|
||||
|
||||
@ -47,9 +47,10 @@ import Mu.GRpc.Client.Internal
|
||||
-- * A single input or output turns into a single value.
|
||||
-- * A streaming input or output turns into a Conduit.
|
||||
gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package')
|
||||
(srvName :: Symbol) (methodName :: Symbol) h pkgName services anns methods.
|
||||
(srvName :: Symbol) (methodName :: Symbol) h
|
||||
pkgName services methods.
|
||||
( pkg ~ 'Package ('Just pkgName) services
|
||||
, LookupService services srvName ~ 'Service srvName anns methods
|
||||
, LookupService services srvName ~ 'Service srvName methods
|
||||
, GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h)
|
||||
=> GrpcClient -> h
|
||||
gRpcCall
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-grpc-common
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: gRPC for Mu, common modules for client and server
|
||||
description:
|
||||
Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts).
|
||||
@ -31,9 +31,9 @@ library
|
||||
, bytestring
|
||||
, http2-grpc-proto3-wire
|
||||
, http2-grpc-types
|
||||
, mu-avro >=0.3.0
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-avro >=0.4.0
|
||||
, mu-protobuf >=0.4.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
@ -1 +1,6 @@
|
||||
cradle: { stack: { component: "mu-grpc-server:lib" } }
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "mu-grpc-server:lib"
|
||||
- path: "./exe"
|
||||
component: "mu-grpc-server:exe:grpc-example-server"
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: mu-grpc-server
|
||||
version: 0.3.0.0
|
||||
version: 0.4.0.0
|
||||
synopsis: gRPC servers for Mu definitions
|
||||
description:
|
||||
With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell!
|
||||
@ -31,9 +31,9 @@ library
|
||||
, conduit
|
||||
, http2-grpc-types
|
||||
, mtl
|
||||
, mu-grpc-common >=0.3.0
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-grpc-common >=0.4.0
|
||||
, mu-protobuf >=0.4.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
, sop-core
|
||||
, stm
|
||||
@ -49,7 +49,6 @@ library
|
||||
|
||||
executable grpc-example-server
|
||||
main-is: ExampleServer.hs
|
||||
other-modules: Mu.GRpc.Server
|
||||
build-depends:
|
||||
async
|
||||
, avro >=0.4.7
|
||||
@ -59,9 +58,10 @@ executable grpc-example-server
|
||||
, conduit
|
||||
, http2-grpc-types
|
||||
, mtl
|
||||
, mu-grpc-common >=0.3.0
|
||||
, mu-protobuf >=0.3.0
|
||||
, mu-rpc >=0.3.0
|
||||
, mu-grpc-common >=0.4.0
|
||||
, mu-grpc-server
|
||||
, mu-protobuf >=0.4.0
|
||||
, mu-rpc >=0.4.0
|
||||
, mu-schema >=0.3.0
|
||||
, sop-core
|
||||
, stm
|
||||
@ -71,6 +71,6 @@ executable grpc-example-server
|
||||
, warp-grpc >=0.4.0.1
|
||||
, warp-tls
|
||||
|
||||
hs-source-dirs: src
|
||||
hs-source-dirs: exe
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
ghc-options: -Wall -fprint-explicit-kinds -fprint-explicit-foralls
|
||||
|
||||
@ -65,7 +65,9 @@ import Mu.Server
|
||||
|
||||
-- | Run a Mu 'Server' on the given port.
|
||||
runGRpcApp
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol ServerErrorIO chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Port
|
||||
-> ServerT chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||
@ -74,7 +76,9 @@ runGRpcApp protocol port = runGRpcAppTrans protocol port id
|
||||
|
||||
-- | Run a Mu 'Server' on the given port.
|
||||
runGRpcAppTrans
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Port
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
@ -86,7 +90,9 @@ runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
||||
--
|
||||
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
runGRpcAppSettings
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> Settings
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
@ -99,7 +105,9 @@ runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f s
|
||||
-- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings'
|
||||
-- and to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
runGRpcAppTLS
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> TLSSettings -> Settings
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
@ -113,7 +121,9 @@ runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr
|
||||
-- for example, @wai-routes@, or you can add middleware
|
||||
-- from @wai-extra@, among others.
|
||||
gRpcApp
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol ServerErrorIO chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> ServerT chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||
-> Application
|
||||
@ -125,7 +135,9 @@ gRpcApp protocol = gRpcAppTrans protocol id
|
||||
-- for example, @wai-routes@, or you can add middleware
|
||||
-- from @wai-extra@, among others.
|
||||
gRpcAppTrans
|
||||
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
:: ( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn ('Package ('Just name) services) m handlers
|
||||
@ -136,51 +148,64 @@ gRpcAppTrans protocol f svr
|
||||
|
||||
gRpcServerHandlers
|
||||
:: forall name services handlers m protocol chn.
|
||||
( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||
( KnownName name
|
||||
, GRpcServiceHandlers ('Package ('Just name) services)
|
||||
protocol m chn services handlers )
|
||||
=> Proxy protocol
|
||||
-> (forall a. m a -> ServerErrorIO a)
|
||||
-> ServerT chn ('Package ('Just name) services) m handlers
|
||||
-> [ServiceHandler]
|
||||
gRpcServerHandlers pr f (Services svr) = gRpcServiceHandlers f pr packageName svr
|
||||
gRpcServerHandlers pr f (Services svr)
|
||||
= gRpcServiceHandlers f (Proxy @('Package ('Just name) services)) pr packageName svr
|
||||
where packageName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
class GRpcServiceHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
class GRpcServiceHandlers (fullP :: Package snm mnm anm (TypeRef snm))
|
||||
(p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
(chn :: ServiceChain snm)
|
||||
(ss :: [Service snm mnm anm]) (hs :: [[Type]]) where
|
||||
(ss :: [Service snm mnm anm (TypeRef snm)]) (hs :: [[Type]]) where
|
||||
gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||
-> Proxy p -> ByteString
|
||||
-> Proxy fullP -> Proxy p -> ByteString
|
||||
-> ServicesT chn ss m hs -> [ServiceHandler]
|
||||
|
||||
instance GRpcServiceHandlers p m chn '[] '[] where
|
||||
gRpcServiceHandlers _ _ _ S0 = []
|
||||
instance ( KnownName name, GRpcMethodHandlers p m chn (MappingRight chn name) methods h
|
||||
, GRpcServiceHandlers p m chn rest hs )
|
||||
=> GRpcServiceHandlers p m chn ('Service name anns methods ': rest) (h ': hs) where
|
||||
gRpcServiceHandlers f pr packageName (svr :<&>: rest)
|
||||
= gRpcMethodHandlers f pr packageName serviceName svr
|
||||
++ gRpcServiceHandlers f pr packageName rest
|
||||
instance GRpcServiceHandlers fullP p m chn '[] '[] where
|
||||
gRpcServiceHandlers _ _ _ _ S0 = []
|
||||
instance ( KnownName name
|
||||
, GRpcMethodHandlers fullP ('Service name methods)
|
||||
p m chn (MappingRight chn name) methods h
|
||||
, GRpcServiceHandlers fullP p m chn rest hs )
|
||||
=> GRpcServiceHandlers fullP p m chn ('Service name methods ': rest) (h ': hs) where
|
||||
gRpcServiceHandlers f pfullP pr packageName (svr :<&>: rest)
|
||||
= gRpcMethodHandlers f pfullP (Proxy @('Service name methods)) pr
|
||||
packageName serviceName svr
|
||||
++ gRpcServiceHandlers f pfullP pr packageName rest
|
||||
where serviceName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
|
||||
class GRpcMethodHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm))
|
||||
(fullS :: Service snm mnm anm (TypeRef snm))
|
||||
(p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||
(chn :: ServiceChain snm) (inh :: Type)
|
||||
(ms :: [Method snm mnm anm]) (hs :: [Type]) where
|
||||
(ms :: [Method snm mnm anm (TypeRef snm)]) (hs :: [Type]) where
|
||||
gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||
-> Proxy p -> ByteString -> ByteString
|
||||
-> Proxy fullP -> Proxy fullS -> Proxy p -> ByteString -> ByteString
|
||||
-> HandlersT chn inh ms m hs -> [ServiceHandler]
|
||||
|
||||
instance GRpcMethodHandlers p m chn inh '[] '[] where
|
||||
gRpcMethodHandlers _ _ _ _ H0 = []
|
||||
instance GRpcMethodHandlers fullP fullS p m chn inh '[] '[] where
|
||||
gRpcMethodHandlers _ _ _ _ _ _ H0 = []
|
||||
instance ( KnownName name, MkRPC p
|
||||
, ReflectRpcInfo fullP fullS ('Method name args r)
|
||||
, GRpcMethodHandler p m args r h
|
||||
, GRpcMethodHandlers p m chn () rest hs)
|
||||
=> GRpcMethodHandlers p m chn () ('Method name anns args r ': rest) (h ': hs) where
|
||||
gRpcMethodHandlers f pr p s (h :<||>: rest)
|
||||
= gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) (h ())
|
||||
: gRpcMethodHandlers f pr p s rest
|
||||
, GRpcMethodHandlers fullP fullS p m chn () rest hs)
|
||||
=> GRpcMethodHandlers fullP fullS p m chn ()
|
||||
('Method name args r ': rest) (h ': hs) where
|
||||
gRpcMethodHandlers f pfullP pfullS pr p s (Hmore _ _ h rest)
|
||||
= gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName)
|
||||
(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))
|
||||
|
||||
class GRpcMethodHandler p m args r h where
|
||||
class GRpcMethodHandler p m (args :: [Argument snm anm (TypeRef snm)]) r h where
|
||||
gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a)
|
||||
-> Proxy p -> Proxy args -> Proxy r
|
||||
-> RPCTy p -> h -> ServiceHandler
|
||||
@ -312,7 +337,7 @@ instance (MonadIO m, GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO
|
||||
-----
|
||||
|
||||
instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ())
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] 'RetNothing (v -> m ()) where
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] 'RetNothing (v -> m ()) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= unary @m @_ @(GRpcIWTy p vref v) @()
|
||||
(raiseErrors . f) rpc (\_ -> h . unGRpcIWTy (Proxy @p) (Proxy @vref))
|
||||
@ -320,7 +345,7 @@ instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ())
|
||||
-----
|
||||
|
||||
instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r)
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] ('RetSingle rref) (v -> m r) where
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetSingle rref) (v -> m r) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= unary @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
|
||||
(raiseErrors . f) rpc
|
||||
@ -331,7 +356,7 @@ instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r)
|
||||
-----
|
||||
|
||||
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname anns vref ] ('RetStream rref)
|
||||
=> GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetStream rref)
|
||||
(v -> ConduitT r Void m () -> m ()) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= serverStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
|
||||
@ -356,7 +381,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
-----
|
||||
|
||||
instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) (), MonadIO m)
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname anns vref ] 'RetNothing
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname vref ] 'RetNothing
|
||||
(ConduitT () v m () -> m ()) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= clientStream @m @_ @(GRpcIWTy p vref v) @()
|
||||
@ -381,7 +406,7 @@ instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) (), MonadIO
|
||||
-----
|
||||
|
||||
instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname anns vref ] ('RetSingle rref)
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetSingle rref)
|
||||
(ConduitT () v m () -> m r) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= clientStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
|
||||
@ -407,7 +432,7 @@ instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, Mona
|
||||
-----
|
||||
|
||||
instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname anns vref ] ('RetStream rref)
|
||||
=> GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetStream rref)
|
||||
(ConduitT () v m () -> ConduitT r Void m () -> m ()) where
|
||||
gRpcMethodHandler f _ _ _ rpc h
|
||||
= generalStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r)
|
||||
|
||||
202
instrumentation/prometheus/LICENSE
Normal file
202
instrumentation/prometheus/LICENSE
Normal file
@ -0,0 +1,202 @@
|
||||
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright © 2019-2020 47 Degrees. <http://47deg.com>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
||||
1
instrumentation/prometheus/hie.yaml
Normal file
1
instrumentation/prometheus/hie.yaml
Normal file
@ -0,0 +1 @@
|
||||
cradle: { stack: { component: "mu-prometheus:lib" } }
|
||||
38
instrumentation/prometheus/mu-prometheus.cabal
Normal file
38
instrumentation/prometheus/mu-prometheus.cabal
Normal file
@ -0,0 +1,38 @@
|
||||
name: mu-prometheus
|
||||
version: 0.4.0.0
|
||||
synopsis: Metrics support for Mu using Prometheus
|
||||
description:
|
||||
Get metrics of your running Mu servers using Prometheus
|
||||
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Alejandro Serrano
|
||||
maintainer: alejandro.serrano@47deg.com
|
||||
copyright: Copyright © 2020 <http://47deg.com 47 Degrees>
|
||||
category: Network
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
homepage: https://higherkindness.io/mu-haskell/
|
||||
bug-reports: https://github.com/higherkindness/mu-haskell/issues
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/higherkindness/mu-haskell
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Mu.Instrumentation.Prometheus
|
||||
|
||||
build-depends:
|
||||
base >=4.12 && <5
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, mu-rpc >=0.4.0
|
||||
, prometheus-client
|
||||
, text
|
||||
, wai
|
||||
, wai-middleware-prometheus
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
||||
@ -0,0 +1,68 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
module Mu.Instrumentation.Prometheus (
|
||||
initPrometheus
|
||||
, prometheus
|
||||
, prometheusWai
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar.Lifted
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Text (Text)
|
||||
import Mu.Rpc
|
||||
import Mu.Server
|
||||
import Network.Wai
|
||||
import qualified Network.Wai.Middleware.Prometheus as Wai
|
||||
import Prometheus
|
||||
|
||||
-- Taken from https://github.com/higherkindness/mu-scala/blob/master/modules/metrics/prometheus/src/main/scala/higherkindness/mu/rpc/prometheus/PrometheusMetrics.scala
|
||||
|
||||
data MuMetrics
|
||||
= MuMetrics {
|
||||
activeCalls :: Gauge
|
||||
, messagesSent :: Vector Label2 Counter
|
||||
, messagesReceived :: Vector Label2 Counter
|
||||
, callsTotal :: Vector Label2 Histogram
|
||||
}
|
||||
|
||||
initPrometheus :: Text -> IO MuMetrics
|
||||
initPrometheus prefix =
|
||||
MuMetrics <$> register (gauge $ Info (prefix <> "_active_calls") "")
|
||||
<*> register (vector ("service", "method")
|
||||
$ counter $ Info (prefix <> "_messages_sent") "")
|
||||
<*> register (vector ("service", "method")
|
||||
$ counter $ Info (prefix <> "_messages_received") "")
|
||||
<*> register (vector ("service", "method")
|
||||
$ histogram (Info (prefix <> "_calls_total") "")
|
||||
defaultBuckets)
|
||||
|
||||
prometheus :: (MonadBaseControl IO m, MonadMonitor m)
|
||||
=> MuMetrics -> ServerT chn p m topHs -> ServerT chn p m topHs
|
||||
prometheus m = wrapServer (prometheusMetrics m)
|
||||
|
||||
prometheusMetrics :: forall m a. (MonadBaseControl IO m, MonadMonitor m)
|
||||
=> MuMetrics -> RpcInfo -> 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
|
||||
incGauge (activeCalls metrics)
|
||||
withLabel (messagesReceived metrics) (sname, mname) incCounter
|
||||
( do -- We are forced to use a MVar because 'withLabel' only allows IO ()
|
||||
r <- liftBaseWith $ \runInIO -> do
|
||||
result :: MVar (StM m a) <- newEmptyMVar
|
||||
withLabel (callsTotal metrics) (sname, mname) $ \h ->
|
||||
h `observeDuration` (runInIO run >>= putMVar result)
|
||||
takeMVar result
|
||||
x <- restoreM r
|
||||
withLabel (messagesSent metrics) (sname, mname) incCounter
|
||||
pure x )
|
||||
`finally` decGauge (activeCalls metrics)
|
||||
|
||||
prometheusWai :: [Text] -> Middleware
|
||||
prometheusWai endpoint
|
||||
= Wai.prometheus (Wai.PrometheusSettings endpoint False False)
|
||||
@ -13,6 +13,7 @@ packages:
|
||||
- grpc/client
|
||||
- grpc/server
|
||||
- graphql
|
||||
- instrumentation/prometheus
|
||||
- examples/health-check
|
||||
- examples/route-guide
|
||||
- examples/seed
|
||||
@ -30,7 +31,7 @@ extra-deps:
|
||||
- hw-kafka-client-3.0.0
|
||||
- hw-kafka-conduit-2.6.0
|
||||
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
commit: ba2379640248ce67cdfe700cbb79acd91c644bdb
|
||||
# missing in LTS 14.x
|
||||
- AC-Angle-1.0
|
||||
- avro-0.5.1.0
|
||||
@ -47,3 +48,4 @@ extra-deps:
|
||||
- regex-tdfa-1.3.1.0
|
||||
- stm-hamt-1.2.0.4
|
||||
- stm-containers-1.1.0.4
|
||||
- wai-middleware-prometheus-1.0.0
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
resolver: nightly-2020-04-01
|
||||
resolver: nightly-2020-06-08
|
||||
allow-newer: true
|
||||
|
||||
packages:
|
||||
@ -13,6 +13,7 @@ packages:
|
||||
- grpc/client
|
||||
- grpc/server
|
||||
- graphql
|
||||
- instrumentation/prometheus
|
||||
- examples/health-check
|
||||
- examples/route-guide
|
||||
- examples/seed
|
||||
@ -30,6 +31,7 @@ extra-deps:
|
||||
- hw-kafka-client-3.0.0
|
||||
- hw-kafka-conduit-2.6.0
|
||||
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
commit: ba2379640248ce67cdfe700cbb79acd91c644bdb
|
||||
- avro-0.5.1.0
|
||||
- language-avro-0.1.3.1
|
||||
- wai-middleware-prometheus-1.0.0
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
resolver: lts-15.5
|
||||
resolver: lts-15.16
|
||||
allow-newer: true
|
||||
|
||||
packages:
|
||||
@ -13,6 +13,7 @@ packages:
|
||||
- grpc/client
|
||||
- grpc/server
|
||||
- graphql
|
||||
- instrumentation/prometheus
|
||||
- examples/health-check
|
||||
- examples/route-guide
|
||||
- examples/seed
|
||||
@ -30,6 +31,7 @@ extra-deps:
|
||||
- hw-kafka-client-3.0.0
|
||||
- hw-kafka-conduit-2.6.0
|
||||
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||
commit: ba2379640248ce67cdfe700cbb79acd91c644bdb
|
||||
- avro-0.5.1.0
|
||||
- language-avro-0.1.3.1
|
||||
- wai-middleware-prometheus-1.0.0
|
||||
|
||||
Loading…
Reference in New Issue
Block a user