mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-08-17 02:10:22 +03:00
New API to support GraphQL resolvers as services (#111)
Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>
This commit is contained in:
parent
551b777b87
commit
c1c23326ef
@ -197,7 +197,7 @@ instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))
|
|||||||
fromAvro v = TSimple <$> A.fromAvro v
|
fromAvro v = TSimple <$> A.fromAvro v
|
||||||
|
|
||||||
instance A.FromAvro (FieldValue f sch 'TNull) where
|
instance A.FromAvro (FieldValue f sch 'TNull) where
|
||||||
fromAvro AVal.Null = return FNull
|
fromAvro AVal.Null = pure FNull
|
||||||
fromAvro v = A.badValue v "null"
|
fromAvro v = A.badValue v "null"
|
||||||
instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where
|
instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where
|
||||||
fromAvro v = FPrimitive <$> A.fromAvro v
|
fromAvro v = FPrimitive <$> A.fromAvro v
|
||||||
@ -228,7 +228,7 @@ class FromAvroEnum (vs :: [ChoiceDef fn]) where
|
|||||||
instance FromAvroEnum '[] where
|
instance FromAvroEnum '[] where
|
||||||
fromAvroEnum v _ = A.badValue v "element not found"
|
fromAvroEnum v _ = A.badValue v "element not found"
|
||||||
instance FromAvroEnum vs => FromAvroEnum (v ': vs) where
|
instance FromAvroEnum vs => FromAvroEnum (v ': vs) where
|
||||||
fromAvroEnum _ 0 = return (Z Proxy)
|
fromAvroEnum _ 0 = pure (Z Proxy)
|
||||||
fromAvroEnum v n = S <$> fromAvroEnum v (n-1)
|
fromAvroEnum v n = S <$> fromAvroEnum v (n-1)
|
||||||
|
|
||||||
class FromAvroUnion f sch choices where
|
class FromAvroUnion f sch choices where
|
||||||
@ -246,7 +246,7 @@ instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us)
|
|||||||
class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where
|
class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where
|
||||||
fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Schema) -> A.Result (NP (Field f sch) fs)
|
fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Schema) -> A.Result (NP (Field f sch) fs)
|
||||||
instance FromAvroFields f sch '[] where
|
instance FromAvroFields f sch '[] where
|
||||||
fromAvroF _ = return Nil
|
fromAvroF _ = pure Nil
|
||||||
instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs)
|
instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs)
|
||||||
=> FromAvroFields f sch ('FieldDef name t ': fs) where
|
=> FromAvroFields f sch ('FieldDef name t ': fs) where
|
||||||
fromAvroF v = case HM.lookup fieldName v of
|
fromAvroF v = case HM.lookup fieldName v of
|
||||||
|
@ -88,13 +88,15 @@ avdlToDecls schemaName serviceName protocol
|
|||||||
serviceName' = mkName serviceName
|
serviceName' = mkName serviceName
|
||||||
schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol))
|
schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol))
|
||||||
serviceDec <- tySynD serviceName' []
|
serviceDec <- tySynD serviceName' []
|
||||||
[t| 'Service $(textToStrLit (A.pname protocol)) $(pkgType (A.ns protocol))
|
[t| 'Package $(pkgType (A.ns protocol))
|
||||||
$(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |]
|
'[ 'Service $(textToStrLit (A.pname protocol)) '[]
|
||||||
return [schemaDec, serviceDec]
|
$(typesToList <$> mapM (avroMethodToType schemaName')
|
||||||
|
(S.toList $ A.messages protocol)) ] |]
|
||||||
|
pure [schemaDec, serviceDec]
|
||||||
where
|
where
|
||||||
pkgType Nothing = [t| '[] |]
|
pkgType Nothing = [t| 'Nothing |]
|
||||||
pkgType (Just (A.Namespace p))
|
pkgType (Just (A.Namespace p))
|
||||||
= [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
|
= [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
|
||||||
|
|
||||||
schemaFromAvro :: [A.Schema] -> Q Type
|
schemaFromAvro :: [A.Schema] -> Q Type
|
||||||
schemaFromAvro =
|
schemaFromAvro =
|
||||||
@ -181,7 +183,7 @@ avroMethodToType schemaName m
|
|||||||
where
|
where
|
||||||
argToType :: A.Argument -> Q Type
|
argToType :: A.Argument -> Q Type
|
||||||
argToType (A.Argument (A.NamedType a) _)
|
argToType (A.Argument (A.NamedType a) _)
|
||||||
= [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
= [t| 'ArgSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||||
argToType (A.Argument _ _)
|
argToType (A.Argument _ _)
|
||||||
= fail "only named types may be used as arguments"
|
= fail "only named types may be used as arguments"
|
||||||
|
|
||||||
@ -189,7 +191,7 @@ avroMethodToType schemaName m
|
|||||||
retToType A.Null
|
retToType A.Null
|
||||||
= [t| 'RetNothing |]
|
= [t| 'RetNothing |]
|
||||||
retToType (A.NamedType a)
|
retToType (A.NamedType a)
|
||||||
= [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
= [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
|
||||||
retToType _
|
retToType _
|
||||||
= fail "only named types may be used as results"
|
= fail "only named types may be used as results"
|
||||||
|
|
||||||
@ -197,4 +199,4 @@ typesToList :: [Type] -> Type
|
|||||||
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||||
|
|
||||||
textToStrLit :: T.Text -> Q Type
|
textToStrLit :: T.Text -> Q Type
|
||||||
textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
|
textToStrLit s = litT $ strTyLit $ T.unpack s
|
||||||
|
@ -225,7 +225,7 @@ instance ProtoBridgeTerm w sch ('DRecord name args)
|
|||||||
t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
||||||
case t of
|
case t of
|
||||||
Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))
|
Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))
|
||||||
Just v -> return v
|
Just v -> pure v
|
||||||
embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))
|
||||||
|
|
||||||
-- ENUMERATIONS
|
-- ENUMERATIONS
|
||||||
@ -256,7 +256,7 @@ instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs)
|
|||||||
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
||||||
enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v
|
enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v
|
||||||
protoToEnum n
|
protoToEnum n
|
||||||
| n == enumValue = return (Z Proxy)
|
| n == enumValue = pure (Z Proxy)
|
||||||
| otherwise = S <$> protoToEnum @_ @_ @sch @ty n
|
| otherwise = S <$> protoToEnum @_ @_ @sch @ty n
|
||||||
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
|
||||||
|
|
||||||
|
@ -28,11 +28,11 @@ import Mu.Schema
|
|||||||
|
|
||||||
-- | Specifies that a type is turned into a Protocol Buffers
|
-- | Specifies that a type is turned into a Protocol Buffers
|
||||||
-- message by using the schema as intermediate representation.
|
-- message by using the schema as intermediate representation.
|
||||||
newtype ViaToProtoBufTypeRef (ref :: TypeRef) t
|
newtype ViaToProtoBufTypeRef (ref :: TypeRef snm) t
|
||||||
= ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t }
|
= ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t }
|
||||||
-- | Specifies that a type can be parsed from a Protocol Buffers
|
-- | Specifies that a type can be parsed from a Protocol Buffers
|
||||||
-- message by using the schema as intermediate representation.
|
-- message by using the schema as intermediate representation.
|
||||||
newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t
|
newtype ViaFromProtoBufTypeRef (ref :: TypeRef snm) t
|
||||||
= ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }
|
= ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }
|
||||||
|
|
||||||
instance ToProtoBufTypeRef ref t
|
instance ToProtoBufTypeRef ref t
|
||||||
@ -46,29 +46,29 @@ instance FromProtoBufTypeRef ref t
|
|||||||
|
|
||||||
instance Proto3WireEncoder () where
|
instance Proto3WireEncoder () where
|
||||||
proto3WireEncode _ = mempty
|
proto3WireEncode _ = mempty
|
||||||
proto3WireDecode = return ()
|
proto3WireDecode = pure ()
|
||||||
|
|
||||||
-- | Types which can be parsed from a Protocol Buffers message.
|
-- | Types which can be parsed from a Protocol Buffers message.
|
||||||
class FromProtoBufTypeRef (ref :: TypeRef) t where
|
class FromProtoBufTypeRef (ref :: TypeRef snm) t where
|
||||||
fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t
|
fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t
|
||||||
-- | Types which can be turned into a Protocol Buffers message.
|
-- | Types which can be turned into a Protocol Buffers message.
|
||||||
class ToProtoBufTypeRef (ref :: TypeRef) t where
|
class ToProtoBufTypeRef (ref :: TypeRef snm) t where
|
||||||
toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder
|
toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder
|
||||||
|
|
||||||
instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)
|
instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)
|
||||||
=> FromProtoBufTypeRef ('ViaSchema sch sty) t where
|
=> FromProtoBufTypeRef ('SchemaRef sch sty) t where
|
||||||
fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch
|
fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch
|
||||||
instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)
|
instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)
|
||||||
=> ToProtoBufTypeRef ('ViaSchema sch sty) t where
|
=> ToProtoBufTypeRef ('SchemaRef sch sty) t where
|
||||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch
|
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch
|
||||||
|
|
||||||
instance ( FromProtoBufRegistry r t
|
instance ( FromProtoBufRegistry r t
|
||||||
, IsProtoSchema Maybe (MappingRight r last) sty
|
, IsProtoSchema Maybe (MappingRight r last) sty
|
||||||
, FromSchema Maybe (MappingRight r last) sty t )
|
, FromSchema Maybe (MappingRight r last) sty t )
|
||||||
=> FromProtoBufTypeRef ('ViaRegistry r t last) t where
|
=> FromProtoBufTypeRef ('RegistryRef r t last) t where
|
||||||
fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r
|
fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r
|
||||||
instance ( FromProtoBufRegistry r t
|
instance ( FromProtoBufRegistry r t
|
||||||
, IsProtoSchema Maybe (MappingRight r last) sty
|
, IsProtoSchema Maybe (MappingRight r last) sty
|
||||||
, ToSchema Maybe (MappingRight r last) sty t )
|
, ToSchema Maybe (MappingRight r last) sty t )
|
||||||
=> ToProtoBufTypeRef ('ViaRegistry r t last) t where
|
=> ToProtoBufTypeRef ('RegistryRef r t last) t where
|
||||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last)
|
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last)
|
||||||
|
@ -60,7 +60,7 @@ grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services
|
|||||||
= do let schemaName' = mkName schemaName
|
= do let schemaName' = mkName schemaName
|
||||||
schemaDec <- protobufToDecls schemaName p
|
schemaDec <- protobufToDecls schemaName p
|
||||||
serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs
|
serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs
|
||||||
return (schemaDec ++ serviceTy)
|
pure (schemaDec ++ serviceTy)
|
||||||
|
|
||||||
pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec
|
pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec
|
||||||
pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
||||||
@ -69,11 +69,12 @@ pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
|
|||||||
|
|
||||||
pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
|
pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
|
||||||
pbServiceDeclToType pkg schema (P.Service nm _ methods)
|
pbServiceDeclToType pkg schema (P.Service nm _ methods)
|
||||||
= [t| 'Service $(textToStrLit nm) $(pkgType pkg)
|
= [t| 'Package $(pkgType pkg)
|
||||||
$(typesToList <$> mapM (pbMethodToType schema) methods) |]
|
'[ 'Service $(textToStrLit nm) '[]
|
||||||
|
$(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
|
||||||
where
|
where
|
||||||
pkgType Nothing = [t| '[] |]
|
pkgType Nothing = [t| 'Nothing |]
|
||||||
pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
|
pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
|
||||||
|
|
||||||
pbMethodToType :: Name -> P.Method -> Q Type
|
pbMethodToType :: Name -> P.Method -> Q Type
|
||||||
pbMethodToType s (P.Method nm vr v rr r _)
|
pbMethodToType s (P.Method nm vr v rr r _)
|
||||||
@ -83,27 +84,27 @@ pbMethodToType s (P.Method nm vr v rr r _)
|
|||||||
argToType P.Single (P.TOther ["google","protobuf","Empty"])
|
argToType P.Single (P.TOther ["google","protobuf","Empty"])
|
||||||
= [t| '[ ] |]
|
= [t| '[ ] |]
|
||||||
argToType P.Single (P.TOther a)
|
argToType P.Single (P.TOther a)
|
||||||
= [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
|
= [t| '[ 'ArgSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||||
argToType P.Stream (P.TOther a)
|
argToType P.Stream (P.TOther a)
|
||||||
= [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
|
= [t| '[ 'ArgStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
|
||||||
argToType _ _
|
argToType _ _
|
||||||
= fail "only message types may be used as arguments"
|
= fail "only message types may be used as arguments"
|
||||||
|
|
||||||
retToType P.Single (P.TOther ["google","protobuf","Empty"])
|
retToType P.Single (P.TOther ["google","protobuf","Empty"])
|
||||||
= [t| 'RetNothing |]
|
= [t| 'RetNothing |]
|
||||||
retToType P.Single (P.TOther a)
|
retToType P.Single (P.TOther a)
|
||||||
= [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
|
= [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
|
||||||
retToType P.Stream (P.TOther a)
|
retToType P.Stream (P.TOther a)
|
||||||
= [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
|
= [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
|
||||||
retToType _ _
|
retToType _ _
|
||||||
= fail "only message types may be used as results"
|
= fail "only message types may be used as results"
|
||||||
|
|
||||||
schemaTy :: Name -> Q Type
|
schemaTy :: Name -> Q Type
|
||||||
schemaTy schema = return $ ConT schema
|
schemaTy schema = pure $ ConT schema
|
||||||
|
|
||||||
typesToList :: [Type] -> Type
|
typesToList :: [Type] -> Type
|
||||||
typesToList
|
typesToList
|
||||||
= foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
= foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||||
textToStrLit :: T.Text -> Q Type
|
textToStrLit :: T.Text -> Q Type
|
||||||
textToStrLit s
|
textToStrLit s
|
||||||
= return $ LitT $ StrTyLit $ T.unpack s
|
= pure $ LitT $ StrTyLit $ T.unpack s
|
||||||
|
@ -26,8 +26,8 @@ import Language.ProtocolBuffers.Parser
|
|||||||
import qualified Language.ProtocolBuffers.Types as P
|
import qualified Language.ProtocolBuffers.Types as P
|
||||||
|
|
||||||
import Mu.Adapter.ProtoBuf
|
import Mu.Adapter.ProtoBuf
|
||||||
import Mu.Schema.Definition
|
|
||||||
import Mu.Schema.Annotations
|
import Mu.Schema.Annotations
|
||||||
|
import Mu.Schema.Definition
|
||||||
|
|
||||||
-- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema'
|
-- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema'
|
||||||
-- with all the message types, using the name given
|
-- with all the message types, using the name given
|
||||||
@ -46,22 +46,22 @@ protobufToDecls :: String -> P.ProtoBuf -> Q [Dec]
|
|||||||
protobufToDecls schemaName p
|
protobufToDecls schemaName p
|
||||||
= do let schemaName' = mkName schemaName
|
= do let schemaName' = mkName schemaName
|
||||||
(schTy, annTy) <- schemaFromProtoBuf p
|
(schTy, annTy) <- schemaFromProtoBuf p
|
||||||
schemaDec <- tySynD schemaName' [] (return schTy)
|
schemaDec <- tySynD schemaName' [] (pure schTy)
|
||||||
#if MIN_VERSION_template_haskell(2,15,0)
|
#if MIN_VERSION_template_haskell(2,15,0)
|
||||||
annDec <- tySynInstD (tySynEqn Nothing
|
annDec <- tySynInstD (tySynEqn Nothing
|
||||||
[t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]
|
[t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]
|
||||||
(return annTy))
|
(pure annTy))
|
||||||
#else
|
#else
|
||||||
annDec <- tySynInstD ''AnnotatedSchema
|
annDec <- tySynInstD ''AnnotatedSchema
|
||||||
(tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))
|
(tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy))
|
||||||
#endif
|
#endif
|
||||||
return [schemaDec, annDec]
|
pure [schemaDec, annDec]
|
||||||
|
|
||||||
schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type)
|
schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type)
|
||||||
schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do
|
schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do
|
||||||
let decls = flattenDecls tys
|
let decls = flattenDecls tys
|
||||||
(schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls
|
(schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls
|
||||||
return (typesToList schTys, typesToList (concat anns))
|
pure (typesToList schTys, typesToList (concat anns))
|
||||||
|
|
||||||
flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]
|
flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]
|
||||||
flattenDecls = concatMap flattenDecl
|
flattenDecls = concatMap flattenDecl
|
||||||
@ -73,7 +73,7 @@ flattenDecls = concatMap flattenDecl
|
|||||||
pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
|
pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
|
||||||
pbTypeDeclToType (P.DEnum name _ fields) = do
|
pbTypeDeclToType (P.DEnum name _ fields) = do
|
||||||
(tys, anns) <- unzip <$> mapM pbChoiceToType fields
|
(tys, anns) <- unzip <$> mapM pbChoiceToType fields
|
||||||
(,) <$> [t|'DEnum $(textToStrLit name) $(return $ typesToList tys)|] <*> pure anns
|
(,) <$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns
|
||||||
where
|
where
|
||||||
pbChoiceToType :: P.EnumField -> Q (Type, Type)
|
pbChoiceToType :: P.EnumField -> Q (Type, Type)
|
||||||
pbChoiceToType (P.EnumField nm number _)
|
pbChoiceToType (P.EnumField nm number _)
|
||||||
@ -138,7 +138,7 @@ typesToList :: [Type] -> Type
|
|||||||
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||||
|
|
||||||
textToStrLit :: T.Text -> Q Type
|
textToStrLit :: T.Text -> Q Type
|
||||||
textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
|
textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s
|
||||||
|
|
||||||
intToLit :: Int -> Q Type
|
intToLit :: Int -> Q Type
|
||||||
intToLit n = return $ LitT $ NumTyLit $ toInteger n
|
intToLit n = pure $ LitT $ NumTyLit $ toInteger n
|
||||||
|
2
cabal-fmt.sh
Normal file → Executable file
2
cabal-fmt.sh
Normal file → Executable file
@ -1 +1 @@
|
|||||||
find . -name '*.cabal' -exec sh -c 'cabal-fmt $0 > output.tmp; mv output.tmp $0' {} ';'
|
find . -name '*.cabal' -exec sh -c 'cabal-fmt -i $0' {} ';'
|
||||||
|
@ -16,3 +16,4 @@ packages: compendium-client/
|
|||||||
grpc/common/
|
grpc/common/
|
||||||
grpc/client/
|
grpc/client/
|
||||||
grpc/server/
|
grpc/server/
|
||||||
|
graphql/
|
||||||
|
@ -79,8 +79,8 @@ obtainProtoBuf m url ident = do
|
|||||||
r <- transformation m url ident Protobuf
|
r <- transformation m url ident Protobuf
|
||||||
case r of
|
case r of
|
||||||
Left e
|
Left e
|
||||||
-> return $ Left (OPEClient e)
|
-> pure $ Left (OPEClient e)
|
||||||
Right p
|
Right p
|
||||||
-> case parseProtoBuf p of
|
-> case parseProtoBuf p of
|
||||||
Left e -> return $ Left (OPEParse e)
|
Left e -> pure $ Left (OPEParse e)
|
||||||
Right pb -> return $ Right pb
|
Right pb -> pure $ Right pb
|
||||||
|
@ -14,9 +14,10 @@ RPC-like microservices independently of the transport
|
|||||||
and protocol.
|
and protocol.
|
||||||
-}
|
-}
|
||||||
module Mu.Rpc (
|
module Mu.Rpc (
|
||||||
Service', Service(..)
|
Package', Package(..)
|
||||||
, ServiceAnnotation, Package, FindPackageName
|
, Service', Service(..), Object
|
||||||
, Method(..), (:-->:)
|
, ServiceAnnotation, Method(..), ObjectField
|
||||||
|
, LookupService, LookupMethod
|
||||||
, TypeRef(..), Argument(..), Return(..)
|
, TypeRef(..), Argument(..), Return(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -27,66 +28,82 @@ import qualified Language.Haskell.TH as TH
|
|||||||
import Mu.Schema
|
import Mu.Schema
|
||||||
import Mu.Schema.Registry
|
import Mu.Schema.Registry
|
||||||
|
|
||||||
|
-- | Packages whose names are given by type-level strings.
|
||||||
|
type Package' = Package Symbol Symbol
|
||||||
-- | Services whose names are given by type-level strings.
|
-- | Services whose names are given by type-level strings.
|
||||||
type Service' = Service Symbol Symbol
|
type Service' = Service Symbol Symbol
|
||||||
-- | Annotations for services. At this moment, such
|
-- | Annotations for services. At this moment, such
|
||||||
-- annotations can be of any type.
|
-- annotations can be of any type.
|
||||||
type ServiceAnnotation = Type
|
type ServiceAnnotation = Type
|
||||||
|
|
||||||
|
-- | A package is a set of services.
|
||||||
|
data Package serviceName methodName
|
||||||
|
= Package (Maybe serviceName)
|
||||||
|
[Service serviceName methodName]
|
||||||
|
|
||||||
-- | A service is a set of methods.
|
-- | A service is a set of methods.
|
||||||
data Service serviceName methodName
|
data Service serviceName methodName
|
||||||
= Service serviceName [ServiceAnnotation] [Method methodName]
|
= Service serviceName
|
||||||
|
[ServiceAnnotation]
|
||||||
-- | An annotation to define a package name.
|
[Method serviceName methodName]
|
||||||
-- This is used by some handlers, like gRPC.
|
|
||||||
data Package (s :: Symbol)
|
|
||||||
|
|
||||||
-- | Find the 'Package' for a service, to be found
|
|
||||||
-- as part of the annotations.
|
|
||||||
type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where
|
|
||||||
FindPackageName '[] = TypeError ('Text "Cannot find package name for the service")
|
|
||||||
FindPackageName (Package s ': rest) = s
|
|
||||||
FindPackageName (other ': rest) = FindPackageName rest
|
|
||||||
|
|
||||||
-- | A method is defined by its name, arguments, and return type.
|
-- | A method is defined by its name, arguments, and return type.
|
||||||
data Method methodName
|
data Method serviceName methodName
|
||||||
= Method methodName [ServiceAnnotation] [Argument] Return
|
= Method methodName [ServiceAnnotation]
|
||||||
|
[Argument serviceName]
|
||||||
|
(Return serviceName)
|
||||||
|
|
||||||
|
-- Synonyms for GraphQL
|
||||||
|
-- | An object is a set of fields, in GraphQL lingo.
|
||||||
|
type Object = 'Service
|
||||||
|
-- | A field in an object takes some input objects,
|
||||||
|
-- and returns a value or some other object,
|
||||||
|
-- in GraphQL lingo.
|
||||||
|
type ObjectField = 'Method
|
||||||
|
|
||||||
|
type family LookupService (ss :: [Service snm mnm]) (s :: snm) :: Service snm mnm 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
|
||||||
|
|
||||||
-- | Look up a method in a service definition using its name.
|
-- | Look up a method in a service definition using its name.
|
||||||
-- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@.
|
type family LookupMethod (s :: [Method snm mnm]) (m :: mnm) :: Method snm mnm where
|
||||||
type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where
|
|
||||||
'Service sname anns methods :-->: m = LookupMethod methods m
|
|
||||||
|
|
||||||
type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where
|
|
||||||
LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)
|
LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)
|
||||||
LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r
|
LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r
|
||||||
LookupMethod (other ': ms) m = LookupMethod ms m
|
LookupMethod (other ': ms) m = LookupMethod ms m
|
||||||
|
|
||||||
-- | Defines how to handle the type
|
data TypeRef serviceName where
|
||||||
data TypeRef where
|
-- | A primitive type.
|
||||||
ViaSchema :: Schema typeName fieldName -> typeName -> TypeRef
|
PrimitiveRef :: Type -> TypeRef serviceName
|
||||||
|
-- | Chain with another service.
|
||||||
|
ObjectRef :: serviceName -> TypeRef serviceName
|
||||||
|
-- | Point to schema.
|
||||||
|
SchemaRef :: Schema typeName fieldName -> typeName -> TypeRef serviceName
|
||||||
-- | Registry subject, type to convert to, and preferred serialization version
|
-- | Registry subject, type to convert to, and preferred serialization version
|
||||||
ViaRegistry :: Registry -> Type -> Nat -> TypeRef
|
RegistryRef :: Registry -> Type -> Nat -> TypeRef serviceName
|
||||||
-- | To be used only during TH generation!
|
-- | To be used only during TH generation!
|
||||||
ViaTH :: TH.Type -> TypeRef
|
THRef :: TH.Type -> TypeRef serviceName
|
||||||
|
-- Combinators found in the gRPC and GraphQL languages.
|
||||||
|
-- | Represents a list of values.
|
||||||
|
ListRef :: TypeRef serviceName -> TypeRef serviceName
|
||||||
|
-- | Represents a possibly-missing value.
|
||||||
|
OptionalRef :: TypeRef serviceName -> TypeRef serviceName
|
||||||
|
|
||||||
-- | Defines the way in which arguments are handled.
|
-- | Defines the way in which arguments are handled.
|
||||||
data Argument where
|
data Argument serviceName where
|
||||||
-- | Use a single value.
|
-- | Use a single value.
|
||||||
ArgSingle :: TypeRef -> Argument
|
ArgSingle :: TypeRef serviceName -> Argument serviceName
|
||||||
-- | Consume a stream of values.
|
-- | Consume a stream of values.
|
||||||
ArgStream :: TypeRef -> Argument
|
ArgStream :: TypeRef serviceName -> Argument serviceName
|
||||||
|
|
||||||
-- | Defines the different possibilities for returning
|
-- | Defines the different possibilities for returning
|
||||||
-- information from a method.
|
-- information from a method.
|
||||||
data Return where
|
data Return serviceName where
|
||||||
-- | Fire and forget.
|
-- | Fire and forget.
|
||||||
RetNothing :: Return
|
RetNothing :: Return serviceName
|
||||||
-- | Return a single value.
|
-- | Return a single value.
|
||||||
RetSingle :: TypeRef -> Return
|
RetSingle :: TypeRef serviceName -> Return serviceName
|
||||||
-- | Return a value or an error
|
-- | Return a stream of values.
|
||||||
-- (this can be found in Avro IDL).
|
RetStream :: TypeRef serviceName -> Return serviceName
|
||||||
RetThrows :: TypeRef -> TypeRef -> Return
|
-- | Return a value or an error.
|
||||||
-- | Return a stream of values
|
RetThrows :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName
|
||||||
-- (this can be found in gRPC).
|
|
||||||
RetStream :: TypeRef -> Return
|
|
||||||
|
@ -36,24 +36,25 @@ import Mu.Server
|
|||||||
|
|
||||||
type QuickstartSchema
|
type QuickstartSchema
|
||||||
= '[ 'DRecord "HelloRequest"
|
= '[ 'DRecord "HelloRequest"
|
||||||
'[ 'FieldDef "name" ('TPrimitive T.Text) ]
|
'[ 'FieldDef "name" ('TPrimitive T.Text) ]
|
||||||
, 'DRecord "HelloResponse"
|
, 'DRecord "HelloResponse"
|
||||||
'[ 'FieldDef "message" ('TPrimitive T.Text) ]
|
'[ 'FieldDef "message" ('TPrimitive T.Text) ]
|
||||||
, 'DRecord "HiRequest"
|
, 'DRecord "HiRequest"
|
||||||
'[ 'FieldDef "number" ('TPrimitive Int) ]
|
'[ 'FieldDef "number" ('TPrimitive Int) ]
|
||||||
]
|
]
|
||||||
|
|
||||||
type QuickStartService
|
type QuickStartService
|
||||||
= 'Service "Greeter" '[Package "helloworld"]
|
= 'Package ('Just "helloworld")
|
||||||
'[ 'Method "SayHello" '[]
|
'[ 'Service "Greeter" '[]
|
||||||
'[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ]
|
'[ 'Method "SayHello" '[]
|
||||||
('RetSingle ('ViaSchema QuickstartSchema "HelloResponse"))
|
'[ 'ArgSingle ('SchemaRef QuickstartSchema "HelloRequest") ]
|
||||||
, 'Method "SayHi" '[]
|
('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||||
'[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")]
|
, 'Method "SayHi" '[]
|
||||||
('RetStream ('ViaSchema QuickstartSchema "HelloResponse"))
|
'[ 'ArgSingle ('SchemaRef QuickstartSchema "HiRequest")]
|
||||||
, 'Method "SayManyHellos" '[]
|
('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
|
||||||
'[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")]
|
, 'Method "SayManyHellos" '[]
|
||||||
('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ]
|
'[ 'ArgStream ('SchemaRef QuickstartSchema "HelloRequest")]
|
||||||
|
('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]
|
||||||
|
|
||||||
newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic)
|
newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic)
|
||||||
deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f)
|
deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f)
|
||||||
@ -69,21 +70,62 @@ deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequ
|
|||||||
|
|
||||||
quickstartServer :: forall m f.
|
quickstartServer :: forall m f.
|
||||||
(MonadServer m, Applicative f, MaybeLike f)
|
(MonadServer m, Applicative f, MaybeLike f)
|
||||||
=> ServerT f QuickStartService m _
|
=> ServerT f '[] QuickStartService m _
|
||||||
quickstartServer
|
quickstartServer
|
||||||
= Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
|
= Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
|
||||||
where sayHello :: HelloRequest f -> m (HelloResponse f)
|
where
|
||||||
sayHello (HelloRequest nm)
|
sayHello :: HelloRequest f -> m (HelloResponse f)
|
||||||
= return (HelloResponse (("hi, " <>) <$> nm))
|
sayHello (HelloRequest nm)
|
||||||
sayHi :: HiRequest f
|
= pure (HelloResponse (("hi, " <>) <$> nm))
|
||||||
-> ConduitT (HelloResponse f) Void m ()
|
sayHi :: HiRequest f
|
||||||
-> m ()
|
-> ConduitT (HelloResponse f) Void m ()
|
||||||
sayHi (HiRequest (likeMaybe -> Just n)) sink
|
-> m ()
|
||||||
= runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
|
sayHi (HiRequest (likeMaybe -> Just n)) sink
|
||||||
sayHi (HiRequest _) sink
|
= runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink
|
||||||
= runConduit $ return () .| sink
|
sayHi (HiRequest _) sink
|
||||||
sayManyHellos :: ConduitT () (HelloRequest f) m ()
|
= runConduit $ pure () .| sink
|
||||||
-> ConduitT (HelloResponse f) Void m ()
|
sayManyHellos :: ConduitT () (HelloRequest f) m ()
|
||||||
-> m ()
|
-> ConduitT (HelloResponse f) Void m ()
|
||||||
sayManyHellos source sink
|
-> m ()
|
||||||
= runConduit $ source .| C.mapM sayHello .| sink
|
sayManyHellos source sink
|
||||||
|
= runConduit $ source .| C.mapM sayHello .| sink
|
||||||
|
|
||||||
|
{-
|
||||||
|
From https://www.apollographql.com/docs/apollo-server/schema/schema/
|
||||||
|
|
||||||
|
type Book {
|
||||||
|
title: String
|
||||||
|
author: Author
|
||||||
|
}
|
||||||
|
|
||||||
|
type Author {
|
||||||
|
name: String
|
||||||
|
books: [Book]
|
||||||
|
}
|
||||||
|
-}
|
||||||
|
|
||||||
|
type ApolloService
|
||||||
|
= 'Package ('Just "apollo")
|
||||||
|
'[ Object "Book" '[]
|
||||||
|
'[ ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||||
|
, ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))
|
||||||
|
]
|
||||||
|
, Object "Author" '[]
|
||||||
|
'[ ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String))
|
||||||
|
, ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|
||||||
|
type ApolloBookAuthor = '[
|
||||||
|
"Book" ':-> (String, Integer)
|
||||||
|
, "Author" ':-> Integer
|
||||||
|
]
|
||||||
|
|
||||||
|
apolloServer :: forall m. (MonadServer m) => ServerT Maybe ApolloBookAuthor ApolloService m _
|
||||||
|
apolloServer
|
||||||
|
= Services $ (pure . fst :<||>: pure . snd :<||>: H0) :<&>: (authorName :<||>: authorBooks :<||>: H0) :<&>: S0
|
||||||
|
where
|
||||||
|
authorName :: Integer -> m String
|
||||||
|
authorName _ = pure "alex" -- this would run in the DB
|
||||||
|
authorBooks :: Integer -> m [(String, Integer)]
|
||||||
|
authorBooks _ = pure []
|
||||||
|
@ -5,11 +5,13 @@
|
|||||||
{-# language FlexibleInstances #-}
|
{-# language FlexibleInstances #-}
|
||||||
{-# language GADTs #-}
|
{-# language GADTs #-}
|
||||||
{-# language MultiParamTypeClasses #-}
|
{-# language MultiParamTypeClasses #-}
|
||||||
|
{-# language PatternSynonyms #-}
|
||||||
{-# language PolyKinds #-}
|
{-# language PolyKinds #-}
|
||||||
{-# language RankNTypes #-}
|
{-# language RankNTypes #-}
|
||||||
{-# language TypeFamilies #-}
|
{-# language TypeFamilies #-}
|
||||||
{-# language TypeOperators #-}
|
{-# language TypeOperators #-}
|
||||||
{-# language UndecidableInstances #-}
|
{-# language UndecidableInstances #-}
|
||||||
|
{-# language ViewPatterns #-}
|
||||||
{-|
|
{-|
|
||||||
Description : Protocol-independent declaration of servers.
|
Description : Protocol-independent declaration of servers.
|
||||||
|
|
||||||
@ -34,13 +36,18 @@ We recommend you to catch exceptions and return custom
|
|||||||
-}
|
-}
|
||||||
module Mu.Server (
|
module Mu.Server (
|
||||||
-- * Servers and handlers
|
-- * Servers and handlers
|
||||||
MonadServer, ServerT(..), HandlersT(..)
|
MonadServer
|
||||||
|
, SingleServerT
|
||||||
|
, ServerT(.., Server), ServicesT(..), HandlersT(.., (:<|>:))
|
||||||
|
, ServiceChain, noContext
|
||||||
-- ** Simple servers using only IO
|
-- ** Simple servers using only IO
|
||||||
, ServerErrorIO, ServerIO
|
, ServerErrorIO, ServerIO
|
||||||
-- * Errors which might be raised
|
-- * Errors which might be raised
|
||||||
, serverError, ServerError(..), ServerErrorCode(..)
|
, serverError, ServerError(..), ServerErrorCode(..)
|
||||||
-- ** Useful when you do not want to deal with errors
|
-- ** Useful when you do not want to deal with errors
|
||||||
, alwaysOk
|
, alwaysOk
|
||||||
|
-- * For internal use
|
||||||
|
, Handles, FromRef, ToRef
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
@ -54,8 +61,10 @@ import Mu.Schema
|
|||||||
type MonadServer m = (MonadError ServerError m, MonadIO m)
|
type MonadServer m = (MonadError ServerError m, MonadIO m)
|
||||||
-- | Simplest monad which satisfies 'MonadServer'.
|
-- | Simplest monad which satisfies 'MonadServer'.
|
||||||
type ServerErrorIO = ExceptT ServerError IO
|
type ServerErrorIO = ExceptT ServerError IO
|
||||||
-- | Simple 'ServerT' which uses only 'IO' and errors.
|
|
||||||
type ServerIO w srv = ServerT w srv ServerErrorIO
|
-- | Simple 'ServerT' which uses only 'IO' and errors,
|
||||||
|
-- and whose service has no back-references.
|
||||||
|
type ServerIO w srv = ServerT w '[] srv ServerErrorIO
|
||||||
|
|
||||||
-- | Stop the current handler,
|
-- | Stop the current handler,
|
||||||
-- returning an error to the client.
|
-- returning an error to the client.
|
||||||
@ -70,6 +79,11 @@ alwaysOk :: (MonadIO m)
|
|||||||
=> IO a -> m a
|
=> IO a -> m a
|
||||||
alwaysOk = liftIO
|
alwaysOk = liftIO
|
||||||
|
|
||||||
|
-- | To declare that the function doesn't use
|
||||||
|
-- its context.
|
||||||
|
noContext :: b -> a -> b
|
||||||
|
noContext = const
|
||||||
|
|
||||||
-- | Errors raised in a handler.
|
-- | Errors raised in a handler.
|
||||||
data ServerError
|
data ServerError
|
||||||
= ServerError ServerErrorCode String
|
= ServerError ServerErrorCode String
|
||||||
@ -87,11 +101,40 @@ data ServerErrorCode
|
|||||||
| NotFound
|
| NotFound
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | Definition of a complete server for a service.
|
-- | Defines a mapping between outcome of
|
||||||
data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where
|
-- a service, and its representation as
|
||||||
Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs
|
-- Haskell type.
|
||||||
|
type ServiceChain snm = Mappings snm Type
|
||||||
|
|
||||||
infixr 5 :<|>:
|
-- | A server for a single service,
|
||||||
|
-- like most RPC ones.
|
||||||
|
type SingleServerT w = ServerT w '[]
|
||||||
|
|
||||||
|
-- | Definition of a complete server
|
||||||
|
-- for a set of services, with possible
|
||||||
|
-- references between them.
|
||||||
|
data ServerT (w :: Type -> Type) -- wrapper for data types
|
||||||
|
(chn :: ServiceChain snm) (s :: Package snm mnm)
|
||||||
|
(m :: Type -> Type) (hs :: [[Type]]) where
|
||||||
|
Services :: ServicesT w chn s m hs
|
||||||
|
-> ServerT w chn ('Package pname s) m hs
|
||||||
|
|
||||||
|
pattern Server :: (MappingRight chn sname ~ ())
|
||||||
|
=> HandlersT w chn () methods m hs
|
||||||
|
-> ServerT w chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]
|
||||||
|
pattern Server svr = Services (svr :<&>: S0)
|
||||||
|
|
||||||
|
infixr 3 :<&>:
|
||||||
|
-- | Definition of a complete server for a service.
|
||||||
|
data ServicesT (w :: Type -> Type)
|
||||||
|
(chn :: ServiceChain snm) (s :: [Service snm mnm])
|
||||||
|
(m :: Type -> Type) (hs :: [[Type]]) where
|
||||||
|
S0 :: ServicesT w chn '[] m '[]
|
||||||
|
(:<&>:) :: HandlersT w chn (MappingRight chn sname) methods m hs
|
||||||
|
-> ServicesT w chn rest m hss
|
||||||
|
-> ServicesT w chn ('Service sname anns methods ': rest) m (hs ': hss)
|
||||||
|
|
||||||
|
infixr 4 :<||>:
|
||||||
-- | 'HandlersT' is a sequence of handlers.
|
-- | 'HandlersT' is a sequence of handlers.
|
||||||
-- Note that the handlers for your service
|
-- Note that the handlers for your service
|
||||||
-- must appear __in the same order__ as they
|
-- must appear __in the same order__ as they
|
||||||
@ -111,36 +154,59 @@ infixr 5 :<|>:
|
|||||||
-- * Output streams turn into an __additional argument__
|
-- * Output streams turn into an __additional argument__
|
||||||
-- of type @Conduit t Void m ()@. This stream should
|
-- of type @Conduit t Void m ()@. This stream should
|
||||||
-- be connected to a source to get the elements.
|
-- be connected to a source to get the elements.
|
||||||
data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where
|
data HandlersT (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||||
H0 :: HandlersT w '[] m '[]
|
(inh :: *) (methods :: [Method snm mnm])
|
||||||
(:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs
|
(m :: Type -> Type) (hs :: [Type]) where
|
||||||
-> HandlersT w ('Method name anns args ret ': ms) m (h ': hs)
|
H0 :: HandlersT w chn inh '[] m '[]
|
||||||
|
(:<||>:) :: Handles w chn args ret m h
|
||||||
|
=> (inh -> h) -> HandlersT w chn inh ms m hs
|
||||||
|
-> HandlersT w chn inh ('Method name anns args ret ': ms) m (h ': hs)
|
||||||
|
|
||||||
|
infixr 4 :<|>:
|
||||||
|
pattern (:<|>:) :: (Handles w chn args ret m h)
|
||||||
|
=> h -> HandlersT w chn () ms m hs
|
||||||
|
-> HandlersT w chn () ('Method name anns args ret ': ms) m (h ': hs)
|
||||||
|
pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where
|
||||||
|
x :<|>: xs = noContext x :<||>: xs
|
||||||
|
|
||||||
-- Define a relation for handling
|
-- Define a relation for handling
|
||||||
class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return)
|
class Handles (w :: Type -> Type)
|
||||||
|
(chn :: ServiceChain snm)
|
||||||
|
(args :: [Argument snm]) (ret :: Return snm)
|
||||||
(m :: Type -> Type) (h :: Type)
|
(m :: Type -> Type) (h :: Type)
|
||||||
class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)
|
class ToRef (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||||
class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type)
|
(ref :: TypeRef snm) (t :: Type)
|
||||||
|
class FromRef (w :: Type -> Type) (chn :: ServiceChain snm)
|
||||||
|
(ref :: TypeRef snm) (t :: Type)
|
||||||
|
|
||||||
-- Type references
|
-- Type references
|
||||||
instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t
|
instance t ~ s => ToRef w chn ('PrimitiveRef t) s
|
||||||
instance ToRef w ('ViaRegistry subject t last) t
|
instance ToSchema w sch sty t => ToRef w chn ('SchemaRef sch sty) t
|
||||||
instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t
|
instance MappingRight chn ref ~ t => ToRef w chn ('ObjectRef ref) t
|
||||||
instance FromRef w ('ViaRegistry subject t last) t
|
instance t ~ s => ToRef w chn ('RegistryRef subject t last) s
|
||||||
|
instance (ToRef w chn ref t, [t] ~ s) => ToRef w chn ('ListRef ref) s
|
||||||
|
instance (ToRef w chn ref t, Maybe t ~ s) => ToRef w chn ('OptionalRef ref) s
|
||||||
|
|
||||||
|
instance t ~ s => FromRef w chn ('PrimitiveRef t) s
|
||||||
|
instance FromSchema w sch sty t => FromRef w chn ('SchemaRef sch sty) t
|
||||||
|
instance MappingRight chn ref ~ t => FromRef w chn ('ObjectRef ref) t
|
||||||
|
instance t ~ s => FromRef w chn ('RegistryRef subject t last) s
|
||||||
|
instance (FromRef w chn ref t, [t] ~ s) => FromRef w chn ('ListRef ref) s
|
||||||
|
instance (FromRef w chn ref t, Maybe t ~ s) => FromRef w chn ('OptionalRef ref) s
|
||||||
|
|
||||||
-- Arguments
|
-- Arguments
|
||||||
instance (FromRef w ref t, Handles w args ret m h,
|
instance (FromRef w chn ref t, Handles w chn args ret m h,
|
||||||
handler ~ (t -> h))
|
handler ~ (t -> h))
|
||||||
=> Handles w ('ArgSingle ref ': args) ret m handler
|
=> Handles w chn ('ArgSingle ref ': args) ret m handler
|
||||||
instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h,
|
instance (MonadError ServerError m, FromRef w chn ref t, Handles w chn args ret m h,
|
||||||
handler ~ (ConduitT () t m () -> h))
|
handler ~ (ConduitT () t m () -> h))
|
||||||
=> Handles w ('ArgStream ref ': args) ret m handler
|
=> Handles w chn ('ArgStream ref ': args) ret m handler
|
||||||
-- Result with exception
|
-- Result with exception
|
||||||
instance (MonadError ServerError m, handler ~ m ())
|
instance (MonadError ServerError m, handler ~ m ())
|
||||||
=> Handles w '[] 'RetNothing m handler
|
=> Handles w chn '[] 'RetNothing m handler
|
||||||
instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v))
|
instance (MonadError ServerError m, ToRef w chn eref e, ToRef w chn vref v, handler ~ m (Either e v))
|
||||||
=> Handles w '[] ('RetThrows eref vref) m handler
|
=> Handles w chn '[] ('RetThrows eref vref) m handler
|
||||||
instance (MonadError ServerError m, ToRef w ref v, handler ~ m v)
|
instance (MonadError ServerError m, ToRef w chn ref v, handler ~ m v)
|
||||||
=> Handles w '[] ('RetSingle ref) m handler
|
=> Handles w chn '[] ('RetSingle ref) m handler
|
||||||
instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ()))
|
instance (MonadError ServerError m, ToRef w chn ref v, handler ~ (ConduitT v Void m () -> m ()))
|
||||||
=> Handles w '[] ('RetStream ref) m handler
|
=> Handles w chn '[] ('RetStream ref) m handler
|
||||||
|
@ -72,7 +72,7 @@ instance (KnownName name, ToJSON (FieldValue Identity sch t), ToJSONFields sch f
|
|||||||
class FromJSONFields w sch fields where
|
class FromJSONFields w sch fields where
|
||||||
parseJSONFields :: Object -> Parser (NP (Field w sch) fields)
|
parseJSONFields :: Object -> Parser (NP (Field w sch) fields)
|
||||||
instance FromJSONFields w sch '[] where
|
instance FromJSONFields w sch '[] where
|
||||||
parseJSONFields _ = return Nil
|
parseJSONFields _ = pure Nil
|
||||||
instance (Applicative w, KnownName name, FromJSON (FieldValue w sch t), FromJSONFields w sch fs)
|
instance (Applicative w, KnownName name, FromJSON (FieldValue w sch t), FromJSONFields w sch fs)
|
||||||
=> FromJSONFields w sch ('FieldDef name t ': fs) where
|
=> FromJSONFields w sch ('FieldDef name t ': fs) where
|
||||||
parseJSONFields v = (:*) <$> (Field <$> (pure <$> v .: key)) <*> parseJSONFields v
|
parseJSONFields v = (:*) <$> (Field <$> (pure <$> v .: key)) <*> parseJSONFields v
|
||||||
@ -100,7 +100,7 @@ instance FromJSONEnum '[] where
|
|||||||
instance (KnownName c, FromJSONEnum cs)
|
instance (KnownName c, FromJSONEnum cs)
|
||||||
=> FromJSONEnum ('ChoiceDef c ': cs) where
|
=> FromJSONEnum ('ChoiceDef c ': cs) where
|
||||||
parseJSONEnum v
|
parseJSONEnum v
|
||||||
| v == key = return (Z Proxy)
|
| v == key = pure (Z Proxy)
|
||||||
| otherwise = S <$> parseJSONEnum v
|
| otherwise = S <$> parseJSONEnum v
|
||||||
where key = T.pack (nameVal (Proxy @c))
|
where key = T.pack (nameVal (Proxy @c))
|
||||||
|
|
||||||
@ -142,7 +142,7 @@ instance (ToJSON (FieldValue w sch u), ToJSONUnion w sch us)
|
|||||||
unionToJSON (S r) = unionToJSON r
|
unionToJSON (S r) = unionToJSON r
|
||||||
|
|
||||||
instance FromJSON (FieldValue w sch 'TNull) where
|
instance FromJSON (FieldValue w sch 'TNull) where
|
||||||
parseJSON Null = return FNull
|
parseJSON Null = pure FNull
|
||||||
parseJSON _ = fail "expected null"
|
parseJSON _ = fail "expected null"
|
||||||
instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where
|
instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where
|
||||||
parseJSON v = FPrimitive <$> parseJSON v
|
parseJSON v = FPrimitive <$> parseJSON v
|
||||||
|
@ -59,7 +59,7 @@ typeDefToDecl _schemaTy namer (DRecord name [f])
|
|||||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||||
_wTy <- VarT <$> newName "w"
|
_wTy <- VarT <$> newName "w"
|
||||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f])
|
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f])
|
||||||
return [d] -- , hsi]
|
pure [d] -- , hsi]
|
||||||
-- Records with more than one field
|
-- Records with more than one field
|
||||||
typeDefToDecl _schemaTy namer (DRecord name fields)
|
typeDefToDecl _schemaTy namer (DRecord name fields)
|
||||||
= do let complete = completeName namer name
|
= do let complete = completeName namer name
|
||||||
@ -72,7 +72,7 @@ typeDefToDecl _schemaTy namer (DRecord name fields)
|
|||||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||||
_wTy <- VarT <$> newName "w"
|
_wTy <- VarT <$> newName "w"
|
||||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields)
|
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields)
|
||||||
return [d] -- , hsi]
|
pure [d] -- , hsi]
|
||||||
-- Enumerations
|
-- Enumerations
|
||||||
typeDefToDecl _schemaTy namer (DEnum name choices)
|
typeDefToDecl _schemaTy namer (DEnum name choices)
|
||||||
= do let complete = completeName namer name
|
= do let complete = completeName namer name
|
||||||
@ -86,7 +86,7 @@ typeDefToDecl _schemaTy namer (DEnum name choices)
|
|||||||
[pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])]
|
[pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])]
|
||||||
_wTy <- VarT <$> newName "w"
|
_wTy <- VarT <$> newName "w"
|
||||||
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices)
|
-- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices)
|
||||||
return [d] --, hsi]
|
pure [d] --, hsi]
|
||||||
-- Simple things
|
-- Simple things
|
||||||
typeDefToDecl _ _ (DSimple _)
|
typeDefToDecl _ _ (DSimple _)
|
||||||
= fail "DSimple is not supported"
|
= fail "DSimple is not supported"
|
||||||
|
@ -159,8 +159,11 @@ type Mappings a b = [Mapping a b]
|
|||||||
-- | Finds the corresponding right value of @v@
|
-- | Finds the corresponding right value of @v@
|
||||||
-- in a mapping @ms@. When the kinds are 'Symbol',
|
-- in a mapping @ms@. When the kinds are 'Symbol',
|
||||||
-- return the same value if not found.
|
-- return the same value if not found.
|
||||||
|
-- When the return type is 'Type', return ' ()'
|
||||||
|
-- if the value is not found.
|
||||||
type family MappingRight (ms :: Mappings a b) (v :: a) :: b where
|
type family MappingRight (ms :: Mappings a b) (v :: a) :: b where
|
||||||
MappingRight '[] (v :: Symbol) = v
|
MappingRight '[] (v :: Symbol) = (v :: Symbol)
|
||||||
|
MappingRight '[] (v :: Symbol) = (() :: Type)
|
||||||
MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
||||||
MappingRight ((x ':-> y) ': rest) x = y
|
MappingRight ((x ':-> y) ': rest) x = y
|
||||||
MappingRight (other ': rest) x = MappingRight rest x
|
MappingRight (other ': rest) x = MappingRight rest x
|
||||||
@ -168,8 +171,11 @@ type family MappingRight (ms :: Mappings a b) (v :: a) :: b where
|
|||||||
-- | Finds the corresponding left value of @v@
|
-- | Finds the corresponding left value of @v@
|
||||||
-- in a mapping @ms@. When the kinds are 'Symbol',
|
-- in a mapping @ms@. When the kinds are 'Symbol',
|
||||||
-- return the same value if not found.
|
-- return the same value if not found.
|
||||||
|
-- When the return type is 'Type', return ' ()'
|
||||||
|
-- if the value is not found.
|
||||||
type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where
|
type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where
|
||||||
MappingLeft '[] (v :: Symbol) = v
|
MappingLeft '[] (v :: Symbol) = (v :: Symbol)
|
||||||
|
MappingLeft '[] (v :: Symbol) = (() :: Type)
|
||||||
MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v)
|
||||||
MappingLeft ((x ':-> y) ': rest) y = x
|
MappingLeft ((x ':-> y) ': rest) y = x
|
||||||
MappingLeft (other ': rest) y = MappingLeft rest y
|
MappingLeft (other ': rest) y = MappingLeft rest y
|
||||||
|
@ -135,7 +135,7 @@ instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest)
|
|||||||
Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs
|
Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs
|
||||||
v' <- traverse checkSchemaValue v
|
v' <- traverse checkSchemaValue v
|
||||||
r' <- checkSchemaFields @_ @_ @s @rest fs
|
r' <- checkSchemaFields @_ @_ @s @rest fs
|
||||||
return (S.Field v' :* r')
|
pure (S.Field v' :* r')
|
||||||
|
|
||||||
instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where
|
instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where
|
||||||
checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n
|
checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n
|
||||||
|
@ -17,6 +17,7 @@ in {
|
|||||||
mu-example-seed-protobuf = hnPkgs.mu-example-seed-protobuf.components.all;
|
mu-example-seed-protobuf = hnPkgs.mu-example-seed-protobuf.components.all;
|
||||||
mu-example-todolist = hnPkgs.mu-example-todolist.components.all;
|
mu-example-todolist = hnPkgs.mu-example-todolist.components.all;
|
||||||
mu-example-with-persistent = hnPkgs.mu-example-with-persistent.components.all;
|
mu-example-with-persistent = hnPkgs.mu-example-with-persistent.components.all;
|
||||||
|
mu-graphql = hnPkgs.mu-graphql.components.library;
|
||||||
mu-grpc-client = hnPkgs.mu-grpc-client.components.library;
|
mu-grpc-client = hnPkgs.mu-grpc-client.components.library;
|
||||||
mu-grpc-common = hnPkgs.mu-grpc-common.components.library;
|
mu-grpc-common = hnPkgs.mu-grpc-common.components.library;
|
||||||
mu-grpc-server = hnPkgs.mu-grpc-server.components.all;
|
mu-grpc-server = hnPkgs.mu-grpc-server.components.all;
|
||||||
|
@ -26,7 +26,7 @@ data HealthCall = HealthCall
|
|||||||
} deriving (Generic)
|
} deriving (Generic)
|
||||||
|
|
||||||
buildHealthCall :: GrpcClient -> HealthCall
|
buildHealthCall :: GrpcClient -> HealthCall
|
||||||
buildHealthCall = buildService @'MsgAvro @HealthCheckService @""
|
buildHealthCall = buildService @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @""
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do -- Setup the client
|
main = do -- Setup the client
|
||||||
|
@ -31,22 +31,22 @@ simple client who = do
|
|||||||
let hcm = HealthCheckMsg (T.pack who)
|
let hcm = HealthCheckMsg (T.pack who)
|
||||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||||
rknown :: GRpcReply ServerStatusMsg
|
rknown :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||||
update client who "SERVING"
|
update client who "SERVING"
|
||||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"clearStatus" client hcm
|
r <- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"clearStatus" client hcm
|
||||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||||
runknown :: GRpcReply ServerStatusMsg
|
runknown :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||||
|
|
||||||
update :: GrpcClient -> String -> String -> IO ()
|
update :: GrpcClient -> String -> String -> IO ()
|
||||||
update client who newstatus = do
|
update client who newstatus = do
|
||||||
let hcm = HealthCheckMsg (T.pack who)
|
let hcm = HealthCheckMsg (T.pack who)
|
||||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||||
r <- gRpcCall @'MsgAvro @HealthCheckService @"setStatus" client
|
r <- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"setStatus" client
|
||||||
(HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
(HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||||
rstatus :: GRpcReply ServerStatusMsg
|
rstatus :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgAvro @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgAvro @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||||
|
@ -53,7 +53,7 @@ checkH_ m (HealthCheckMsg nm) = alwaysOk $ do
|
|||||||
putStr "check: " >> print nm
|
putStr "check: " >> print nm
|
||||||
ss <- atomically $ M.lookup nm m
|
ss <- atomically $ M.lookup nm m
|
||||||
print ss
|
print ss
|
||||||
return $ ServerStatusMsg (fromMaybe "<unknown>" ss)
|
pure $ ServerStatusMsg (fromMaybe "<unknown>" ss)
|
||||||
|
|
||||||
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
||||||
clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do
|
clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do
|
||||||
|
@ -28,7 +28,7 @@ data HealthCall = HealthCall
|
|||||||
} deriving (Generic)
|
} deriving (Generic)
|
||||||
|
|
||||||
buildHealthCall :: GrpcClient -> HealthCall
|
buildHealthCall :: GrpcClient -> HealthCall
|
||||||
buildHealthCall = buildService @'MsgProtoBuf @HealthCheckService @""
|
buildHealthCall = buildService @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @""
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do -- Setup the client
|
main = do -- Setup the client
|
||||||
|
@ -34,28 +34,28 @@ simple client who = do
|
|||||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||||
rknown :: GRpcReply ServerStatusMsg
|
rknown :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||||
update client who "SERVING"
|
update client who "SERVING"
|
||||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"clearStatus" client hcm
|
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"clearStatus" client hcm
|
||||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||||
runknown :: GRpcReply ServerStatusMsg
|
runknown :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||||
|
|
||||||
update :: GrpcClient -> String -> String -> IO ()
|
update :: GrpcClient -> String -> String -> IO ()
|
||||||
update client who newstatus = do
|
update client who newstatus = do
|
||||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||||
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"setStatus" client
|
r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"setStatus" client
|
||||||
(HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (Just $ T.pack newstatus)))
|
(HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (Just $ T.pack newstatus)))
|
||||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||||
rstatus :: GRpcReply ServerStatusMsg
|
rstatus :: GRpcReply ServerStatusMsg
|
||||||
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"check" client hcm
|
<- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm
|
||||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||||
|
|
||||||
watching :: GrpcClient -> String -> IO ()
|
watching :: GrpcClient -> String -> IO ()
|
||||||
watching client who = do
|
watching client who = do
|
||||||
let hcm = HealthCheckMsg $ Just (T.pack who)
|
let hcm = HealthCheckMsg $ Just (T.pack who)
|
||||||
replies <- gRpcCall @'MsgProtoBuf @HealthCheckService @"watch" client hcm
|
replies <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"watch" client hcm
|
||||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ())
|
runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ())
|
||||||
|
@ -48,14 +48,14 @@ checkH_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ServerStatusMsg
|
|||||||
checkH_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
checkH_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
||||||
putStr "check: " >> print nm
|
putStr "check: " >> print nm
|
||||||
ss <- atomically $ M.lookup nm m
|
ss <- atomically $ M.lookup nm m
|
||||||
return $ ServerStatusMsg ss
|
pure $ ServerStatusMsg ss
|
||||||
checkH_ _ _ = serverError (ServerError Invalid "no server name given")
|
checkH_ _ _ = serverError (ServerError Invalid "no server name given")
|
||||||
|
|
||||||
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ()
|
||||||
clearStatus_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
clearStatus_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do
|
||||||
putStr "clearStatus: " >> print nm
|
putStr "clearStatus: " >> print nm
|
||||||
atomically $ M.delete nm m
|
atomically $ M.delete nm m
|
||||||
clearStatus_ _ _ = return ()
|
clearStatus_ _ _ = pure ()
|
||||||
|
|
||||||
checkAll_ :: StatusMap -> ServerErrorIO AllStatusMsg
|
checkAll_ :: StatusMap -> ServerErrorIO AllStatusMsg
|
||||||
checkAll_ m = alwaysOk $ do
|
checkAll_ m = alwaysOk $ do
|
||||||
@ -87,4 +87,4 @@ watch_ upd hcm@(HealthCheckMsg nm) sink = do
|
|||||||
case x of
|
case x of
|
||||||
Just (Just y) -> yield y >> catMaybesC
|
Just (Just y) -> yield y >> catMaybesC
|
||||||
Just Nothing -> catMaybesC
|
Just Nothing -> catMaybesC
|
||||||
Nothing -> return ()
|
Nothing -> pure ()
|
||||||
|
@ -73,7 +73,7 @@ server f m = Server
|
|||||||
(getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0)
|
(getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0)
|
||||||
|
|
||||||
getFeature :: Features -> Point -> ServerErrorIO Feature
|
getFeature :: Features -> Point -> ServerErrorIO Feature
|
||||||
getFeature fs p = return $ fromMaybe nilFeature (findFeatureIn fs p)
|
getFeature fs p = pure $ fromMaybe nilFeature (findFeatureIn fs p)
|
||||||
where nilFeature = Feature (Just "") (Just (Point (Just 0) (Just 0)))
|
where nilFeature = Feature (Just "") (Just (Point (Just 0) (Just 0)))
|
||||||
|
|
||||||
listFeatures :: Features -> Rectangle
|
listFeatures :: Features -> Rectangle
|
||||||
@ -103,7 +103,7 @@ recordRoute fs ps = do
|
|||||||
((update_feature_count +) <$> feature_count summary)
|
((update_feature_count +) <$> feature_count summary)
|
||||||
((+) <$> distance summary <*> new_distance)
|
((+) <$> distance summary <*> new_distance)
|
||||||
(Just $ floor new_elapsed)
|
(Just $ floor new_elapsed)
|
||||||
return (new_summary, Just point, startTime)
|
pure (new_summary, Just point, startTime)
|
||||||
|
|
||||||
routeChat :: TBMChan RouteNote
|
routeChat :: TBMChan RouteNote
|
||||||
-> ConduitT () RouteNote ServerErrorIO ()
|
-> ConduitT () RouteNote ServerErrorIO ()
|
||||||
@ -117,7 +117,7 @@ routeChat notesMap inS outS = do
|
|||||||
readStmMap (\l1 (RouteNote _ l2)-> Just l1 == l2) toWatch notesMap .| outS
|
readStmMap (\l1 (RouteNote _ l2)-> Just l1 == l2) toWatch notesMap .| outS
|
||||||
res <- liftIO $ concurrently inA outA
|
res <- liftIO $ concurrently inA outA
|
||||||
case res of
|
case res of
|
||||||
(Right _, Right _) -> return ()
|
(Right _, Right _) -> pure ()
|
||||||
(Left e, _) -> serverError e
|
(Left e, _) -> serverError e
|
||||||
(_, Left e) -> serverError e
|
(_, Left e) -> serverError e
|
||||||
where
|
where
|
||||||
@ -126,7 +126,7 @@ routeChat notesMap inS outS = do
|
|||||||
_ <- tryTakeTMVar toWatch
|
_ <- tryTakeTMVar toWatch
|
||||||
putTMVar toWatch loc
|
putTMVar toWatch loc
|
||||||
writeTBMChan notesMap newNote
|
writeTBMChan notesMap newNote
|
||||||
addNoteToMap _toWatch _ = return ()
|
addNoteToMap _toWatch _ = pure ()
|
||||||
|
|
||||||
readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m ()
|
readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m ()
|
||||||
readStmMap p toWatch m = go
|
readStmMap p toWatch m = go
|
||||||
@ -134,6 +134,6 @@ readStmMap p toWatch m = go
|
|||||||
go = do
|
go = do
|
||||||
v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch
|
v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch
|
||||||
case v of
|
case v of
|
||||||
(Nothing, _) -> return ()
|
(Nothing, _) -> pure ()
|
||||||
(Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go
|
(Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go
|
||||||
_ -> go
|
_ -> go
|
||||||
|
@ -31,7 +31,7 @@ main = do
|
|||||||
-- Server implementation
|
-- Server implementation
|
||||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||||
|
|
||||||
server :: (MonadServer m, MonadLogger m) => ServerT Identity PeopleService m _
|
server :: (MonadServer m, MonadLogger m) => SingleServerT Identity PeopleService m _
|
||||||
server = Server (getPerson :<|>: H0)
|
server = Server (getPerson :<|>: H0)
|
||||||
|
|
||||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||||
|
@ -50,7 +50,7 @@ main = do
|
|||||||
-- Server implementation
|
-- Server implementation
|
||||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||||
|
|
||||||
server :: (MonadServer m, MonadLogger m) => ServerT Maybe PeopleService m _
|
server :: (MonadServer m, MonadLogger m) => SingleServerT Maybe PeopleService m _
|
||||||
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
||||||
|
|
||||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||||
|
@ -34,7 +34,7 @@ main = do
|
|||||||
-- Server implementation
|
-- Server implementation
|
||||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala
|
||||||
|
|
||||||
server :: (MonadServer m, MonadLogger m) => ServerT Maybe PeopleService m _
|
server :: (MonadServer m, MonadLogger m) => SingleServerT Maybe PeopleService m _
|
||||||
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
server = Server (getPerson :<|>: getPersonStream :<|>: H0)
|
||||||
|
|
||||||
evolvePerson :: PeopleRequest -> PeopleResponse
|
evolvePerson :: PeopleRequest -> PeopleResponse
|
||||||
|
@ -41,7 +41,7 @@ reset i t = alwaysOk $ do
|
|||||||
atomically $ do
|
atomically $ do
|
||||||
writeTVar i 0
|
writeTVar i 0
|
||||||
writeTVar t []
|
writeTVar t []
|
||||||
pure $ MessageId Nothing -- returns nothing
|
pure $ MessageId Nothing
|
||||||
|
|
||||||
insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse
|
insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse
|
||||||
insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do
|
insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do
|
||||||
@ -89,5 +89,5 @@ destroy t (MessageId (Just idMsg)) = do
|
|||||||
modifyTVar t $ filter (/=todo)
|
modifyTVar t $ filter (/=todo)
|
||||||
pure $ Just (MessageId (Just idMsg)) -- OK ✅
|
pure $ Just (MessageId (Just idMsg)) -- OK ✅
|
||||||
Nothing -> pure Nothing -- did nothing
|
Nothing -> pure Nothing -- did nothing
|
||||||
maybe (serverError $ ServerError NotFound "unknown message id") return r
|
maybe (serverError $ ServerError NotFound "unknown message id") pure r
|
||||||
destroy _ _ = serverError $ ServerError Invalid "missing message id"
|
destroy _ _ = serverError $ ServerError Invalid "missing message id"
|
||||||
|
@ -30,7 +30,7 @@ get client idPerson = do
|
|||||||
let req = MPersonRequest $ readMaybe idPerson
|
let req = MPersonRequest $ readMaybe idPerson
|
||||||
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
||||||
response :: GRpcReply MPerson
|
response :: GRpcReply MPerson
|
||||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"getPerson" client req
|
<- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"getPerson" client req
|
||||||
putStrLn $ "GET: response was: " ++ show response
|
putStrLn $ "GET: response was: " ++ show response
|
||||||
|
|
||||||
add :: GrpcClient -> String -> String -> IO ()
|
add :: GrpcClient -> String -> String -> IO ()
|
||||||
@ -38,10 +38,10 @@ add client nm ag = do
|
|||||||
let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag)
|
let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag)
|
||||||
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
||||||
response :: GRpcReply MPersonRequest
|
response :: GRpcReply MPersonRequest
|
||||||
<- gRpcCall @'MsgProtoBuf @PersistentService @"newPerson" client p
|
<- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"newPerson" client p
|
||||||
putStrLn $ "ADD: was creating successful? " ++ show response
|
putStrLn $ "ADD: was creating successful? " ++ show response
|
||||||
|
|
||||||
watching :: GrpcClient -> IO ()
|
watching :: GrpcClient -> IO ()
|
||||||
watching client = do
|
watching client = do
|
||||||
replies <- gRpcCall @'MsgProtoBuf @PersistentService @"allPeople" client
|
replies <- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"allPeople" client
|
||||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ())
|
runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ())
|
||||||
|
@ -1,11 +1,13 @@
|
|||||||
{-# language DataKinds #-}
|
{-# language DataKinds #-}
|
||||||
{-# language OverloadedLabels #-}
|
{-# language OverloadedLabels #-}
|
||||||
|
{-# language TypeApplications #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import qualified Data.Conduit.Combinators as C
|
import qualified Data.Conduit.Combinators as C
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import GHC.OverloadedLabels
|
||||||
import Mu.GRpc.Client.Optics
|
import Mu.GRpc.Client.Optics
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
@ -26,17 +28,17 @@ get :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> IO ()
|
|||||||
get client idPerson = do
|
get client idPerson = do
|
||||||
let req = readMaybe idPerson
|
let req = readMaybe idPerson
|
||||||
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?"
|
||||||
response <- (client ^. #getPerson) (record1 req)
|
response <- (client ^. (fromLabel @"PersistentService") % #getPerson) (record1 req)
|
||||||
putStrLn $ "GET: response was: " ++ show response
|
putStrLn $ "GET: response was: " ++ show response
|
||||||
|
|
||||||
add :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> String -> IO ()
|
add :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> String -> IO ()
|
||||||
add client nm ag = do
|
add client nm ag = do
|
||||||
let p = record (Nothing, Just (T.pack nm), readMaybe ag)
|
let p = record (Nothing, Just (T.pack nm), readMaybe ag)
|
||||||
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag
|
||||||
response <- (client ^. #newPerson) p
|
response <- (client ^. (fromLabel @"PersistentService") % #newPerson) p
|
||||||
putStrLn $ "ADD: was creating successful? " ++ show response
|
putStrLn $ "ADD: was creating successful? " ++ show response
|
||||||
|
|
||||||
watching :: GRpcConnection PersistentService 'MsgProtoBuf -> IO ()
|
watching :: GRpcConnection PersistentService 'MsgProtoBuf -> IO ()
|
||||||
watching client = do
|
watching client = do
|
||||||
replies <- client ^. #allPeople
|
replies <- client ^. (fromLabel @"PersistentService") % #allPeople
|
||||||
runConduit $ replies .| C.mapM_ print
|
runConduit $ replies .| C.mapM_ print
|
||||||
|
@ -25,7 +25,7 @@ main :: IO ()
|
|||||||
main = do
|
main = do
|
||||||
let config = grpcClientConfigSimple "127.0.0.1" 1234 False
|
let config = grpcClientConfigSimple "127.0.0.1" 1234 False
|
||||||
Right grpcClient <- setupGrpcClient' config
|
Right grpcClient <- setupGrpcClient' config
|
||||||
let client = buildService @'MsgProtoBuf @PersistentService @"" grpcClient
|
let client = buildService @'MsgProtoBuf @PersistentService @"PersistentService" @"" grpcClient
|
||||||
args <- getArgs
|
args <- getArgs
|
||||||
case args of
|
case args of
|
||||||
["watch"] -> watching client
|
["watch"] -> watching client
|
||||||
|
@ -25,7 +25,7 @@ main = do
|
|||||||
runDb conn $ runMigration migrateAll
|
runDb conn $ runMigration migrateAll
|
||||||
liftIO $ runGRpcApp msgProtoBuf 1234 (server conn)
|
liftIO $ runGRpcApp msgProtoBuf 1234 (server conn)
|
||||||
|
|
||||||
server :: SqlBackend -> ServerT Maybe PersistentService ServerErrorIO _
|
server :: SqlBackend -> SingleServerT Maybe PersistentService ServerErrorIO _
|
||||||
server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0)
|
server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0)
|
||||||
|
|
||||||
getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person)
|
getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person)
|
||||||
|
@ -17,7 +17,7 @@ stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \
|
|||||||
--hyperlink-source \
|
--hyperlink-source \
|
||||||
core/schema core/rpc core/optics \
|
core/schema core/rpc core/optics \
|
||||||
adapter/avro adapter/protobuf adapter/persistent adapter/kafka \
|
adapter/avro adapter/protobuf adapter/persistent adapter/kafka \
|
||||||
grpc/common grpc/client grpc/server
|
grpc/common grpc/client grpc/server graphql
|
||||||
|
|
||||||
echo "Setting Linuwial theme on Haddock generated docs"
|
echo "Setting Linuwial theme on Haddock generated docs"
|
||||||
find ${DOCSDIR} -name "ocean.css" -exec cp -rf docs/css/linuwial.css {} \;
|
find ${DOCSDIR} -name "ocean.css" -exec cp -rf docs/css/linuwial.css {} \;
|
||||||
|
202
graphql/LICENSE
Normal file
202
graphql/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.
|
2
graphql/Setup.hs
Normal file
2
graphql/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
|||||||
|
import Distribution.Simple
|
||||||
|
main = defaultMain
|
1
graphql/hie.yaml
Normal file
1
graphql/hie.yaml
Normal file
@ -0,0 +1 @@
|
|||||||
|
cradle: { stack: { component: "mu-graphql:lib" } }
|
39
graphql/mu-graphql.cabal
Normal file
39
graphql/mu-graphql.cabal
Normal file
@ -0,0 +1,39 @@
|
|||||||
|
name: mu-graphql
|
||||||
|
version: 0.1.0.0
|
||||||
|
synopsis: GraphQL support for Mu
|
||||||
|
cabal-version: >=1.10
|
||||||
|
|
||||||
|
-- description:
|
||||||
|
-- bug-reports:
|
||||||
|
license: Apache-2.0
|
||||||
|
license-file: LICENSE
|
||||||
|
author: Alejandro Serrano, Flavio Corpa
|
||||||
|
maintainer: alejandro.serrano@47deg.com
|
||||||
|
|
||||||
|
-- copyright:
|
||||||
|
category: Network
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
-- extra-source-files: CHANGELOG.md
|
||||||
|
|
||||||
|
library
|
||||||
|
exposed-modules:
|
||||||
|
Mu.GraphQL.Query.Definition
|
||||||
|
Mu.GraphQL.Query.Parse
|
||||||
|
Mu.GraphQL.Query.Run
|
||||||
|
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends:
|
||||||
|
aeson
|
||||||
|
, base >=4.12 && <5
|
||||||
|
, graphql-parser
|
||||||
|
, mtl
|
||||||
|
, mu-rpc
|
||||||
|
, mu-schema
|
||||||
|
, sop-core
|
||||||
|
, text
|
||||||
|
, unordered-containers
|
||||||
|
|
||||||
|
hs-source-dirs: src
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -fprint-potential-instances
|
56
graphql/src/Mu/GraphQL/Query/Definition.hs
Normal file
56
graphql/src/Mu/GraphQL/Query/Definition.hs
Normal file
@ -0,0 +1,56 @@
|
|||||||
|
{-# language DataKinds #-}
|
||||||
|
{-# language GADTs #-}
|
||||||
|
{-# language PolyKinds #-}
|
||||||
|
{-# language ScopedTypeVariables #-}
|
||||||
|
{-# language TypeOperators #-}
|
||||||
|
module Mu.GraphQL.Query.Definition where
|
||||||
|
|
||||||
|
import Data.Functor.Identity
|
||||||
|
import Data.SOP.NP
|
||||||
|
import Data.SOP.NS
|
||||||
|
import Data.Text
|
||||||
|
import Mu.Rpc
|
||||||
|
import Mu.Schema
|
||||||
|
|
||||||
|
data Document (p :: Package snm mnm) (qr :: snm) (mut :: snm) where
|
||||||
|
QueryDoc :: LookupService ss qr ~ 'Service qr qanns qms
|
||||||
|
=> ServiceQuery ('Package pname ss) (LookupService ss qr)
|
||||||
|
-> Document ('Package pname ss) qr mut
|
||||||
|
MutationDoc :: LookupService ss mut ~ 'Service mut manns mms
|
||||||
|
=> ServiceQuery ('Package pname ss) (LookupService ss mut)
|
||||||
|
-> Document ('Package pname ss) qr mut
|
||||||
|
|
||||||
|
type ServiceQuery (p :: Package snm mnm) (s :: Service snm mnm)
|
||||||
|
= [OneMethodQuery p s]
|
||||||
|
|
||||||
|
data OneMethodQuery (p :: Package snm mnm) (s :: Service snm mnm) where
|
||||||
|
OneMethodQuery
|
||||||
|
:: Maybe Text
|
||||||
|
-> NS (ChosenMethodQuery p) ms
|
||||||
|
-> OneMethodQuery p ('Service nm anns ms)
|
||||||
|
|
||||||
|
data ChosenMethodQuery (p :: Package snm mnm) (m :: Method snm mnm) where
|
||||||
|
ChosenMethodQuery
|
||||||
|
:: NP (ArgumentValue p) args
|
||||||
|
-> ReturnQuery p r
|
||||||
|
-> ChosenMethodQuery p ('Method mname anns args ('RetSingle r))
|
||||||
|
|
||||||
|
data ArgumentValue (p :: Package snm mnm) (a :: Argument snm) where
|
||||||
|
ArgumentValue :: ArgumentValue' p r -> ArgumentValue p ('ArgSingle r)
|
||||||
|
|
||||||
|
data ArgumentValue' (p :: Package snm mnm) (r :: TypeRef snm) where
|
||||||
|
ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t)
|
||||||
|
ArgSchema :: Term Identity sch (sch :/: sty)
|
||||||
|
-> ArgumentValue' p ('SchemaRef sch sty)
|
||||||
|
ArgList :: [ArgumentValue' p r]
|
||||||
|
-> ArgumentValue' p ('ListRef r)
|
||||||
|
ArgOptional :: Maybe (ArgumentValue' p r)
|
||||||
|
-> ArgumentValue' p ('OptionalRef r)
|
||||||
|
|
||||||
|
data ReturnQuery (p :: Package snm mnm) (r :: TypeRef snm) where
|
||||||
|
RetPrimitive :: ReturnQuery p ('PrimitiveRef t)
|
||||||
|
RetSchema :: ReturnQuery p ('SchemaRef sch sty)
|
||||||
|
RetList :: ReturnQuery p r -> ReturnQuery p ('ListRef r)
|
||||||
|
RetOptional :: ReturnQuery p r -> ReturnQuery p ('OptionalRef r)
|
||||||
|
RetObject :: ServiceQuery ('Package pname ss) (LookupService ss s)
|
||||||
|
-> ReturnQuery ('Package pname ss) ('ObjectRef s)
|
240
graphql/src/Mu/GraphQL/Query/Parse.hs
Normal file
240
graphql/src/Mu/GraphQL/Query/Parse.hs
Normal file
@ -0,0 +1,240 @@
|
|||||||
|
{-# language DataKinds #-}
|
||||||
|
{-# language FlexibleContexts #-}
|
||||||
|
{-# language FlexibleInstances #-}
|
||||||
|
{-# language GADTs #-}
|
||||||
|
{-# language MultiParamTypeClasses #-}
|
||||||
|
{-# language PolyKinds #-}
|
||||||
|
{-# language ScopedTypeVariables #-}
|
||||||
|
{-# language TypeApplications #-}
|
||||||
|
{-# language TypeOperators #-}
|
||||||
|
{-# language UndecidableInstances #-}
|
||||||
|
{-# language ViewPatterns #-}
|
||||||
|
|
||||||
|
module Mu.GraphQL.Query.Parse where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Functor.Identity
|
||||||
|
import Data.Int (Int32)
|
||||||
|
import Data.List (find)
|
||||||
|
import Data.Proxy
|
||||||
|
import Data.SOP.NS
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import GHC.TypeLits
|
||||||
|
import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||||
|
|
||||||
|
import Mu.GraphQL.Query.Definition
|
||||||
|
import Mu.Rpc
|
||||||
|
import Mu.Schema
|
||||||
|
|
||||||
|
parseDoc ::
|
||||||
|
( Alternative f, p ~ 'Package pname ss,
|
||||||
|
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||||
|
ParseMethod p qmethods,
|
||||||
|
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||||
|
ParseMethod p mmethods
|
||||||
|
) =>
|
||||||
|
GQL.ExecutableDocument ->
|
||||||
|
f (Document p qr mut)
|
||||||
|
parseDoc (GQL.ExecutableDocument defns)
|
||||||
|
= case GQL.partitionExDefs defns of
|
||||||
|
([unnamed], [], _) -> QueryDoc <$> parseQuery Proxy Proxy unnamed
|
||||||
|
([], [named], _) -> parseTypedDoc named
|
||||||
|
_ -> empty
|
||||||
|
|
||||||
|
parseTypedDoc ::
|
||||||
|
( Alternative f, p ~ 'Package pname ss,
|
||||||
|
LookupService ss qr ~ 'Service qr qanns qmethods,
|
||||||
|
ParseMethod p qmethods,
|
||||||
|
LookupService ss mut ~ 'Service mut manns mmethods,
|
||||||
|
ParseMethod p mmethods
|
||||||
|
) =>
|
||||||
|
GQL.TypedOperationDefinition ->
|
||||||
|
f (Document p qr mut)
|
||||||
|
parseTypedDoc tod@GQL.TypedOperationDefinition { GQL._todType = GQL.OperationTypeQuery }
|
||||||
|
= QueryDoc <$> parseQuery Proxy Proxy (GQL._todSelectionSet tod)
|
||||||
|
parseTypedDoc tod@GQL.TypedOperationDefinition { GQL._todType = GQL.OperationTypeMutation }
|
||||||
|
= MutationDoc <$> parseQuery Proxy Proxy (GQL._todSelectionSet tod)
|
||||||
|
parseTypedDoc _ = empty
|
||||||
|
|
||||||
|
-- TODO: turn Hasura's `ExecutableDefinition` into a service query
|
||||||
|
-- Hint: start with the following function, and then move up
|
||||||
|
-- (OperationDefinition -> ExecutableDefinition -> ExecutableDocument)
|
||||||
|
parseQuery ::
|
||||||
|
forall (p :: Package') (s :: Symbol) pname ss sanns methods f.
|
||||||
|
( Alternative f, p ~ 'Package pname ss,
|
||||||
|
LookupService ss s ~ 'Service s sanns methods,
|
||||||
|
ParseMethod p methods
|
||||||
|
) =>
|
||||||
|
Proxy p ->
|
||||||
|
Proxy s ->
|
||||||
|
GQL.SelectionSet ->
|
||||||
|
f (ServiceQuery p (LookupService ss s))
|
||||||
|
parseQuery _ _ = traverse toOneMethod
|
||||||
|
where
|
||||||
|
toOneMethod :: GQL.Selection -> f (OneMethodQuery p ('Service sname sanns methods))
|
||||||
|
toOneMethod (GQL.SelectionField fld) = fieldToMethod fld
|
||||||
|
toOneMethod (GQL.SelectionFragmentSpread _) = empty -- FIXME:
|
||||||
|
toOneMethod (GQL.SelectionInlineFragment _) = empty -- FIXME:
|
||||||
|
fieldToMethod :: GQL.Field -> f (OneMethodQuery p ('Service sname sanns methods))
|
||||||
|
fieldToMethod (GQL.Field alias name args _ sels) =
|
||||||
|
OneMethodQuery (GQL.unName . GQL.unAlias <$> alias) <$> selectMethod name args sels
|
||||||
|
|
||||||
|
class ParseMethod (p :: Package') (ms :: [Method Symbol Symbol]) where
|
||||||
|
selectMethod ::
|
||||||
|
Alternative f =>
|
||||||
|
GQL.Name ->
|
||||||
|
[GQL.Argument] ->
|
||||||
|
GQL.SelectionSet ->
|
||||||
|
f (NS (ChosenMethodQuery p) ms)
|
||||||
|
|
||||||
|
instance ParseMethod p '[] where
|
||||||
|
selectMethod _ _ _ = empty
|
||||||
|
instance
|
||||||
|
(KnownSymbol mname, ParseMethod p ms, ParseArgs p args, ParseReturn p r) =>
|
||||||
|
ParseMethod p ('Method mname manns args ('RetSingle r) ': ms)
|
||||||
|
where
|
||||||
|
selectMethod w@(GQL.unName -> wanted) args sels
|
||||||
|
| wanted == mname = Z <$> (ChosenMethodQuery <$> parseArgs args <*> parseReturn sels)
|
||||||
|
| otherwise = S <$> selectMethod w args sels
|
||||||
|
where
|
||||||
|
mname = T.pack $ nameVal (Proxy @mname)
|
||||||
|
|
||||||
|
class ParseArgs (p :: Package') (args :: [Argument Symbol]) where
|
||||||
|
parseArgs :: Alternative f => [GQL.Argument] -> f (NP (ArgumentValue p) args)
|
||||||
|
|
||||||
|
instance ParseArgs p '[] where
|
||||||
|
parseArgs _ = pure Nil
|
||||||
|
instance (ParseArg p a, ParseArgs p as) => ParseArgs p ('ArgSingle a ': as) where
|
||||||
|
parseArgs (GQL.Argument _ x : xs) = (:*) <$> (ArgumentValue <$> parseArg x) <*> parseArgs xs
|
||||||
|
parseArgs _ = empty
|
||||||
|
|
||||||
|
class ParseArg (p :: Package') (a :: TypeRef Symbol) where
|
||||||
|
parseArg :: Alternative f => GQL.Value -> f (ArgumentValue' p a)
|
||||||
|
|
||||||
|
instance (ParseArg p r) => ParseArg p ('ListRef r) where
|
||||||
|
parseArg (GQL.VList (GQL.ListValueG xs)) = ArgList <$> traverse parseArg xs
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef Bool) where
|
||||||
|
parseArg (GQL.VBoolean b) = pure (ArgPrimitive b)
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef Int32) where
|
||||||
|
parseArg (GQL.VInt b) = pure (ArgPrimitive b)
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef Integer) where
|
||||||
|
parseArg (GQL.VInt b) = pure $ ArgPrimitive $ fromIntegral b
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef Double) where
|
||||||
|
parseArg (GQL.VFloat b) = pure (ArgPrimitive b)
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef T.Text) where
|
||||||
|
parseArg (GQL.VString (GQL.StringValue b)) = pure $ ArgPrimitive b
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef String) where
|
||||||
|
parseArg (GQL.VString (GQL.StringValue b)) = pure $ ArgPrimitive $ T.unpack b
|
||||||
|
parseArg _ = empty
|
||||||
|
instance ParseArg p ('PrimitiveRef ()) where
|
||||||
|
parseArg GQL.VNull = pure $ ArgPrimitive ()
|
||||||
|
parseArg _ = empty
|
||||||
|
instance (ObjectOrEnumParser sch (sch :/: sty))
|
||||||
|
=> ParseArg p ('SchemaRef sch sty) where
|
||||||
|
parseArg v = ArgSchema <$> parseObjectOrEnum v
|
||||||
|
|
||||||
|
class ObjectOrEnumParser sch (t :: TypeDef Symbol Symbol) where
|
||||||
|
parseObjectOrEnum :: Alternative f
|
||||||
|
=> GQL.Value
|
||||||
|
-> f (Term Identity sch t)
|
||||||
|
|
||||||
|
instance (ObjectParser sch args)
|
||||||
|
=> ObjectOrEnumParser sch ('DRecord name args) where
|
||||||
|
parseObjectOrEnum (GQL.VObject (GQL.ObjectValueG vs)) = TRecord <$> objectParser vs
|
||||||
|
parseObjectOrEnum _ = empty
|
||||||
|
instance (EnumParser choices)
|
||||||
|
=> ObjectOrEnumParser sch ('DEnum name choices) where
|
||||||
|
parseObjectOrEnum (GQL.VEnum (GQL.EnumValue nm)) = TEnum <$> enumParser nm
|
||||||
|
parseObjectOrEnum _ = empty
|
||||||
|
|
||||||
|
class ObjectParser sch args where
|
||||||
|
objectParser :: Alternative f
|
||||||
|
=> [GQL.ObjectFieldG GQL.Value]
|
||||||
|
-> f (NP (Field Identity sch) args)
|
||||||
|
|
||||||
|
instance ObjectParser sch '[] where
|
||||||
|
objectParser _ = pure Nil
|
||||||
|
instance
|
||||||
|
(ObjectParser sch args, ValueParser sch v, KnownName nm) =>
|
||||||
|
ObjectParser sch ('FieldDef nm v ': args)
|
||||||
|
where
|
||||||
|
objectParser args
|
||||||
|
= case find ((== nameVal (Proxy @nm)) . T.unpack . GQL.unName . GQL._ofName) args of
|
||||||
|
Just (GQL.ObjectFieldG _ v)
|
||||||
|
-> (:*) <$> (Field . Identity <$> valueParser v) <*> objectParser args
|
||||||
|
Nothing -> empty
|
||||||
|
|
||||||
|
class EnumParser (choices :: [ChoiceDef Symbol]) where
|
||||||
|
enumParser :: Alternative f => GQL.Name -> f (NS Proxy choices)
|
||||||
|
|
||||||
|
instance EnumParser '[] where
|
||||||
|
enumParser _ = empty
|
||||||
|
instance (KnownName name, EnumParser choices)
|
||||||
|
=> EnumParser ('ChoiceDef name ': choices) where
|
||||||
|
enumParser w@(GQL.unName -> wanted)
|
||||||
|
| wanted == mname = pure (Z Proxy)
|
||||||
|
| otherwise = S <$> enumParser w
|
||||||
|
where
|
||||||
|
mname = T.pack $ nameVal (Proxy @name)
|
||||||
|
|
||||||
|
class ValueParser sch v where
|
||||||
|
valueParser :: Alternative f
|
||||||
|
=> GQL.Value
|
||||||
|
-> f (FieldValue Identity sch v)
|
||||||
|
|
||||||
|
instance ValueParser sch 'TNull where
|
||||||
|
valueParser GQL.VNull = pure FNull
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive Bool) where
|
||||||
|
valueParser (GQL.VBoolean b) = pure (FPrimitive b)
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive Int32) where
|
||||||
|
valueParser (GQL.VInt b) = pure (FPrimitive b)
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive Integer) where
|
||||||
|
valueParser (GQL.VInt b) = pure $ FPrimitive $ fromIntegral b
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive Double) where
|
||||||
|
valueParser (GQL.VFloat b) = pure (FPrimitive b)
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive T.Text) where
|
||||||
|
valueParser (GQL.VString (GQL.StringValue b)) = pure $ FPrimitive b
|
||||||
|
valueParser _ = empty
|
||||||
|
instance ValueParser sch ('TPrimitive String) where
|
||||||
|
valueParser (GQL.VString (GQL.StringValue b)) = pure $ FPrimitive $ T.unpack b
|
||||||
|
valueParser _ = empty
|
||||||
|
instance (ValueParser sch r) => ValueParser sch ('TList r) where
|
||||||
|
valueParser (GQL.VList (GQL.ListValueG xs)) = FList <$> traverse valueParser xs
|
||||||
|
valueParser _ = empty
|
||||||
|
instance (sch :/: sty ~ 'DRecord name args, ObjectParser sch args)
|
||||||
|
=> ValueParser sch ('TSchematic sty) where
|
||||||
|
valueParser (GQL.VObject (GQL.ObjectValueG vs)) = FSchematic <$> (TRecord <$> objectParser vs)
|
||||||
|
valueParser _ = empty
|
||||||
|
|
||||||
|
class ParseReturn (p :: Package') (r :: TypeRef Symbol) where
|
||||||
|
parseReturn :: Alternative f
|
||||||
|
=> GQL.SelectionSet
|
||||||
|
-> f (ReturnQuery p r)
|
||||||
|
|
||||||
|
instance ParseReturn p ('PrimitiveRef t) where
|
||||||
|
parseReturn [] = pure RetPrimitive
|
||||||
|
parseReturn _ = empty
|
||||||
|
instance ParseReturn p ('SchemaRef sch sty) where
|
||||||
|
parseReturn _ = pure RetSchema
|
||||||
|
instance ParseReturn p r
|
||||||
|
=> ParseReturn p ('ListRef r) where
|
||||||
|
parseReturn s = RetList <$> parseReturn s
|
||||||
|
instance ParseReturn p r
|
||||||
|
=> ParseReturn p ('OptionalRef r) where
|
||||||
|
parseReturn s = RetOptional <$> parseReturn s
|
||||||
|
instance ( p ~ 'Package pname ss,
|
||||||
|
LookupService ss s ~ 'Service s sanns methods,
|
||||||
|
ParseMethod p methods
|
||||||
|
) => ParseReturn p ('ObjectRef s) where
|
||||||
|
parseReturn s = RetObject <$> parseQuery (Proxy @p) (Proxy @s) s
|
211
graphql/src/Mu/GraphQL/Query/Run.hs
Normal file
211
graphql/src/Mu/GraphQL/Query/Run.hs
Normal file
@ -0,0 +1,211 @@
|
|||||||
|
{-# language DataKinds #-}
|
||||||
|
{-# language FlexibleContexts #-}
|
||||||
|
{-# language FlexibleInstances #-}
|
||||||
|
{-# language GADTs #-}
|
||||||
|
{-# language MultiParamTypeClasses #-}
|
||||||
|
{-# language OverloadedLists #-}
|
||||||
|
{-# language OverloadedStrings #-}
|
||||||
|
{-# language PolyKinds #-}
|
||||||
|
{-# language ScopedTypeVariables #-}
|
||||||
|
{-# language TupleSections #-}
|
||||||
|
{-# language TypeApplications #-}
|
||||||
|
{-# language TypeOperators #-}
|
||||||
|
{-# language UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -fprint-explicit-foralls #-}
|
||||||
|
module Mu.GraphQL.Query.Run (
|
||||||
|
runPipeline
|
||||||
|
, runDocument
|
||||||
|
, runQuery
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Except (runExceptT)
|
||||||
|
import Control.Monad.Writer
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import qualified Data.Aeson.Types as Aeson
|
||||||
|
import Data.Functor.Identity
|
||||||
|
import Data.Maybe
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import GHC.TypeLits
|
||||||
|
import qualified Language.GraphQL.Draft.Syntax as GQL
|
||||||
|
|
||||||
|
import Mu.GraphQL.Query.Definition
|
||||||
|
import Mu.GraphQL.Query.Parse
|
||||||
|
import Mu.Rpc
|
||||||
|
import Mu.Schema
|
||||||
|
import Mu.Server
|
||||||
|
|
||||||
|
data GraphQLError
|
||||||
|
= GraphQLError ServerError [T.Text]
|
||||||
|
|
||||||
|
runPipeline
|
||||||
|
:: forall qr mut (p :: Package') pname ss hs chn qanns qmethods manns mmethods.
|
||||||
|
( p ~ 'Package pname ss
|
||||||
|
, LookupService ss qr ~ 'Service qr qanns qmethods
|
||||||
|
, ParseMethod p qmethods
|
||||||
|
, LookupService ss mut ~ 'Service mut manns mmethods
|
||||||
|
, ParseMethod p mmethods
|
||||||
|
, RunQueryFindHandler p hs chn ss (LookupService ss qr) hs
|
||||||
|
, MappingRight chn qr ~ ()
|
||||||
|
, RunQueryFindHandler p hs chn ss (LookupService ss mut) hs
|
||||||
|
, MappingRight chn mut ~ ()
|
||||||
|
)
|
||||||
|
=> ServerT Identity chn p ServerErrorIO hs
|
||||||
|
-> Proxy qr -> Proxy mut -> GQL.ExecutableDocument
|
||||||
|
-> IO Aeson.Value
|
||||||
|
runPipeline svr _ _ doc
|
||||||
|
= case parseDoc doc of
|
||||||
|
Nothing ->
|
||||||
|
return $
|
||||||
|
Aeson.object [
|
||||||
|
("errors", Aeson.Array [
|
||||||
|
Aeson.object [ ("message", Aeson.String "cannot parse document") ] ])]
|
||||||
|
Just (d :: Document p qr mut) -> do
|
||||||
|
(data_, errors) <- runWriterT (runDocument svr d)
|
||||||
|
case errors of
|
||||||
|
[] -> return $ Aeson.object [ ("data", data_) ]
|
||||||
|
_ -> return $ Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ]
|
||||||
|
where
|
||||||
|
errValue :: GraphQLError -> Aeson.Value
|
||||||
|
errValue (GraphQLError (ServerError _ msg) path)
|
||||||
|
= Aeson.object [
|
||||||
|
("message", Aeson.String $ T.pack msg)
|
||||||
|
, ("path", Aeson.toJSON path)
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
runDocument
|
||||||
|
:: ( p ~ 'Package pname ss
|
||||||
|
, RunQueryFindHandler p hs chn ss (LookupService ss qr) hs
|
||||||
|
, MappingRight chn qr ~ ()
|
||||||
|
, RunQueryFindHandler p hs chn ss (LookupService ss mut) hs
|
||||||
|
, MappingRight chn mut ~ ()
|
||||||
|
)
|
||||||
|
=> ServerT Identity chn p ServerErrorIO hs
|
||||||
|
-> Document p qr mut
|
||||||
|
-> WriterT [GraphQLError] IO Aeson.Value
|
||||||
|
runDocument svr (QueryDoc q)
|
||||||
|
= runQuery svr () q
|
||||||
|
runDocument svr (MutationDoc q)
|
||||||
|
= runQuery svr () q
|
||||||
|
|
||||||
|
runQuery
|
||||||
|
:: forall p s pname ss hs sname sanns ms chn inh.
|
||||||
|
( RunQueryFindHandler p hs chn ss s hs
|
||||||
|
, p ~ 'Package pname ss
|
||||||
|
, s ~ 'Service sname sanns ms
|
||||||
|
, inh ~ MappingRight chn sname )
|
||||||
|
=> ServerT Identity chn p ServerErrorIO hs
|
||||||
|
-> inh
|
||||||
|
-> ServiceQuery p s
|
||||||
|
-> WriterT [GraphQLError] IO Aeson.Value
|
||||||
|
runQuery whole@(Services ss) = runQueryFindHandler whole ss
|
||||||
|
|
||||||
|
class RunQueryFindHandler p whole chn ss s hs where
|
||||||
|
runQueryFindHandler
|
||||||
|
:: ( p ~ 'Package pname wholess
|
||||||
|
, s ~ 'Service sname sanns ms
|
||||||
|
, inh ~ MappingRight chn sname )
|
||||||
|
=> ServerT Identity chn p ServerErrorIO whole
|
||||||
|
-> ServicesT Identity chn ss ServerErrorIO hs
|
||||||
|
-> inh
|
||||||
|
-> ServiceQuery p s
|
||||||
|
-> WriterT [GraphQLError] IO Aeson.Value
|
||||||
|
|
||||||
|
instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s)
|
||||||
|
=> RunQueryFindHandler p whole chn '[] s '[] where
|
||||||
|
runQueryFindHandler = error "this should never be called"
|
||||||
|
instance {-# OVERLAPPABLE #-}
|
||||||
|
RunQueryFindHandler p whole chn ss s hs
|
||||||
|
=> RunQueryFindHandler p whole chn (other ': ss) s (h ': hs) where
|
||||||
|
runQueryFindHandler whole (_ :<&>: that) = runQueryFindHandler whole that
|
||||||
|
instance {-# OVERLAPS #-} (s ~ 'Service sname sanns ms, RunMethod p whole chn sname ms h)
|
||||||
|
=> RunQueryFindHandler p whole chn (s ': ss) s (h ': hs) where
|
||||||
|
runQueryFindHandler whole (this :<&>: _) inh queries
|
||||||
|
= Aeson.object . catMaybes <$> mapM runOneQuery queries
|
||||||
|
where
|
||||||
|
-- if we include the signature we have to write
|
||||||
|
-- an explicit type signature for 'runQueryFindHandler'
|
||||||
|
runOneQuery (OneMethodQuery nm args)
|
||||||
|
= pass (do (val, methodName) <- runMethod whole (Proxy @sname) inh this args
|
||||||
|
let realName = fromMaybe methodName nm
|
||||||
|
-- choose between given name,
|
||||||
|
-- or fallback to method name
|
||||||
|
newVal = fmap (realName,) val
|
||||||
|
pure (newVal, map (updateErrs realName)) )
|
||||||
|
where -- add the additional path component to the errors
|
||||||
|
updateErrs :: T.Text -> GraphQLError -> GraphQLError
|
||||||
|
updateErrs methodName (GraphQLError err loc) = GraphQLError err (methodName : loc)
|
||||||
|
|
||||||
|
class RunMethod p whole chn sname ms hs where
|
||||||
|
runMethod
|
||||||
|
:: ( p ~ 'Package pname wholess
|
||||||
|
, inh ~ MappingRight chn sname )
|
||||||
|
=> ServerT Identity chn p ServerErrorIO whole
|
||||||
|
-> Proxy sname -> inh
|
||||||
|
-> HandlersT Identity chn inh ms ServerErrorIO hs
|
||||||
|
-> NS (ChosenMethodQuery p) ms
|
||||||
|
-> WriterT [GraphQLError] IO (Maybe Aeson.Value, T.Text)
|
||||||
|
|
||||||
|
instance RunMethod p whole chn s '[] '[] where
|
||||||
|
runMethod = error "this should never be called"
|
||||||
|
instance (RunMethod p whole chn s ms hs, KnownName mname, RunHandler p whole chn args r h)
|
||||||
|
=> RunMethod p whole chn s ('Method mname anns args ('RetSingle r) ': ms) (h ': hs) where
|
||||||
|
runMethod whole _ inh (h :<||>: _) (Z (ChosenMethodQuery args ret))
|
||||||
|
= (, T.pack $ nameVal (Proxy @mname)) <$> runHandler whole (h inh) args ret
|
||||||
|
runMethod whole p inh (_ :<||>: r) (S cont)
|
||||||
|
= runMethod whole p inh r cont
|
||||||
|
|
||||||
|
class Handles Identity chn args ('RetSingle r) ServerErrorIO h
|
||||||
|
=> RunHandler p whole chn args r h where
|
||||||
|
runHandler :: ServerT Identity chn p ServerErrorIO whole
|
||||||
|
-> h
|
||||||
|
-> NP (ArgumentValue p) args
|
||||||
|
-> ReturnQuery p r
|
||||||
|
-> WriterT [GraphQLError] IO (Maybe Aeson.Value)
|
||||||
|
|
||||||
|
instance (ArgumentConversion chn ref t, RunHandler p whole chn rest r h)
|
||||||
|
=> RunHandler p whole chn ('ArgSingle ref ': rest) r (t -> h) where
|
||||||
|
runHandler whole h (ArgumentValue one :* rest)
|
||||||
|
= runHandler whole (h (convertArg (Proxy @chn) one)) rest
|
||||||
|
instance (ResultConversion p whole chn r l)
|
||||||
|
=> RunHandler p whole chn '[] r (ServerErrorIO l) where
|
||||||
|
runHandler whole h Nil q = do
|
||||||
|
res <- liftIO $ runExceptT h
|
||||||
|
case res of
|
||||||
|
Right v -> convertResult whole q v
|
||||||
|
Left e -> tell [GraphQLError e []] >> return Nothing
|
||||||
|
|
||||||
|
class FromRef Identity chn ref t
|
||||||
|
=> ArgumentConversion chn ref t where
|
||||||
|
convertArg :: Proxy chn -> ArgumentValue' p ref -> t
|
||||||
|
instance ArgumentConversion chn ('PrimitiveRef s) s where
|
||||||
|
convertArg _ (ArgPrimitive x) = x
|
||||||
|
instance FromSchema Identity sch sty t
|
||||||
|
=> ArgumentConversion chn ('SchemaRef sch sty) t where
|
||||||
|
convertArg _ (ArgSchema x) = fromSchema x
|
||||||
|
instance ArgumentConversion chn ref t
|
||||||
|
=> ArgumentConversion chn ('ListRef ref) [t] where
|
||||||
|
convertArg p (ArgList x) = convertArg p <$> x
|
||||||
|
instance ArgumentConversion chn ref t
|
||||||
|
=> ArgumentConversion chn ('OptionalRef ref) (Maybe t) where
|
||||||
|
convertArg p (ArgOptional x) = convertArg p <$> x
|
||||||
|
|
||||||
|
class ToRef Identity chn r l => ResultConversion p whole chn r l where
|
||||||
|
convertResult :: ServerT Identity chn p ServerErrorIO whole
|
||||||
|
-> ReturnQuery p r
|
||||||
|
-> l -> WriterT [GraphQLError] IO (Maybe Aeson.Value)
|
||||||
|
|
||||||
|
instance Aeson.ToJSON t => ResultConversion p whole chn ('PrimitiveRef t) t where
|
||||||
|
convertResult _ RetPrimitive = return . Just . Aeson.toJSON
|
||||||
|
instance ( ToSchema Identity sch l r
|
||||||
|
, Aeson.ToJSON (Term Identity sch (sch :/: l)) )
|
||||||
|
=> ResultConversion p whole chn ('SchemaRef sch l) r where
|
||||||
|
convertResult _ RetSchema = return . Just . Aeson.toJSON . toSchema' @_ @_ @sch @Identity @r
|
||||||
|
instance ( MappingRight chn ref ~ t
|
||||||
|
, MappingRight chn sname ~ t
|
||||||
|
, LookupService ss ref ~ 'Service sname sanns ms
|
||||||
|
, RunQueryFindHandler ('Package pname ss) whole chn ss ('Service sname sanns ms) whole)
|
||||||
|
=> ResultConversion ('Package pname ss) whole chn ('ObjectRef ref) t where
|
||||||
|
convertResult whole (RetObject q) h
|
||||||
|
= Just <$> runQuery @('Package pname ss) @(LookupService ss ref) whole h q
|
||||||
|
-- TODO: be able to return enums
|
@ -30,6 +30,7 @@ library
|
|||||||
other-modules: Mu.GRpc.Client.Internal
|
other-modules: Mu.GRpc.Client.Internal
|
||||||
build-depends:
|
build-depends:
|
||||||
async
|
async
|
||||||
|
, avro >=0.4.7
|
||||||
, base >=4.12 && <5
|
, base >=4.12 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
, conduit
|
, conduit
|
||||||
|
@ -32,7 +32,7 @@ sayHello' host port req
|
|||||||
fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req))
|
fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req))
|
||||||
|
|
||||||
sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse))
|
sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse))
|
||||||
sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHello"
|
sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHello"
|
||||||
|
|
||||||
sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)]
|
sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)]
|
||||||
sayHi' host port n
|
sayHi' host port n
|
||||||
@ -41,4 +41,4 @@ sayHi' host port n
|
|||||||
runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume
|
runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume
|
||||||
|
|
||||||
sayHi :: GrpcClient -> M HiRequest -> IO (ConduitT () (GRpcReply (M HelloResponse)) IO ())
|
sayHi :: GrpcClient -> M HiRequest -> IO (ConduitT () (GRpcReply (M HelloResponse)) IO ())
|
||||||
sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"SayHi"
|
sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHi"
|
||||||
|
@ -11,6 +11,7 @@
|
|||||||
{-# language TypeFamilies #-}
|
{-# language TypeFamilies #-}
|
||||||
{-# language TypeOperators #-}
|
{-# language TypeOperators #-}
|
||||||
{-# language UndecidableInstances #-}
|
{-# language UndecidableInstances #-}
|
||||||
|
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
|
||||||
-- | Client for gRPC services defined using Mu 'Service'
|
-- | Client for gRPC services defined using Mu 'Service'
|
||||||
module Mu.GRpc.Client.Internal where
|
module Mu.GRpc.Client.Internal where
|
||||||
|
|
||||||
@ -19,11 +20,14 @@ import Control.Concurrent.STM (atomically)
|
|||||||
import Control.Concurrent.STM.TMChan
|
import Control.Concurrent.STM.TMChan
|
||||||
import Control.Concurrent.STM.TMVar
|
import Control.Concurrent.STM.TMVar
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Data.Avro
|
||||||
import qualified Data.ByteString.Char8 as BS
|
import qualified Data.ByteString.Char8 as BS
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import qualified Data.Conduit.Combinators as C
|
import qualified Data.Conduit.Combinators as C
|
||||||
import Data.Conduit.TMChan
|
import Data.Conduit.TMChan
|
||||||
|
import Data.Functor.Identity
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
|
import GHC.TypeLits
|
||||||
import Network.GRPC.Client (CompressMode (..), IncomingEvent (..),
|
import Network.GRPC.Client (CompressMode (..), IncomingEvent (..),
|
||||||
OutgoingEvent (..), RawReply, StreamDone (..))
|
OutgoingEvent (..), RawReply, StreamDone (..))
|
||||||
import Network.GRPC.Client.Helpers
|
import Network.GRPC.Client.Helpers
|
||||||
@ -41,14 +45,14 @@ import Mu.Schema
|
|||||||
setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient)
|
setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient)
|
||||||
setupGrpcClient' = runExceptT . setupGrpcClient
|
setupGrpcClient' = runExceptT . setupGrpcClient
|
||||||
|
|
||||||
class GRpcServiceMethodCall (p :: GRpcMessageProtocol) (s :: Service snm mnm) (m :: Method mnm) h where
|
class GRpcServiceMethodCall (p :: GRpcMessageProtocol)
|
||||||
gRpcServiceMethodCall :: Proxy p -> Proxy s -> Proxy m -> GrpcClient -> h
|
(pkg :: snm) (s :: snm) (m :: Method snm mnm) h where
|
||||||
instance ( KnownName serviceName, KnownName (FindPackageName anns), KnownName mname
|
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 )
|
, GRpcMethodCall p ('Method mname manns margs mret) h, MkRPC p )
|
||||||
=> GRpcServiceMethodCall p ('Service serviceName anns methods)
|
=> GRpcServiceMethodCall p pkg serviceName ('Method mname manns margs mret) h where
|
||||||
('Method mname manns margs mret) h where
|
gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc
|
||||||
gRpcServiceMethodCall pro _ = gRpcMethodCall @p rpc
|
where pkgName = BS.pack (nameVal (Proxy @pkg))
|
||||||
where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
|
||||||
svrName = BS.pack (nameVal (Proxy @serviceName))
|
svrName = BS.pack (nameVal (Proxy @serviceName))
|
||||||
metName = BS.pack (nameVal (Proxy @mname))
|
metName = BS.pack (nameVal (Proxy @mname))
|
||||||
rpc = mkRPC pro pkgName svrName metName
|
rpc = mkRPC pro pkgName svrName metName
|
||||||
@ -80,15 +84,15 @@ buildGRpcReply3 (Right _) = GRpcOk ()
|
|||||||
simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a)
|
simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a)
|
||||||
simplifyResponse reply = do
|
simplifyResponse reply = do
|
||||||
r <- runExceptT reply
|
r <- runExceptT reply
|
||||||
case r of
|
pure $ case r of
|
||||||
Left e -> return $ GRpcClientError e
|
Left e -> GRpcClientError e
|
||||||
Right v -> return v
|
Right v -> v
|
||||||
|
|
||||||
-- These type classes allow us to abstract over
|
-- These type classes allow us to abstract over
|
||||||
-- the choice of message protocol (PB or Avro)
|
-- the choice of message protocol (PB or Avro)
|
||||||
|
|
||||||
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
||||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||||
type GRpcIWTy p ref r :: Type
|
type GRpcIWTy p ref r :: Type
|
||||||
buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r
|
buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r
|
||||||
|
|
||||||
@ -97,13 +101,15 @@ instance ToProtoBufTypeRef ref r
|
|||||||
type GRpcIWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
type GRpcIWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
||||||
buildGRpcIWTy _ _ = ViaToProtoBufTypeRef
|
buildGRpcIWTy _ _ = ViaToProtoBufTypeRef
|
||||||
|
|
||||||
instance (GRPCInput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r))
|
instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
|
||||||
=> GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
( ToSchema Identity sch sty r
|
||||||
type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r
|
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||||
|
=> GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||||
|
type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r
|
||||||
buildGRpcIWTy _ _ = ViaToAvroTypeRef
|
buildGRpcIWTy _ _ = ViaToAvroTypeRef
|
||||||
|
|
||||||
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
||||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||||
type GRpcOWTy p ref r :: Type
|
type GRpcOWTy p ref r :: Type
|
||||||
unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r
|
unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r
|
||||||
|
|
||||||
@ -112,16 +118,18 @@ instance FromProtoBufTypeRef ref r
|
|||||||
type GRpcOWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
type GRpcOWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
||||||
unGRpcOWTy _ _ = unViaFromProtoBufTypeRef
|
unGRpcOWTy _ _ = unViaFromProtoBufTypeRef
|
||||||
|
|
||||||
instance (GRPCOutput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r))
|
instance forall (sch :: Schema') (sty :: Symbol) (r :: Type).
|
||||||
=> GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
( FromSchema Identity sch sty r
|
||||||
type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r
|
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||||
|
=> GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||||
|
type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r
|
||||||
unGRpcOWTy _ _ = unViaFromAvroTypeRef
|
unGRpcOWTy _ _ = unViaFromAvroTypeRef
|
||||||
|
|
||||||
-- -----------------------------
|
-- -----------------------------
|
||||||
-- IMPLEMENTATION OF THE METHODS
|
-- IMPLEMENTATION OF THE METHODS
|
||||||
-- -----------------------------
|
-- -----------------------------
|
||||||
|
|
||||||
class GRpcMethodCall (p :: GRpcMessageProtocol) method h where
|
class GRpcMethodCall (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) h where
|
||||||
gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h
|
gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h
|
||||||
|
|
||||||
instance ( KnownName name
|
instance ( KnownName name
|
||||||
@ -170,7 +178,7 @@ instance ( KnownName name
|
|||||||
GRpcOk _ -> -- no error, everything is fine
|
GRpcOk _ -> -- no error, everything is fine
|
||||||
sourceTMChan chan .| C.map GRpcOk
|
sourceTMChan chan .| C.map GRpcOk
|
||||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||||
return go
|
pure go
|
||||||
|
|
||||||
instance ( KnownName name
|
instance ( KnownName name
|
||||||
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
|
, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()
|
||||||
@ -207,8 +215,8 @@ instance ( KnownName name
|
|||||||
rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client ()
|
rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client ()
|
||||||
(\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan
|
(\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan
|
||||||
case nextVal of
|
case nextVal of
|
||||||
Nothing -> return ((), Left StreamDone)
|
Nothing -> pure ((), Left StreamDone)
|
||||||
Just v -> return ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
Just v -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||||
-- This conduit feeds information to the other thread
|
-- This conduit feeds information to the other thread
|
||||||
let go = do x <- await
|
let go = do x <- await
|
||||||
case x of
|
case x of
|
||||||
@ -216,7 +224,7 @@ instance ( KnownName name
|
|||||||
go
|
go
|
||||||
Nothing -> do liftIO $ atomically $ closeTMChan chan
|
Nothing -> do liftIO $ atomically $ closeTMChan chan
|
||||||
liftIO $ wait promise
|
liftIO $ wait promise
|
||||||
return go
|
pure go
|
||||||
|
|
||||||
instance ( KnownName name
|
instance ( KnownName name
|
||||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||||
@ -245,7 +253,7 @@ instance ( KnownName name
|
|||||||
GRpcOk _ -> -- no error, everything is fine
|
GRpcOk _ -> -- no error, everything is fine
|
||||||
sourceTMChan chan .| C.map GRpcOk
|
sourceTMChan chan .| C.map GRpcOk
|
||||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||||
return go
|
pure go
|
||||||
|
|
||||||
instance ( KnownName name
|
instance ( KnownName name
|
||||||
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r
|
||||||
@ -268,12 +276,12 @@ instance ( KnownName name
|
|||||||
case ievent of
|
case ievent of
|
||||||
RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unGRpcOWTy(Proxy @p) (Proxy @rref) o)
|
RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unGRpcOWTy(Proxy @p) (Proxy @rref) o)
|
||||||
Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e))
|
Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e))
|
||||||
_ -> return () )
|
_ -> pure () )
|
||||||
() (\_ -> do
|
() (\_ -> do
|
||||||
nextVal <- liftIO $ atomically $ readTMChan outchan
|
nextVal <- liftIO $ atomically $ readTMChan outchan
|
||||||
case nextVal of
|
case nextVal of
|
||||||
Nothing -> return ((), Finalize)
|
Nothing -> pure ((), Finalize)
|
||||||
Just v -> return ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
Just v -> pure ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)))
|
||||||
case v of
|
case v of
|
||||||
GRpcOk () -> liftIO $ atomically $ closeTMChan inchan
|
GRpcOk () -> liftIO $ atomically $ closeTMChan inchan
|
||||||
_ -> liftIO $ atomically $ putTMVar var v
|
_ -> liftIO $ atomically $ putTMVar var v
|
||||||
@ -288,7 +296,7 @@ instance ( KnownName name
|
|||||||
go2
|
go2
|
||||||
Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan
|
Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan
|
||||||
case r of
|
case r of
|
||||||
Nothing -> return () -- both are empty, end
|
Nothing -> pure () -- both are empty, end
|
||||||
Just Nothing -> go2
|
Just Nothing -> go2
|
||||||
Just (Just nextIn) -> yield nextIn >> go2
|
Just (Just nextIn) -> yield nextIn >> go2
|
||||||
return go
|
pure go
|
||||||
|
@ -49,9 +49,13 @@ import Mu.Schema
|
|||||||
import Mu.Schema.Optics
|
import Mu.Schema.Optics
|
||||||
|
|
||||||
-- | Represents a connection to the service @s@.
|
-- | Represents a connection to the service @s@.
|
||||||
newtype GRpcConnection (s :: Service Symbol Symbol) (p :: GRpcMessageProtocol)
|
newtype GRpcConnection (s :: Package') (p :: GRpcMessageProtocol)
|
||||||
= GRpcConnection { gcClient :: G.GrpcClient }
|
= GRpcConnection { gcClient :: G.GrpcClient }
|
||||||
|
|
||||||
|
-- | Represents a connection to a specific service @s@
|
||||||
|
newtype GRpcConnectionService (pkg :: Package') (srv :: Service') (p :: GRpcMessageProtocol)
|
||||||
|
= GRpcConnectionService { gcsClient :: G.GrpcClient }
|
||||||
|
|
||||||
-- | Initializes a connection to a gRPC server.
|
-- | Initializes a connection to a gRPC server.
|
||||||
-- Usually the service you are connecting to is
|
-- Usually the service you are connecting to is
|
||||||
-- inferred from the usage later on.
|
-- inferred from the usage later on.
|
||||||
@ -64,28 +68,43 @@ initGRpc :: G.GrpcClientConfig -- ^ gRPC configuration
|
|||||||
-> forall s. IO (Either ClientError (GRpcConnection s p))
|
-> forall s. IO (Either ClientError (GRpcConnection s p))
|
||||||
initGRpc config _ = do
|
initGRpc config _ = do
|
||||||
setup <- setupGrpcClient' config
|
setup <- setupGrpcClient' config
|
||||||
case setup of
|
pure $ case setup of
|
||||||
Left e -> return $ Left e
|
Left e -> Left e
|
||||||
Right c -> return $ Right $ GRpcConnection c
|
Right c -> Right $ GRpcConnection c
|
||||||
|
|
||||||
instance forall (serviceName :: Symbol) anns (methods :: [Method Symbol]) (m :: Symbol)
|
instance forall (pkg :: Package') pkgName (services :: [Service'])
|
||||||
(t :: *) (p :: GRpcMessageProtocol).
|
(s :: Service')
|
||||||
( SearchMethodOptic p methods m t
|
(p :: GRpcMessageProtocol) (m :: Symbol).
|
||||||
|
( pkg ~ 'Package pkgName services, s ~ LookupService services m )
|
||||||
|
=> LabelOptic m A_Getter
|
||||||
|
(GRpcConnection pkg p)
|
||||||
|
(GRpcConnection pkg p)
|
||||||
|
(GRpcConnectionService pkg s p)
|
||||||
|
(GRpcConnectionService pkg s p) where
|
||||||
|
labelOptic = to (GRpcConnectionService . gcClient)
|
||||||
|
|
||||||
|
instance forall (pkg :: Package') (pkgName :: Symbol) (services :: [Service'])
|
||||||
|
(service :: Service') (serviceName :: Symbol) (anns :: [ServiceAnnotation])
|
||||||
|
(methods :: [Method Symbol Symbol])
|
||||||
|
(p :: GRpcMessageProtocol) (m :: Symbol) t.
|
||||||
|
( pkg ~ 'Package ('Just pkgName) services
|
||||||
|
, service ~ 'Service serviceName anns methods
|
||||||
|
, SearchMethodOptic p methods m t
|
||||||
, KnownName serviceName
|
, KnownName serviceName
|
||||||
, KnownName (FindPackageName anns)
|
, KnownName pkgName
|
||||||
, KnownName m
|
, KnownName m
|
||||||
, MkRPC p )
|
, MkRPC p )
|
||||||
=> LabelOptic m A_Getter
|
=> LabelOptic m A_Getter
|
||||||
(GRpcConnection ('Service serviceName anns methods) p)
|
(GRpcConnectionService pkg service p)
|
||||||
(GRpcConnection ('Service serviceName anns methods) p)
|
(GRpcConnectionService pkg service p)
|
||||||
t t where
|
t t where
|
||||||
labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient)
|
labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcsClient)
|
||||||
where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
where pkgName = BS.pack (nameVal (Proxy @pkgName))
|
||||||
svrName = BS.pack (nameVal (Proxy @serviceName))
|
svrName = BS.pack (nameVal (Proxy @serviceName))
|
||||||
metName = BS.pack (nameVal (Proxy @m))
|
metName = BS.pack (nameVal (Proxy @m))
|
||||||
rpc = mkRPC (Proxy @p) pkgName svrName metName
|
rpc = mkRPC (Proxy @p) pkgName svrName metName
|
||||||
|
|
||||||
class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol]) (m :: Symbol) t
|
class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method Symbol Symbol]) (m :: Symbol) t
|
||||||
| p methods m -> t where
|
| p methods m -> t where
|
||||||
searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t
|
searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t
|
||||||
|
|
||||||
@ -101,7 +120,7 @@ instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t
|
|||||||
searchMethodOptic _ = searchMethodOptic @p (Proxy @rest)
|
searchMethodOptic _ = searchMethodOptic @p (Proxy @rest)
|
||||||
|
|
||||||
class GRpcMethodCall p method t
|
class GRpcMethodCall p method t
|
||||||
=> MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol) t
|
=> MethodOptic (p :: GRpcMessageProtocol) (method :: Method Symbol Symbol) t
|
||||||
| p method -> t where
|
| p method -> t where
|
||||||
methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t
|
methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t
|
||||||
methodOptic = gRpcMethodCall @p
|
methodOptic = gRpcMethodCall @p
|
||||||
@ -116,46 +135,46 @@ instance forall (name :: Symbol) anns t p.
|
|||||||
, t ~ IO (GRpcReply ()) )
|
, t ~ IO (GRpcReply ()) )
|
||||||
=> MethodOptic p ('Method name anns '[ ] 'RetNothing) t
|
=> MethodOptic p ('Method name anns '[ ] 'RetNothing) t
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ IO (GRpcReply (Term w sch (sch :/: r))) )
|
, t ~ IO (GRpcReply (Term w sch (sch :/: r))) )
|
||||||
=> MethodOptic p ('Method name anns '[ ] ('RetSingle ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) )
|
, t ~ IO (ConduitT () (GRpcReply (Term w sch (sch :/: r))) IO ()) )
|
||||||
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ ] ('RetStream ('SchemaRef sch r))) t
|
||||||
-- Simple arguments
|
-- Simple arguments
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t
|
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) )
|
, t ~ (Term w sch (sch :/: v) -> IO (GRpcReply ())) )
|
||||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] 'RetNothing) t
|
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] 'RetNothing) t
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ (Term w sch (sch :/: v)
|
, t ~ (Term w sch (sch :/: v)
|
||||||
-> IO (GRpcReply (Term w sch (sch :/: r))) ) )
|
-> IO (GRpcReply (Term w sch (sch :/: r))) ) )
|
||||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ (Term w sch (sch :/: v)
|
, t ~ (Term w sch (sch :/: v)
|
||||||
-> IO (ConduitT () (GRpcReply (Term Maybe sch (sch :/: r))) IO ()) ) )
|
-> IO (ConduitT () (GRpcReply (Term Maybe sch (sch :/: r))) IO ()) ) )
|
||||||
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ 'ArgSingle ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||||
-- Stream arguments
|
-- Stream arguments
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ (CompressMode
|
, t ~ (CompressMode
|
||||||
-> IO (ConduitT (Term w sch (sch :/: v))
|
-> IO (ConduitT (Term w sch (sch :/: v))
|
||||||
Void IO
|
Void IO
|
||||||
(GRpcReply (Term w sch (sch :/: r))))) )
|
(GRpcReply (Term w sch (sch :/: r))))) )
|
||||||
=> MethodOptic p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetSingle ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t
|
||||||
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) anns t p w.
|
||||||
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
( GRpcMethodCall p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||||
, ProtocolWrapper p w
|
, ProtocolWrapper p w
|
||||||
, t ~ (CompressMode
|
, t ~ (CompressMode
|
||||||
-> IO (ConduitT (Term w sch (sch :/: v))
|
-> IO (ConduitT (Term w sch (sch :/: v))
|
||||||
(GRpcReply (Term w sch (sch :/: r))) IO ())) )
|
(GRpcReply (Term w sch (sch :/: r))) IO ())) )
|
||||||
=> MethodOptic p ('Method name anns '[ 'ArgStream ('ViaSchema sch v) ] ('RetStream ('ViaSchema sch r))) t
|
=> MethodOptic p ('Method name anns '[ 'ArgStream ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t
|
||||||
|
@ -49,35 +49,41 @@ import Mu.Rpc
|
|||||||
|
|
||||||
-- | Fills in a Haskell record of functions with the corresponding
|
-- | Fills in a Haskell record of functions with the corresponding
|
||||||
-- calls to gRPC services from a Mu 'Service' declaration.
|
-- calls to gRPC services from a Mu 'Service' declaration.
|
||||||
buildService :: forall (pro :: GRpcMessageProtocol) (s :: Service') (p :: Symbol) t
|
buildService :: forall (pro :: GRpcMessageProtocol)
|
||||||
(nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]).
|
(pkg :: Package') (s :: Symbol) (p :: Symbol) t
|
||||||
(s ~ 'Service nm anns ms, Generic t, BuildService pro s p ms (Rep t))
|
(pkgName :: Symbol) (ss :: [Service'])
|
||||||
|
(anns :: [ServiceAnnotation]) (ms :: [Method Symbol Symbol]).
|
||||||
|
( pkg ~ 'Package ('Just pkgName) ss
|
||||||
|
, LookupService ss s ~ 'Service s anns ms
|
||||||
|
, Generic t
|
||||||
|
, BuildService pro pkgName s p ms (Rep t) )
|
||||||
=> GrpcClient -> t
|
=> GrpcClient -> t
|
||||||
buildService client = to (buildService' (Proxy @pro) (Proxy @s) (Proxy @p) (Proxy @ms) client)
|
buildService client
|
||||||
|
= to (buildService' (Proxy @pro) (Proxy @pkgName) (Proxy @s) (Proxy @p) (Proxy @ms) client)
|
||||||
|
|
||||||
class BuildService (pro :: GRpcMessageProtocol) (s :: Service')
|
class BuildService (pro :: GRpcMessageProtocol) (pkg :: Symbol) (s :: Symbol)
|
||||||
(p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where
|
(p :: Symbol) (ms :: [Method Symbol Symbol]) (f :: * -> *) where
|
||||||
buildService' :: Proxy pro -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
|
buildService' :: Proxy pro -> Proxy pkg -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a
|
||||||
|
|
||||||
instance BuildService pro s p ms U1 where
|
instance BuildService pro pkg s p ms U1 where
|
||||||
buildService' _ _ _ _ _ = U1
|
buildService' _ _ _ _ _ _ = U1
|
||||||
instance BuildService pro s p ms f => BuildService pro s p ms (D1 meta f) where
|
instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (D1 meta f) where
|
||||||
buildService' ppro ps ppr pms client
|
buildService' ppro ppkg ps ppr pms client
|
||||||
= M1 (buildService' ppro ps ppr pms client)
|
= M1 (buildService' ppro ppkg ps ppr pms client)
|
||||||
instance BuildService pro s p ms f => BuildService pro s p ms (C1 meta f) where
|
instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (C1 meta f) where
|
||||||
buildService' ppro ps ppr pms client
|
buildService' ppro ppkg ps ppr pms client
|
||||||
= M1 (buildService' ppro ps ppr pms client)
|
= M1 (buildService' ppro ppkg ps ppr pms client)
|
||||||
instance TypeError ('Text "building a service from sums is not supported")
|
instance TypeError ('Text "building a service from sums is not supported")
|
||||||
=> BuildService pro s p ms (f :+: g) where
|
=> BuildService pro pkg s p ms (f :+: g) where
|
||||||
buildService' = error "this should never happen"
|
buildService' = error "this should never happen"
|
||||||
instance (BuildService pro s p ms f, BuildService pro s p ms g)
|
instance (BuildService pro pkg s p ms f, BuildService pro pkg s p ms g)
|
||||||
=> BuildService pro s p ms (f :*: g) where
|
=> BuildService pro pkg s p ms (f :*: g) where
|
||||||
buildService' ppro ps ppr pms client
|
buildService' ppro ppkg ps ppr pms client
|
||||||
= buildService' ppro ps ppr pms client :*: buildService' ppro ps ppr pms client
|
= buildService' ppro ppkg ps ppr pms client :*: buildService' ppro ppkg ps ppr pms client
|
||||||
instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro s (s :-->: x) h)
|
instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro pkg sname (LookupMethod ms x) h)
|
||||||
=> BuildService pro s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
|
=> BuildService pro pkg sname p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where
|
||||||
buildService' ppro ps _ _ client
|
buildService' ppro ppkg ps _ _ client
|
||||||
= M1 $ K1 $ gRpcServiceMethodCall ppro ps (Proxy @(s :-->: x)) client
|
= M1 $ K1 $ gRpcServiceMethodCall ppro ppkg ps (Proxy @(LookupMethod ms x)) client
|
||||||
|
|
||||||
-- TEMPLATE HASKELL
|
-- TEMPLATE HASKELL
|
||||||
-- ================
|
-- ================
|
||||||
@ -104,20 +110,20 @@ serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods
|
|||||||
[RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods]
|
[RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods]
|
||||||
[pure (DerivClause Nothing [ConT ''Generic])]
|
[pure (DerivClause Nothing [ConT ''Generic])]
|
||||||
let buildName = mkName ("build" ++ complete)
|
let buildName = mkName ("build" ++ complete)
|
||||||
s <- SigD buildName <$> [t|GrpcClient -> $(return (ConT (mkName complete)))|]
|
s <- SigD buildName <$> [t|GrpcClient -> $(pure (ConT (mkName complete)))|]
|
||||||
c <- Clause <$> pure []
|
c <- Clause <$> pure []
|
||||||
<*> (NormalB <$> [e|buildService @($(return $ ConT serviceTyName))
|
<*> (NormalB <$> [e|buildService @($(pure $ ConT serviceTyName))
|
||||||
@($(return $ LitT (StrTyLit fieldsPrefix)))|])
|
@($(pure $ LitT (StrTyLit fieldsPrefix)))|])
|
||||||
<*> pure []
|
<*> pure []
|
||||||
return [d, s, FunD buildName [c]]
|
pure [d, s, FunD buildName [c]]
|
||||||
|
|
||||||
methodToDecl :: String -> Namer -> Method String -> Q (Name, Bang, Type)
|
methodToDecl :: String -> Namer -> Method String String -> Q (Name, Bang, Type)
|
||||||
methodToDecl fieldsPrefix tNamer (Method mName _ args ret)
|
methodToDecl fieldsPrefix tNamer (Method mName _ args ret)
|
||||||
= do let nm = firstLower (fieldsPrefix ++ mName)
|
= do let nm = firstLower (fieldsPrefix ++ mName)
|
||||||
ty <- computeMethodType tNamer args ret
|
ty <- computeMethodType tNamer args ret
|
||||||
return ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty )
|
pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty )
|
||||||
|
|
||||||
computeMethodType :: Namer -> [Argument] -> Return -> Q Type
|
computeMethodType :: Namer -> [Argument String] -> Return String -> Q Type
|
||||||
computeMethodType _ [] RetNothing
|
computeMethodType _ [] RetNothing
|
||||||
= [t|IO (GRpcReply ())|]
|
= [t|IO (GRpcReply ())|]
|
||||||
computeMethodType n [] (RetSingle r)
|
computeMethodType n [] (RetSingle r)
|
||||||
@ -134,11 +140,11 @@ computeMethodType n [ArgStream v] (RetStream r)
|
|||||||
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
|
= [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|]
|
||||||
computeMethodType _ _ _ = fail "method signature not supported"
|
computeMethodType _ _ _ = fail "method signature not supported"
|
||||||
|
|
||||||
typeRefToType :: Namer -> TypeRef -> Q Type
|
typeRefToType :: Namer -> TypeRef snm -> Q Type
|
||||||
typeRefToType tNamer (ViaTH (LitT (StrTyLit s)))
|
typeRefToType tNamer (THRef (LitT (StrTyLit s)))
|
||||||
= return $ ConT (mkName $ completeName tNamer s)
|
= pure $ ConT (mkName $ completeName tNamer s)
|
||||||
typeRefToType _tNamer (ViaTH ty)
|
typeRefToType _tNamer (THRef ty)
|
||||||
= return ty
|
= pure ty
|
||||||
typeRefToType _ _ = error "this should never happen"
|
typeRefToType _ _ = error "this should never happen"
|
||||||
|
|
||||||
completeName :: Namer -> String -> String
|
completeName :: Namer -> String -> String
|
||||||
@ -167,7 +173,7 @@ typeToServiceDef toplevelty
|
|||||||
<*> pure []
|
<*> pure []
|
||||||
<*> mapM typeToMethodDef methods'
|
<*> mapM typeToMethodDef methods'
|
||||||
|
|
||||||
typeToMethodDef :: Type -> Maybe (Method String)
|
typeToMethodDef :: Type -> Maybe (Method String String)
|
||||||
typeToMethodDef ty
|
typeToMethodDef ty
|
||||||
= do (mn, _, args, ret) <- tyD4 'Method ty
|
= do (mn, _, args, ret) <- tyD4 'Method ty
|
||||||
args' <- tyList args
|
args' <- tyList args
|
||||||
@ -176,12 +182,12 @@ typeToServiceDef toplevelty
|
|||||||
<*> mapM typeToArgDef args'
|
<*> mapM typeToArgDef args'
|
||||||
<*> typeToRetDef ret
|
<*> typeToRetDef ret
|
||||||
|
|
||||||
typeToArgDef :: Type -> Maybe Argument
|
typeToArgDef :: Type -> Maybe (Argument String)
|
||||||
typeToArgDef ty
|
typeToArgDef ty
|
||||||
= ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef)
|
= ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef)
|
||||||
<|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef)
|
<|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef)
|
||||||
|
|
||||||
typeToRetDef :: Type -> Maybe Return
|
typeToRetDef :: Type -> Maybe (Return String)
|
||||||
typeToRetDef ty
|
typeToRetDef ty
|
||||||
= RetNothing <$ tyD0 'RetNothing ty
|
= RetNothing <$ tyD0 'RetNothing ty
|
||||||
<|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef)
|
<|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef)
|
||||||
@ -189,12 +195,12 @@ typeToServiceDef toplevelty
|
|||||||
RetThrows <$> typeToTypeRef e <*> typeToTypeRef v)
|
RetThrows <$> typeToTypeRef e <*> typeToTypeRef v)
|
||||||
<|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef)
|
<|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef)
|
||||||
|
|
||||||
typeToTypeRef :: Type -> Maybe TypeRef
|
typeToTypeRef :: Type -> Maybe (TypeRef snm)
|
||||||
typeToTypeRef ty
|
typeToTypeRef ty
|
||||||
= (do (_,innerTy) <- tyD2 'ViaSchema ty
|
= (do (_,innerTy) <- tyD2 'SchemaRef ty
|
||||||
return (ViaTH innerTy))
|
pure (THRef innerTy))
|
||||||
<|> (do (_,innerTy,_) <- tyD3 'ViaRegistry ty
|
<|> (do (_,innerTy,_) <- tyD3 'RegistryRef ty
|
||||||
return (ViaTH innerTy))
|
pure (THRef innerTy))
|
||||||
|
|
||||||
tyString :: Type -> Maybe String
|
tyString :: Type -> Maybe String
|
||||||
tyString (SigT t _)
|
tyString (SigT t _)
|
||||||
|
@ -26,6 +26,7 @@ module Mu.GRpc.Client.TyApps (
|
|||||||
, GRpcReply(..)
|
, GRpcReply(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import GHC.TypeLits
|
||||||
import Network.GRPC.Client (CompressMode (..))
|
import Network.GRPC.Client (CompressMode (..))
|
||||||
import Network.GRPC.Client.Helpers
|
import Network.GRPC.Client.Helpers
|
||||||
|
|
||||||
@ -45,7 +46,12 @@ import Mu.GRpc.Client.Internal
|
|||||||
-- * The resulting value is always wrapped in 'GRpcReply'.
|
-- * The resulting value is always wrapped in 'GRpcReply'.
|
||||||
-- * A single input or output turns into a single value.
|
-- * A single input or output turns into a single value.
|
||||||
-- * A streaming input or output turns into a Conduit.
|
-- * A streaming input or output turns into a Conduit.
|
||||||
gRpcCall :: forall (pro :: GRpcMessageProtocol) s methodName h.
|
gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package')
|
||||||
(GRpcServiceMethodCall pro s (s :-->: methodName) h)
|
(srvName :: Symbol) (methodName :: Symbol) h pkgName services anns methods.
|
||||||
|
( pkg ~ 'Package ('Just pkgName) services
|
||||||
|
, LookupService services srvName ~ 'Service srvName anns methods
|
||||||
|
, GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h)
|
||||||
=> GrpcClient -> h
|
=> GrpcClient -> h
|
||||||
gRpcCall = gRpcServiceMethodCall (Proxy @pro) (Proxy @s) (Proxy @(s :-->: methodName))
|
gRpcCall
|
||||||
|
= gRpcServiceMethodCall (Proxy @pro) (Proxy @pkgName) (Proxy @srvName)
|
||||||
|
(Proxy @(LookupMethod methods methodName))
|
||||||
|
@ -1,7 +1,9 @@
|
|||||||
name: mu-grpc-common
|
name: mu-grpc-common
|
||||||
version: 0.2.0.0
|
version: 0.2.0.0
|
||||||
synopsis: gRPC for Mu, common modules for client and server
|
synopsis: gRPC for Mu, common modules for client and server
|
||||||
description: Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts).
|
description:
|
||||||
|
Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts).
|
||||||
|
|
||||||
license: Apache-2.0
|
license: Apache-2.0
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Alejandro Serrano, Flavio Corpa
|
author: Alejandro Serrano, Flavio Corpa
|
||||||
|
@ -2,9 +2,9 @@
|
|||||||
{-# language DataKinds #-}
|
{-# language DataKinds #-}
|
||||||
{-# language FlexibleContexts #-}
|
{-# language FlexibleContexts #-}
|
||||||
{-# language FlexibleInstances #-}
|
{-# language FlexibleInstances #-}
|
||||||
{-# language KindSignatures #-}
|
|
||||||
{-# language MultiParamTypeClasses #-}
|
{-# language MultiParamTypeClasses #-}
|
||||||
{-# language OverloadedStrings #-}
|
{-# language OverloadedStrings #-}
|
||||||
|
{-# language PolyKinds #-}
|
||||||
{-# language ScopedTypeVariables #-}
|
{-# language ScopedTypeVariables #-}
|
||||||
{-# language TypeApplications #-}
|
{-# language TypeApplications #-}
|
||||||
{-# language TypeOperators #-}
|
{-# language TypeOperators #-}
|
||||||
@ -34,7 +34,7 @@ import Network.GRPC.HTTP2.Types
|
|||||||
import Data.Monoid ((<>))
|
import Data.Monoid ((<>))
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
import Mu.Adapter.Avro ()
|
import Mu.Adapter.Avro ()
|
||||||
import Mu.Rpc
|
import Mu.Rpc
|
||||||
import Mu.Schema
|
import Mu.Schema
|
||||||
|
|
||||||
@ -45,9 +45,9 @@ instance IsRPC AvroRPC where
|
|||||||
path rpc = "/" <> pkg rpc <> "." <> srv rpc <> "/" <> meth rpc
|
path rpc = "/" <> pkg rpc <> "." <> srv rpc <> "/" <> meth rpc
|
||||||
{-# INLINE path #-}
|
{-# INLINE path #-}
|
||||||
|
|
||||||
newtype ViaFromAvroTypeRef (ref :: TypeRef) t
|
newtype ViaFromAvroTypeRef (ref :: TypeRef snm) t
|
||||||
= ViaFromAvroTypeRef { unViaFromAvroTypeRef :: t }
|
= ViaFromAvroTypeRef { unViaFromAvroTypeRef :: t }
|
||||||
newtype ViaToAvroTypeRef (ref :: TypeRef) t
|
newtype ViaToAvroTypeRef (ref :: TypeRef snm) t
|
||||||
= ViaToAvroTypeRef { unViaToAvroTypeRef :: t }
|
= ViaToAvroTypeRef { unViaToAvroTypeRef :: t }
|
||||||
|
|
||||||
instance GRPCInput AvroRPC () where
|
instance GRPCInput AvroRPC () where
|
||||||
@ -61,21 +61,21 @@ instance GRPCOutput AvroRPC () where
|
|||||||
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
||||||
( FromSchema Identity sch sty i
|
( FromSchema Identity sch sty i
|
||||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||||
=> GRPCInput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) i) where
|
=> GRPCInput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where
|
||||||
encodeInput = error "eif/you should not call this"
|
encodeInput = error "eif/you should not call this"
|
||||||
decodeInput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
decodeInput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
||||||
|
|
||||||
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
instance forall (sch :: Schema') (sty :: Symbol) (i :: Type).
|
||||||
( FromSchema Identity sch sty i
|
( FromSchema Identity sch sty i
|
||||||
, FromAvro (Term Identity sch (sch :/: sty)) )
|
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||||
=> GRPCOutput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) i) where
|
=> GRPCOutput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where
|
||||||
encodeOutput = error "eof/you should not call this"
|
encodeOutput = error "eof/you should not call this"
|
||||||
decodeOutput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
decodeOutput _ i = (ViaFromAvroTypeRef . fromSchema' @_ @_ @sch @Identity <$>) <$> decoder i
|
||||||
|
|
||||||
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
||||||
( ToSchema Identity sch sty o
|
( ToSchema Identity sch sty o
|
||||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||||
=> GRPCInput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) o) where
|
=> GRPCInput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where
|
||||||
encodeInput _ compression
|
encodeInput _ compression
|
||||||
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
||||||
decodeInput = error "dit/you should not call this"
|
decodeInput = error "dit/you should not call this"
|
||||||
@ -83,7 +83,7 @@ instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
|||||||
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
instance forall (sch :: Schema') (sty :: Symbol) (o :: Type).
|
||||||
( ToSchema Identity sch sty o
|
( ToSchema Identity sch sty o
|
||||||
, ToAvro (Term Identity sch (sch :/: sty)) )
|
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||||
=> GRPCOutput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) o) where
|
=> GRPCOutput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where
|
||||||
encodeOutput _ compression
|
encodeOutput _ compression
|
||||||
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
= encoder compression . toSchema' @_ @_ @sch @Identity . unViaToAvroTypeRef
|
||||||
decodeOutput = error "dot/you should not call this"
|
decodeOutput = error "dot/you should not call this"
|
||||||
|
@ -24,6 +24,7 @@ library
|
|||||||
exposed-modules: Mu.GRpc.Server
|
exposed-modules: Mu.GRpc.Server
|
||||||
build-depends:
|
build-depends:
|
||||||
async
|
async
|
||||||
|
, avro >=0.4.7
|
||||||
, base >=4.12 && <5
|
, base >=4.12 && <5
|
||||||
, binary
|
, binary
|
||||||
, bytestring
|
, bytestring
|
||||||
@ -51,6 +52,7 @@ executable grpc-example-server
|
|||||||
other-modules: Mu.GRpc.Server
|
other-modules: Mu.GRpc.Server
|
||||||
build-depends:
|
build-depends:
|
||||||
async
|
async
|
||||||
|
, avro >=0.4.7
|
||||||
, base >=4.12 && <5
|
, base >=4.12 && <5
|
||||||
, binary
|
, binary
|
||||||
, bytestring
|
, bytestring
|
||||||
|
@ -40,10 +40,12 @@ import Control.Concurrent.STM (atomically)
|
|||||||
import Control.Concurrent.STM.TMVar
|
import Control.Concurrent.STM.TMVar
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
|
import Data.Avro
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as BS
|
import qualified Data.ByteString.Char8 as BS
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import Data.Conduit.TMChan
|
import Data.Conduit.TMChan
|
||||||
|
import Data.Functor.Identity
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
|
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
|
||||||
@ -64,22 +66,20 @@ import Mu.Server
|
|||||||
|
|
||||||
-- | Run a Mu 'Server' on the given port.
|
-- | Run a Mu 'Server' on the given port.
|
||||||
runGRpcApp
|
runGRpcApp
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||||
, GRpcMethodHandlers protocol ServerErrorIO methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> Port
|
-> Port
|
||||||
-> ServerT f ('Service name anns methods) ServerErrorIO handlers
|
-> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||||
-> IO ()
|
-> IO ()
|
||||||
runGRpcApp protocol port = runGRpcAppTrans protocol port id
|
runGRpcApp protocol port = runGRpcAppTrans protocol port id
|
||||||
|
|
||||||
-- | Run a Mu 'Server' on the given port.
|
-- | Run a Mu 'Server' on the given port.
|
||||||
runGRpcAppTrans
|
runGRpcAppTrans
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||||
, GRpcMethodHandlers protocol m methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> Port
|
-> Port
|
||||||
-> (forall a. m a -> ServerErrorIO a)
|
-> (forall a. m a -> ServerErrorIO a)
|
||||||
-> ServerT f ('Service name anns methods) m handlers
|
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||||
-> IO ()
|
-> IO ()
|
||||||
runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
||||||
|
|
||||||
@ -87,12 +87,11 @@ runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr)
|
|||||||
--
|
--
|
||||||
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||||
runGRpcAppSettings
|
runGRpcAppSettings
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||||
, GRpcMethodHandlers protocol m methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> Settings
|
-> Settings
|
||||||
-> (forall a. m a -> ServerErrorIO a)
|
-> (forall a. m a -> ServerErrorIO a)
|
||||||
-> ServerT f ('Service name anns methods) m handlers
|
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||||
-> IO ()
|
-> IO ()
|
||||||
runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr)
|
runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr)
|
||||||
|
|
||||||
@ -101,12 +100,11 @@ runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f s
|
|||||||
-- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings'
|
-- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings'
|
||||||
-- and to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
-- and to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||||
runGRpcAppTLS
|
runGRpcAppTLS
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||||
, GRpcMethodHandlers protocol m methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> TLSSettings -> Settings
|
-> TLSSettings -> Settings
|
||||||
-> (forall a. m a -> ServerErrorIO a)
|
-> (forall a. m a -> ServerErrorIO a)
|
||||||
-> ServerT f ('Service name anns methods) m handlers
|
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||||
-> IO ()
|
-> IO ()
|
||||||
runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr)
|
runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr)
|
||||||
|
|
||||||
@ -116,10 +114,9 @@ runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr
|
|||||||
-- for example, @wai-routes@, or you can add middleware
|
-- for example, @wai-routes@, or you can add middleware
|
||||||
-- from @wai-extra@, among others.
|
-- from @wai-extra@, among others.
|
||||||
gRpcApp
|
gRpcApp
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol ServerErrorIO chn services handlers )
|
||||||
, GRpcMethodHandlers protocol ServerErrorIO methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> ServerT f ('Service name anns methods) ServerErrorIO handlers
|
-> ServerT f chn ('Package ('Just name) services) ServerErrorIO handlers
|
||||||
-> Application
|
-> Application
|
||||||
gRpcApp protocol = gRpcAppTrans protocol id
|
gRpcApp protocol = gRpcAppTrans protocol id
|
||||||
|
|
||||||
@ -129,40 +126,58 @@ gRpcApp protocol = gRpcAppTrans protocol id
|
|||||||
-- for example, @wai-routes@, or you can add middleware
|
-- for example, @wai-routes@, or you can add middleware
|
||||||
-- from @wai-extra@, among others.
|
-- from @wai-extra@, among others.
|
||||||
gRpcAppTrans
|
gRpcAppTrans
|
||||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
:: ( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||||
, GRpcMethodHandlers protocol m methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> (forall a. m a -> ServerErrorIO a)
|
-> (forall a. m a -> ServerErrorIO a)
|
||||||
-> ServerT f ('Service name anns methods) m handlers
|
-> ServerT f chn ('Package ('Just name) services) m handlers
|
||||||
-> Application
|
-> Application
|
||||||
gRpcAppTrans protocol f svr
|
gRpcAppTrans protocol f svr
|
||||||
= Wai.grpcApp [uncompressed, gzip]
|
= Wai.grpcApp [uncompressed, gzip]
|
||||||
(gRpcServiceHandlers protocol f svr)
|
(gRpcServerHandlers protocol f svr)
|
||||||
|
|
||||||
gRpcServiceHandlers
|
gRpcServerHandlers
|
||||||
:: forall name anns methods handlers m protocol w.
|
:: forall name services handlers m protocol w chn.
|
||||||
( KnownName name, KnownName (FindPackageName anns)
|
( KnownName name, GRpcServiceHandlers protocol m chn services handlers )
|
||||||
, GRpcMethodHandlers protocol m methods handlers )
|
|
||||||
=> Proxy protocol
|
=> Proxy protocol
|
||||||
-> (forall a. m a -> ServerErrorIO a)
|
-> (forall a. m a -> ServerErrorIO a)
|
||||||
-> ServerT w ('Service name anns methods) m handlers
|
-> ServerT w chn ('Package ('Just name) services) m handlers
|
||||||
-> [ServiceHandler]
|
-> [ServiceHandler]
|
||||||
gRpcServiceHandlers pr f (Server svr) = gRpcMethodHandlers f pr packageName serviceName svr
|
gRpcServerHandlers pr f (Services svr) = gRpcServiceHandlers f pr packageName svr
|
||||||
where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
where packageName = BS.pack (nameVal (Proxy @name))
|
||||||
serviceName = BS.pack (nameVal (Proxy @name))
|
|
||||||
|
class GRpcServiceHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||||
|
(chn :: ServiceChain snm)
|
||||||
|
(ss :: [Service snm mnm]) (hs :: [[Type]]) where
|
||||||
|
gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||||
|
-> Proxy p -> ByteString
|
||||||
|
-> ServicesT f 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
|
||||||
|
where serviceName = BS.pack (nameVal (Proxy @name))
|
||||||
|
|
||||||
|
|
||||||
class GRpcMethodHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
class GRpcMethodHandlers (p :: GRpcMessageProtocol) (m :: Type -> Type)
|
||||||
(ms :: [Method mnm]) (hs :: [Type]) where
|
(chn :: ServiceChain snm) (inh :: Type)
|
||||||
|
(ms :: [Method snm mnm]) (hs :: [Type]) where
|
||||||
gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a)
|
gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a)
|
||||||
-> Proxy p -> ByteString -> ByteString
|
-> Proxy p -> ByteString -> ByteString
|
||||||
-> HandlersT f ms m hs -> [ServiceHandler]
|
-> HandlersT f chn inh ms m hs -> [ServiceHandler]
|
||||||
|
|
||||||
instance GRpcMethodHandlers p m '[] '[] where
|
instance GRpcMethodHandlers p m chn inh '[] '[] where
|
||||||
gRpcMethodHandlers _ _ _ _ H0 = []
|
gRpcMethodHandlers _ _ _ _ H0 = []
|
||||||
instance (KnownName name, GRpcMethodHandler p m args r h, GRpcMethodHandlers p m rest hs, MkRPC p)
|
instance ( KnownName name, MkRPC p
|
||||||
=> GRpcMethodHandlers p m ('Method name anns args r ': rest) (h ': hs) where
|
, GRpcMethodHandler p m args r h
|
||||||
gRpcMethodHandlers f pr p s (h :<|>: rest)
|
, GRpcMethodHandlers p m chn () rest hs)
|
||||||
= gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) h
|
=> 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 f pr p s rest
|
||||||
where methodName = BS.pack (nameVal (Proxy @name))
|
where methodName = BS.pack (nameVal (Proxy @name))
|
||||||
|
|
||||||
@ -195,7 +210,7 @@ raiseErrors h
|
|||||||
= liftIO $ do
|
= liftIO $ do
|
||||||
h' <- runExceptT h
|
h' <- runExceptT h
|
||||||
case h' of
|
case h' of
|
||||||
Right r -> return r
|
Right r -> pure r
|
||||||
Left (ServerError code msg)
|
Left (ServerError code msg)
|
||||||
-> closeEarly $ GRPCStatus (serverErrorToGRpcError code)
|
-> closeEarly $ GRPCStatus (serverErrorToGRpcError code)
|
||||||
(BS.pack msg)
|
(BS.pack msg)
|
||||||
@ -222,7 +237,7 @@ raiseErrors h
|
|||||||
-- the choice of message protocol (PB or Avro)
|
-- the choice of message protocol (PB or Avro)
|
||||||
|
|
||||||
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
class GRPCOutput (RPCTy p) (GRpcOWTy p ref r)
|
||||||
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
=> GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||||
type GRpcOWTy p ref r :: Type
|
type GRpcOWTy p ref r :: Type
|
||||||
buildGRpcOWTy :: Proxy p -> Proxy ref -> r -> GRpcOWTy p ref r
|
buildGRpcOWTy :: Proxy p -> Proxy ref -> r -> GRpcOWTy p ref r
|
||||||
|
|
||||||
@ -231,13 +246,15 @@ instance ToProtoBufTypeRef ref r
|
|||||||
type GRpcOWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
type GRpcOWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r
|
||||||
buildGRpcOWTy _ _ = ViaToProtoBufTypeRef
|
buildGRpcOWTy _ _ = ViaToProtoBufTypeRef
|
||||||
|
|
||||||
instance (GRPCOutput AvroRPC (ViaToAvroTypeRef ('ViaSchema sch sty) r))
|
instance forall (sch :: Schema') sty (r :: Type).
|
||||||
=> GRpcOutputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
( ToSchema Identity sch sty r
|
||||||
type GRpcOWTy 'MsgAvro ('ViaSchema sch sty) r = ViaToAvroTypeRef ('ViaSchema sch sty) r
|
, ToAvro (Term Identity sch (sch :/: sty)) )
|
||||||
|
=> GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||||
|
type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r
|
||||||
buildGRpcOWTy _ _ = ViaToAvroTypeRef
|
buildGRpcOWTy _ _ = ViaToAvroTypeRef
|
||||||
|
|
||||||
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
class GRPCInput (RPCTy p) (GRpcIWTy p ref r)
|
||||||
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef) (r :: Type) where
|
=> GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where
|
||||||
type GRpcIWTy p ref r :: Type
|
type GRpcIWTy p ref r :: Type
|
||||||
unGRpcIWTy :: Proxy p -> Proxy ref -> GRpcIWTy p ref r -> r
|
unGRpcIWTy :: Proxy p -> Proxy ref -> GRpcIWTy p ref r -> r
|
||||||
|
|
||||||
@ -246,9 +263,11 @@ instance FromProtoBufTypeRef ref r
|
|||||||
type GRpcIWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
type GRpcIWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r
|
||||||
unGRpcIWTy _ _ = unViaFromProtoBufTypeRef
|
unGRpcIWTy _ _ = unViaFromProtoBufTypeRef
|
||||||
|
|
||||||
instance (GRPCInput AvroRPC (ViaFromAvroTypeRef ('ViaSchema sch sty) r))
|
instance forall (sch :: Schema') sty (r :: Type).
|
||||||
=> GRpcInputWrapper 'MsgAvro ('ViaSchema sch sty) r where
|
( FromSchema Identity sch sty r
|
||||||
type GRpcIWTy 'MsgAvro ('ViaSchema sch sty) r = ViaFromAvroTypeRef ('ViaSchema sch sty) r
|
, FromAvro (Term Identity sch (sch :/: sty)) )
|
||||||
|
=> GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where
|
||||||
|
type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r
|
||||||
unGRpcIWTy _ _ = unViaFromAvroTypeRef
|
unGRpcIWTy _ _ = unViaFromAvroTypeRef
|
||||||
|
|
||||||
---
|
---
|
||||||
@ -284,10 +303,10 @@ instance (GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO m)
|
|||||||
let readNext _
|
let readNext _
|
||||||
= do nextOutput <- atomically $ takeTMVar var
|
= do nextOutput <- atomically $ takeTMVar var
|
||||||
case nextOutput of
|
case nextOutput of
|
||||||
Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||||
Nothing -> do cancel promise
|
Nothing -> do cancel promise
|
||||||
return Nothing
|
pure Nothing
|
||||||
return ((), ServerStream readNext)
|
pure ((), ServerStream readNext)
|
||||||
|
|
||||||
-----
|
-----
|
||||||
|
|
||||||
@ -330,7 +349,7 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
|||||||
cstreamFinalizer _
|
cstreamFinalizer _
|
||||||
= atomically (closeTMChan chan) >> wait promise
|
= atomically (closeTMChan chan) >> wait promise
|
||||||
-- Return the information
|
-- Return the information
|
||||||
return ((), ClientStream cstreamHandler cstreamFinalizer)
|
pure ((), ClientStream cstreamHandler cstreamFinalizer)
|
||||||
|
|
||||||
-----
|
-----
|
||||||
|
|
||||||
@ -352,10 +371,10 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
|||||||
let readNext _
|
let readNext _
|
||||||
= do nextOutput <- atomically $ takeTMVar var
|
= do nextOutput <- atomically $ takeTMVar var
|
||||||
case nextOutput of
|
case nextOutput of
|
||||||
Just o -> return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||||
Nothing -> do cancel promise
|
Nothing -> do cancel promise
|
||||||
return Nothing
|
pure Nothing
|
||||||
return ((), ServerStream readNext)
|
pure ((), ServerStream readNext)
|
||||||
|
|
||||||
-----
|
-----
|
||||||
|
|
||||||
@ -383,13 +402,13 @@ instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m)
|
|||||||
= do nextOutput <- atomically $ tryTakeTMVar var
|
= do nextOutput <- atomically $ tryTakeTMVar var
|
||||||
case nextOutput of
|
case nextOutput of
|
||||||
Just (Just o) ->
|
Just (Just o) ->
|
||||||
return $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o)
|
||||||
Just Nothing -> do
|
Just Nothing -> do
|
||||||
cancel promise
|
cancel promise
|
||||||
return Nothing
|
pure Nothing
|
||||||
Nothing -> -- no new elements to output
|
Nothing -> -- no new elements to output
|
||||||
readNext ()
|
readNext ()
|
||||||
return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext)
|
pure ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext)
|
||||||
|
|
||||||
-----
|
-----
|
||||||
|
|
||||||
|
@ -12,6 +12,7 @@ packages:
|
|||||||
- grpc/common
|
- grpc/common
|
||||||
- grpc/client
|
- grpc/client
|
||||||
- grpc/server
|
- grpc/server
|
||||||
|
- graphql
|
||||||
- examples/health-check/avro
|
- examples/health-check/avro
|
||||||
- examples/health-check/protobuf
|
- examples/health-check/protobuf
|
||||||
- examples/route-guide
|
- examples/route-guide
|
||||||
@ -34,3 +35,5 @@ extra-deps:
|
|||||||
- hw-kafka-client-3.0.0
|
- hw-kafka-client-3.0.0
|
||||||
- hw-kafka-conduit-2.6.0
|
- hw-kafka-conduit-2.6.0
|
||||||
- HasBigDecimal-0.1.1
|
- HasBigDecimal-0.1.1
|
||||||
|
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||||
|
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||||
|
@ -12,6 +12,7 @@ packages:
|
|||||||
- grpc/common
|
- grpc/common
|
||||||
- grpc/client
|
- grpc/client
|
||||||
- grpc/server
|
- grpc/server
|
||||||
|
- graphql
|
||||||
- examples/health-check/avro
|
- examples/health-check/avro
|
||||||
- examples/health-check/protobuf
|
- examples/health-check/protobuf
|
||||||
- examples/route-guide
|
- examples/route-guide
|
||||||
@ -34,6 +35,8 @@ extra-deps:
|
|||||||
- hw-kafka-client-3.0.0
|
- hw-kafka-client-3.0.0
|
||||||
- hw-kafka-conduit-2.6.0
|
- hw-kafka-conduit-2.6.0
|
||||||
- HasBigDecimal-0.1.1
|
- HasBigDecimal-0.1.1
|
||||||
|
- git: https://github.com/hasura/graphql-parser-hs.git
|
||||||
|
commit: 1380495a7b3269b70a7ab3081d745a5f54171a9c
|
||||||
# missing in the current LTS
|
# missing in the current LTS
|
||||||
- primitive-0.7.0.0
|
- primitive-0.7.0.0
|
||||||
- primitive-extras-0.8
|
- primitive-extras-0.8
|
||||||
|
Loading…
Reference in New Issue
Block a user