diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +# Revision history for acolyte-grpc + +## 0.1.0.0 -- 2026-04-27 + +* Initial release. gRPC interpretation of acolyte-core API types, + built on spire-grpc and spire-protobuf. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2024-2026, Josh Burgess + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/acolyte-grpc.cabal b/acolyte-grpc.cabal new file mode 100644 --- /dev/null +++ b/acolyte-grpc.cabal @@ -0,0 +1,114 @@ +cabal-version: 3.0 +name: acolyte-grpc +version: 0.1.0.0 +synopsis: gRPC interpretation for acolyte API types +category: Network +description: + Interprets acolyte-core API types as gRPC services. + The same API type that drives REST routing, OpenAPI generation, + and type-safe clients also drives gRPC serving. + . + Provides @ToProtoType@ for protobuf-compatible serialization, + @GrpcReady@ for compile-time validation, @.proto@ file generation, + and @mkGrpcServer@ to build a gRPC service from the API type. + +license: BSD-3-Clause +license-file: LICENSE +author: Josh Burgess +maintainer: Josh Burgess +homepage: https://github.com/joshburgess/acolyte +bug-reports: https://github.com/joshburgess/acolyte/issues +build-type: Simple + +extra-doc-files: + CHANGELOG.md + +library + exposed-modules: + Acolyte.Grpc + Acolyte.Grpc.Proto + Acolyte.Grpc.Server + Acolyte.Grpc.Generate + + build-depends: + base >= 4.20 && < 5 + , acolyte-core >= 0.1 && < 0.2 + , acolyte-server >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , spire-grpc >= 0.1 && < 0.2 + , spire-protobuf >= 0.1 && < 0.2 + , http-core >= 0.1 && < 0.2 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , http-types >= 0.12 && < 0.13 + , case-insensitive >= 1.2 && < 1.3 + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + DataKinds + TypeFamilies + TypeOperators + OverloadedStrings + AllowAmbiguousTypes + UndecidableInstances + ScopedTypeVariables + FlexibleInstances + FlexibleContexts + MultiParamTypeClasses + StrictData + + ghc-options: -Wall -funbox-strict-fields + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + DataKinds + TypeFamilies + TypeOperators + OverloadedStrings + AllowAmbiguousTypes + ScopedTypeVariables + FlexibleInstances + StrictData + + ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K" + + build-depends: + base >= 4.20 && < 5 + , acolyte-grpc >= 0.1 && < 0.2 + , acolyte-core >= 0.1 && < 0.2 + , acolyte-server >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , spire-grpc >= 0.1 && < 0.2 + , http-core >= 0.1 && < 0.2 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , http-types >= 0.12 && < 0.13 + , containers >= 0.6 && < 0.8 + +test-suite properties + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + DataKinds + OverloadedStrings + StrictData + ghc-options: -Wall + build-depends: + base >= 4.20 && < 5 + , acolyte-grpc >= 0.1 && < 0.2 + , acolyte-core >= 0.1 && < 0.2 + , acolyte-server >= 0.1 && < 0.2 + , hedgehog >= 1.4 && < 1.8 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + +source-repository head + type: git + location: https://github.com/joshburgess/acolyte.git diff --git a/src/Acolyte/Grpc.hs b/src/Acolyte/Grpc.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Grpc.hs @@ -0,0 +1,55 @@ +-- | @acolyte-grpc@ — gRPC interpretation of API types. +-- +-- The same API type that drives REST routing, OpenAPI generation, +-- and type-safe clients also drives gRPC serving and .proto +-- generation. +-- +-- @ +-- import Acolyte.Core +-- import Acolyte.Grpc +-- import Spire.Grpc (grpcServer) +-- import Spire.Server.H2 (runServerH2, defaultH2Config) +-- +-- type API = '[ Get HealthPath Text +-- , Post UsersPath (Json CreateUser) (Json User) +-- ] +-- +-- main = do +-- let services = mkGrpcServiceMap @API "myapp" "MySvc" +-- (healthHandler, createUserHandler) +-- runServerH2 (defaultH2Config 50051) (grpcServer services) +-- @ +module Acolyte.Grpc + ( -- * Serialization + GrpcCodec (..) + , ProtoMessageName (..) + + -- * Compile-time validation + , GrpcReady + , AllGrpcReady + + -- * Proto metadata + , ProtoField (..) + , ProtoFieldType (..) + , HasProtoFields (..) + + -- * Server construction + , mkGrpcServiceMap + , GrpcHandlerFn + , BuildGrpcHandlers (..) + + -- * .proto generation + , generateProto + , generateProtoFull + , ApiToProtoMethods (..) + , ProtoMethod (..) + , MessageDef (..) + , renderMessage + , renderFieldType + , CollectMessageDefs (..) + , CollectTypeDef (..) + ) where + +import Acolyte.Grpc.Proto +import Acolyte.Grpc.Server +import Acolyte.Grpc.Generate diff --git a/src/Acolyte/Grpc/Generate.hs b/src/Acolyte/Grpc/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Grpc/Generate.hs @@ -0,0 +1,373 @@ +-- | Generate @.proto@ files from acolyte API types. +-- +-- @ +-- import Acolyte.Grpc.Generate +-- +-- protoFile :: Text +-- protoFile = generateProto @MyAPI "mypackage" "MyService" +-- @ +module Acolyte.Grpc.Generate + ( -- * Proto generation + generateProto + , generateProtoFull + -- * Message definitions + , MessageDef (..) + , renderMessage + , renderFieldType + -- * Collecting message defs from API types + , CollectMessageDefs (..) + , CollectTypeDef (..) + -- * Type class + , ApiToProtoMethods (..) + , ProtoMethod (..) + ) where + +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.Proxy (Proxy (..)) + +import Acolyte.Core.Endpoint (Endpoint, NoBody) +import Acolyte.Core.Path (PathSegment(..)) +import Acolyte.Core.Effect (Requires) +import Acolyte.Core.Wrapper + ( Describe, WithParams, WithHeaders + , ServerStream, ClientStream, BidiStream, RespondsWith + ) +import Acolyte.Grpc.Proto (ProtoMessageName(..), ProtoField(..), ProtoFieldType(..)) +import Acolyte.Server.Response (Json) + + +-- | A proto service method descriptor. +data ProtoMethod = ProtoMethod + { pmName :: !Text -- ^ PascalCase method name + , pmInputType :: !Text -- ^ input message type name + , pmOutputType :: !Text -- ^ output message type name + } deriving (Show, Eq) + + +-- | A complete proto message definition (name + fields). +data MessageDef = MessageDef + { mdName :: !Text + , mdFields :: ![ProtoField] + } deriving (Show, Eq) + + +-- | Render a 'ProtoFieldType' to its proto3 text representation. +renderFieldType :: ProtoFieldType -> Text +renderFieldType ProtoInt32 = "int32" +renderFieldType ProtoInt64 = "int64" +renderFieldType ProtoUInt32 = "uint32" +renderFieldType ProtoUInt64 = "uint64" +renderFieldType ProtoDouble = "double" +renderFieldType ProtoFloat = "float" +renderFieldType ProtoBool = "bool" +renderFieldType ProtoString = "string" +renderFieldType ProtoBytes = "bytes" +renderFieldType (ProtoMessage name) = name +renderFieldType (ProtoRepeated inner) = "repeated " <> renderFieldType inner +renderFieldType (ProtoOptional inner) = "optional " <> renderFieldType inner + + +-- | Render a 'MessageDef' to proto3 text. +-- +-- @ +-- message User { +-- string name = 1; +-- string email = 2; +-- int64 id = 3; +-- } +-- @ +renderMessage :: MessageDef -> Text +renderMessage (MessageDef name fields) = + T.unlines $ + [ "message " <> name <> " {" ] ++ + [ " " <> renderFieldType (pfType f) <> " " <> pfName f <> " = " <> T.pack (show (pfNumber f)) <> ";" + | f <- fields + ] ++ + [ "}" ] + + +-- | Generate a complete @.proto@ file with explicit message definitions. +generateProtoFull + :: forall api + . ApiToProtoMethods api + => Text -- ^ package name + -> Text -- ^ service name + -> [MessageDef] -- ^ message definitions + -> Text -- ^ .proto file content +generateProtoFull pkg svc msgs = + let methods = apiToProtoMethods @api + needsEmpty = any (\m -> pmInputType m == "Empty") methods + emptyImport = if needsEmpty + then [ "import \"google/protobuf/empty.proto\";", "" ] + else [] + in T.unlines $ + [ "syntax = \"proto3\";" + , "" + ] ++ + emptyImport ++ + [ "package " <> pkg <> ";" + , "" + , "service " <> svc <> " {" + ] ++ + [ " rpc " <> pmName m <> " (" <> pmInputType m <> ") returns (" <> pmOutputType m <> ");" + | m <- methods + ] ++ + [ "}" + ] ++ + (if null msgs then [] + else "" : concatMap (\msg -> [renderMessage msg]) msgs) + + +-- | Generate a @.proto@ file from an API type. +-- +-- @ +-- generateProto @MyAPI "mypackage" "UserService" +-- @ +-- +-- When the API's request\/response types have 'HasProtoFields' and +-- 'ProtoMessageName' instances, full message definitions are emitted. +-- Otherwise, commented stubs are produced. +generateProto + :: forall api + . (ApiToProtoMethods api, CollectMessageDefs api) + => Text -- ^ package name + -> Text -- ^ service name + -> Text -- ^ .proto file content +generateProto pkg svc = + let methods = apiToProtoMethods @api + collected = collectMessageDefs @api + needsEmpty = any (\m -> pmInputType m == "Empty") methods + emptyImport = if needsEmpty + then [ "import \"google/protobuf/empty.proto\";", "" ] + else [] + in T.unlines $ + [ "syntax = \"proto3\";" + , "" + ] ++ + emptyImport ++ + [ "package " <> pkg <> ";" + , "" + , "service " <> svc <> " {" + ] ++ + [ " rpc " <> pmName m <> " (" <> pmInputType m <> ") returns (" <> pmOutputType m <> ");" + | m <- methods + ] ++ + [ "}" ] ++ + (if null collected + then + [ "" + , "// Message definitions (generate from HasProtoFields or write manually):" + ] ++ + [ "// message " <> t <> " { ... }" + | t <- uniqueTypes methods + ] + else "" : concatMap (\msg -> [renderMessage msg]) (dedupMsgs collected)) + + +-- | Deduplicate message definitions by name. +dedupMsgs :: [MessageDef] -> [MessageDef] +dedupMsgs = go [] + where + go _ [] = [] + go seen (m:ms) + | mdName m `elem` seen = go seen ms + | otherwise = m : go (mdName m : seen) ms + + +-- | Collect unique type names from methods. +uniqueTypes :: [ProtoMethod] -> [Text] +uniqueTypes methods = + let allTypes = concatMap (\m -> [pmInputType m, pmOutputType m]) methods + noDups [] = [] + noDups (x:xs) + | x `elem` xs = noDups xs + | x == "Empty" = noDups xs + | otherwise = x : noDups xs + in noDups allTypes + + +-- | Walk the API type and extract proto method descriptors. +class ApiToProtoMethods (api :: [Type]) where + apiToProtoMethods :: [ProtoMethod] + +instance ApiToProtoMethods '[] where + apiToProtoMethods = [] + +instance (EndpointProtoMethod e, ApiToProtoMethods rest) + => ApiToProtoMethods (e ': rest) where + apiToProtoMethods = endpointProtoMethod @e : apiToProtoMethods @rest + + +-- | Extract a proto method from a single endpoint type. +class EndpointProtoMethod (e :: Type) where + endpointProtoMethod :: ProtoMethod + +instance EndpointProtoMethod inner => EndpointProtoMethod (Requires eff inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (Describe desc inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (WithParams ps inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (WithHeaders hs inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (ServerStream inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (ClientStream inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (BidiStream inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance EndpointProtoMethod inner => EndpointProtoMethod (RespondsWith s inner) where + endpointProtoMethod = endpointProtoMethod @inner + +instance {-# OVERLAPPING #-} (PathToMethodName path, ResponseTypeName resp) + => EndpointProtoMethod (Endpoint m path NoBody resp) where + endpointProtoMethod = ProtoMethod + { pmName = pathToMethodName @path + , pmInputType = "Empty" + , pmOutputType = responseTypeName @resp + } + +instance (PathToMethodName path, RequestTypeName req, ResponseTypeName resp) + => EndpointProtoMethod (Endpoint m path req resp) where + endpointProtoMethod = ProtoMethod + { pmName = pathToMethodName @path + , pmInputType = requestTypeName @req + , pmOutputType = responseTypeName @resp + } + + +-- | Get the proto type name for a response type. +class ResponseTypeName (a :: Type) where + responseTypeName :: Text + +instance ProtoMessageName a => ResponseTypeName (Json a) where + responseTypeName = protoMessageName @a + +instance {-# OVERLAPPABLE #-} ProtoMessageName a => ResponseTypeName a where + responseTypeName = protoMessageName @a + + +-- | Get the proto type name for a request type. +class RequestTypeName (a :: Type) where + requestTypeName :: Text + +instance ProtoMessageName a => RequestTypeName (Json a) where + requestTypeName = protoMessageName @a + +instance {-# OVERLAPPABLE #-} ProtoMessageName a => RequestTypeName a where + requestTypeName = protoMessageName @a + + +-- | Convert a type-level path to a PascalCase gRPC method name. +class PathToMethodName (path :: [PathSegment]) where + pathToMethodName :: Text + +instance PathToMethodName '[] where + pathToMethodName = "Unknown" + +instance (KnownSymbol s, PathToMethodName rest) + => PathToMethodName ('Lit s ': rest) where + pathToMethodName = capitalize (T.pack (symbolVal (Proxy @s))) + +instance PathToMethodName rest + => PathToMethodName ('Capture t ': rest) where + pathToMethodName = pathToMethodName @rest + + +capitalize :: Text -> Text +capitalize t = case T.uncons t of + Just (c, rest) -> T.cons (toUpper c) rest + Nothing -> t + where + toUpper c + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) + | otherwise = c + + +-- =================================================================== +-- CollectMessageDefs: walk API and gather MessageDefs +-- =================================================================== + +-- | Walk an API type list and collect 'MessageDef' for every +-- request\/response type that has both 'ProtoMessageName' and +-- 'HasProtoFields' instances. +class CollectMessageDefs (api :: [Type]) where + collectMessageDefs :: [MessageDef] + +instance CollectMessageDefs '[] where + collectMessageDefs = [] + +instance (CollectEndpointDefs e, CollectMessageDefs rest) + => CollectMessageDefs (e ': rest) where + collectMessageDefs = collectEndpointDefs @e ++ collectMessageDefs @rest + + +-- | Collect message defs from a single endpoint. +class CollectEndpointDefs (e :: Type) where + collectEndpointDefs :: [MessageDef] + +instance CollectEndpointDefs inner => CollectEndpointDefs (Requires eff inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (Describe desc inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (WithParams ps inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (WithHeaders hs inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (ServerStream inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (ClientStream inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (BidiStream inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance CollectEndpointDefs inner => CollectEndpointDefs (RespondsWith s inner) where + collectEndpointDefs = collectEndpointDefs @inner + +instance {-# OVERLAPPING #-} (CollectTypeDef resp) + => CollectEndpointDefs (Endpoint m path NoBody resp) where + collectEndpointDefs = collectTypeDef @resp + +instance (CollectTypeDef req, CollectTypeDef resp) + => CollectEndpointDefs (Endpoint m path req resp) where + collectEndpointDefs = collectTypeDef @req ++ collectTypeDef @resp + + +-- | Collect a 'MessageDef' from a single type, if it has the +-- required instances. The base instance returns @[]@. +class CollectTypeDef (a :: Type) where + collectTypeDef :: [MessageDef] + +-- | Json wrapper: delegate to inner type. +instance CollectTypeDef inner => CollectTypeDef (Json inner) where + collectTypeDef = collectTypeDef @inner + +-- | Default: no message def available. +instance {-# OVERLAPPABLE #-} CollectTypeDef a where + collectTypeDef = [] + +-- | Types with both 'ProtoMessageName' and 'HasProtoFields' produce +-- a 'MessageDef'. Users opt in by providing an overlapping instance. +-- +-- To collect message defs for your type, add: +-- +-- @ +-- instance {-# OVERLAPPING #-} CollectTypeDef MyType where +-- collectTypeDef = [MessageDef (protoMessageName @MyType) (protoFields @MyType)] +-- @ diff --git a/src/Acolyte/Grpc/Proto.hs b/src/Acolyte/Grpc/Proto.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Grpc/Proto.hs @@ -0,0 +1,181 @@ +-- | Protobuf compatibility types and compile-time validation. +-- +-- 'ToProtoType' declares that a Haskell type can be serialized to +-- protobuf wire format. 'GrpcReady' checks at compile time that +-- every request/response type in the API has this capability. +-- +-- Serialization is pluggable — implement 'ToProtoType' with +-- proto-lens, binary, manual encoding, or any codec. The gRPC +-- layer only needs 'encode' and 'decode' on 'ByteString'. +module Acolyte.Grpc.Proto + ( -- * Serialization class + GrpcCodec (..) + -- * Proto type metadata + , ProtoMessageName (..) + -- * Compile-time validation + , GrpcReady + , AllGrpcReady + -- * Proto field metadata (for .proto generation) + , ProtoField (..) + , ProtoFieldType (..) + , HasProtoFields (..) + ) where + +import Data.ByteString (ByteString) +import Data.Kind (Type, Constraint) +import Data.Text (Text) +import GHC.TypeLits (TypeError, ErrorMessage (..)) + +import qualified Spire.Protobuf + +import Acolyte.Core.Endpoint (Endpoint, NoBody) +import Acolyte.Core.Effect (Requires) +import Acolyte.Server.Response (Json) + + +-- | Encode and decode values to/from protobuf-compatible bytes. +-- +-- This is deliberately minimal — no proto-lens dependency, no +-- code generation requirement. Implement it however you like: +-- +-- @ +-- instance GrpcCodec MyMessage where +-- grpcEncode msg = ... -- your serialization +-- grpcDecode bs = ... -- your deserialization +-- +-- -- With proto-lens: +-- instance GrpcCodec MyProtoMessage where +-- grpcEncode = encodeMessage +-- grpcDecode = decodeMessage +-- +-- -- With aeson (for grpc+json): +-- instance GrpcCodec MyType where +-- grpcEncode = LBS.toStrict . Aeson.encode +-- grpcDecode = Aeson.decodeStrict' +-- @ +class GrpcCodec a where + grpcEncode :: a -> ByteString + grpcDecode :: ByteString -> Maybe a + +-- | Any 'Spire.Protobuf.ProtoMessage' automatically gets 'GrpcCodec'. +-- Users who derive 'ProtoMessage' get gRPC for free -- no separate +-- 'GrpcCodec' instance needed. +instance {-# OVERLAPPABLE #-} Spire.Protobuf.ProtoMessage a => GrpcCodec a where + grpcEncode = Spire.Protobuf.encode + grpcDecode = either (const Nothing) Just . Spire.Protobuf.decode + + +-- | The protobuf message name for .proto generation. +-- +-- @ +-- instance ProtoMessageName User where +-- protoMessageName = "User" +-- @ +class ProtoMessageName a where + protoMessageName :: Text + + +-- | A field in a proto message (for .proto file generation). +data ProtoField = ProtoField + { pfName :: !Text + , pfNumber :: !Int + , pfType :: !ProtoFieldType + } deriving (Show, Eq) + + +-- | Proto scalar types. +data ProtoFieldType + = ProtoInt32 + | ProtoInt64 + | ProtoUInt32 + | ProtoUInt64 + | ProtoDouble + | ProtoFloat + | ProtoBool + | ProtoString + | ProtoBytes + | ProtoMessage !Text -- ^ nested message by name + | ProtoRepeated !ProtoFieldType + | ProtoOptional !ProtoFieldType + deriving (Show, Eq) + + +-- | Declare the fields of a proto message (for .proto generation). +class HasProtoFields a where + protoFields :: [ProtoField] + + +-- =================================================================== +-- Compile-time validation: GrpcReady +-- =================================================================== + +-- | Check that all request and response types in an API support +-- gRPC serialization. +-- +-- Missing a 'GrpcCodec' instance? The compiler will report: +-- +-- @ +-- No instance for 'GrpcCodec MyType' +-- arising from a use of 'mkGrpcServiceMap' +-- @ +-- +-- To fix, add: @instance GrpcCodec MyType where ...@ +-- +-- Usage: +-- +-- @ +-- type MyAPI = '[ Get HealthPath Text +-- , Post UsersPath (Json CreateUser) (Json User) +-- ] +-- +-- -- This compiles only if Text, CreateUser, and User all have GrpcCodec. +-- server :: GrpcReady MyAPI => ... +-- @ +type GrpcReady (api :: [Type]) = AllGrpcReady api + + +-- | Walk the API list and check each endpoint's types. +-- +-- Each endpoint's request and response types are individually checked +-- for a 'GrpcCodec' instance. A missing instance produces: +-- +-- @ +-- No instance for 'GrpcCodec SomeType' +-- @ +-- +-- The fix is always the same: add an @instance GrpcCodec SomeType@. +type AllGrpcReady :: [Type] -> Constraint +type family AllGrpcReady (api :: [Type]) :: Constraint where + AllGrpcReady '[] = () + + AllGrpcReady (Endpoint m path NoBody resp ': rest) = + ( AssertGrpcCodec resp + , AllGrpcReady rest + ) + + AllGrpcReady (Endpoint m path req resp ': rest) = + ( AssertGrpcCodec req + , AssertGrpcCodec resp + , AllGrpcReady rest + ) + + -- Requires: delegate to inner endpoint + AllGrpcReady (Requires e inner ': rest) = + ( AllGrpcReady '[inner] + , AllGrpcReady rest + ) + + -- Fallback: skip unknown wrappers + AllGrpcReady (_ ': rest) = AllGrpcReady rest + + +-- | Assert that a type has a GrpcCodec instance. +type AssertGrpcCodec :: Type -> Constraint +type family AssertGrpcCodec (a :: Type) :: Constraint where + -- Json wrapper: check the inner type + AssertGrpcCodec (Json a) = GrpcCodec a + -- Bare types: check directly + AssertGrpcCodec a = GrpcCodec a + + +-- Json imported from Acolyte.Server.Response diff --git a/src/Acolyte/Grpc/Server.hs b/src/Acolyte/Grpc/Server.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Grpc/Server.hs @@ -0,0 +1,184 @@ +-- | Build a gRPC server from a acolyte API type. +-- +-- The same API type that drives REST routing also drives gRPC: +-- +-- @ +-- type API = '[ Get HealthPath Text +-- , Post UsersPath (Json CreateUser) (Json User) +-- ] +-- +-- -- REST server (existing): +-- restServer = mkServer @API restHandlers +-- +-- -- gRPC server (new): +-- grpcSvc = grpcServer (mkGrpcServiceMap @API "mypackage" "MyService" grpcHandlers) +-- @ +module Acolyte.Grpc.Server + ( -- * Service map construction + mkGrpcServiceMap + -- * Handler types + , GrpcHandlerFn + -- * Type class for building + , BuildGrpcHandlers (..) + ) where + +import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.Proxy (Proxy (..)) + +import Acolyte.Core.Method (KnownMethod, methodVal, Method(..)) +import Acolyte.Core.Path (PathSegment(..)) +import Acolyte.Core.Endpoint (Endpoint, NoBody) +import Acolyte.Core.Effect (Requires) +import Acolyte.Core.Wrapper + ( Describe, WithParams, WithHeaders + , ServerStream, ClientStream, BidiStream, RespondsWith + ) + +import Spire.Grpc (GrpcServiceMap, GrpcHandler(..), GrpcRequest(..), GrpcResponse(..), grpcServiceMap, grpcOk, grpcInternal, unaryHandler) +import Spire.Grpc.Codec (encodeMessage, decodeMessage, GrpcMessage(..)) + +import Acolyte.Grpc.Proto (GrpcCodec(..)) + + +-- | A gRPC handler function: takes raw request bytes, returns raw response bytes. +type GrpcHandlerFn = ByteString -> IO (Either Text ByteString) + + +-- | Build a gRPC service map from an API type. +-- +-- @ +-- let services = mkGrpcServiceMap @MyAPI "pkg" "MySvc" +-- (handler1, handler2, handler3) +-- @ +-- +-- Each handler in the tuple is a 'GrpcHandlerFn'. The API type +-- determines method names from endpoint paths. +mkGrpcServiceMap + :: forall api handlers + . BuildGrpcHandlers api handlers + => Text -- ^ package name (e.g. "myapp") + -> Text -- ^ service name (e.g. "UserService") + -> handlers -- ^ tuple of GrpcHandlerFn + -> GrpcServiceMap +mkGrpcServiceMap pkg svc handlers = + let serviceName = pkg <> "." <> svc + entries = buildGrpcHandlers @api handlers + in grpcServiceMap + [ (serviceName, methodName, mkHandler fn) + | (methodName, fn) <- entries + ] + where + mkHandler fn = unaryHandler $ \reqBytes -> do + result <- fn reqBytes + case result of + Right resp -> pure (Right resp) + Left err -> pure (Left (grpcInternal err)) + + +-- | Type class to walk the API and extract method names + handlers. +class BuildGrpcHandlers (api :: [Type]) handlers where + buildGrpcHandlers :: handlers -> [(Text, GrpcHandlerFn)] + + +-- Arity 1 +instance EndpointMethodName e => BuildGrpcHandlers '[e] GrpcHandlerFn where + buildGrpcHandlers h = [(endpointMethodName @e, h)] + +-- Arity 2 +instance (EndpointMethodName e1, EndpointMethodName e2) + => BuildGrpcHandlers '[e1, e2] (GrpcHandlerFn, GrpcHandlerFn) where + buildGrpcHandlers (h1, h2) = + [ (endpointMethodName @e1, h1) + , (endpointMethodName @e2, h2) + ] + +-- Arity 3 +instance (EndpointMethodName e1, EndpointMethodName e2, EndpointMethodName e3) + => BuildGrpcHandlers '[e1, e2, e3] (GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn) where + buildGrpcHandlers (h1, h2, h3) = + [ (endpointMethodName @e1, h1) + , (endpointMethodName @e2, h2) + , (endpointMethodName @e3, h3) + ] + +-- Arity 4 +instance (EndpointMethodName e1, EndpointMethodName e2, EndpointMethodName e3, EndpointMethodName e4) + => BuildGrpcHandlers '[e1, e2, e3, e4] (GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn) where + buildGrpcHandlers (h1, h2, h3, h4) = + [ (endpointMethodName @e1, h1), (endpointMethodName @e2, h2) + , (endpointMethodName @e3, h3), (endpointMethodName @e4, h4) + ] + +-- Arity 5 +instance (EndpointMethodName e1, EndpointMethodName e2, EndpointMethodName e3, EndpointMethodName e4, EndpointMethodName e5) + => BuildGrpcHandlers '[e1, e2, e3, e4, e5] (GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn, GrpcHandlerFn) where + buildGrpcHandlers (h1, h2, h3, h4, h5) = + [ (endpointMethodName @e1, h1), (endpointMethodName @e2, h2) + , (endpointMethodName @e3, h3), (endpointMethodName @e4, h4) + , (endpointMethodName @e5, h5) + ] + + +-- | Extract a gRPC method name from an endpoint type. +-- +-- Uses the first path literal as the method name. +-- E.g., @Get '[ 'Lit "health" ] Text@ -> "Health" +-- E.g., @Post '[ 'Lit "users" ] req resp@ -> "Users" +class EndpointMethodName (e :: Type) where + endpointMethodName :: Text + +instance EndpointMethodName inner => EndpointMethodName (Requires e inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (Describe desc inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (WithParams ps inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (WithHeaders hs inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (ServerStream inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (ClientStream inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (BidiStream inner) where + endpointMethodName = endpointMethodName @inner + +instance EndpointMethodName inner => EndpointMethodName (RespondsWith s inner) where + endpointMethodName = endpointMethodName @inner + +instance PathToMethodName path => EndpointMethodName (Endpoint m path req resp) where + endpointMethodName = pathToMethodName @path + + +-- | Convert a type-level path to a PascalCase gRPC method name. +class PathToMethodName (path :: [PathSegment]) where + pathToMethodName :: Text + +instance PathToMethodName '[] where + pathToMethodName = "Unknown" + +instance (KnownSymbol s, PathToMethodName rest) => PathToMethodName ('Lit s ': rest) where + pathToMethodName = capitalize (T.pack (symbolVal (Proxy @s))) + +instance PathToMethodName rest => PathToMethodName ('Capture t ': rest) where + pathToMethodName = pathToMethodName @rest + + +-- | Capitalize the first letter of a text value. +capitalize :: Text -> Text +capitalize t = case T.uncons t of + Just (c, rest) -> T.cons (toUpper c) rest + Nothing -> t + where + toUpper c + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) + | otherwise = c diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Map.Strict as Map + +import Acolyte.Core +import Acolyte.Server (Json) +import Acolyte.Grpc + + +-- =================================================================== +-- Test types +-- =================================================================== + +data HealthStatus = HealthStatus !Text +data CreateUserReq = CreateUserReq !Text + deriving (Eq, Show) +data User = User !Text + deriving (Eq, Show) +data Article = Article !Text + +instance GrpcCodec HealthStatus where + grpcEncode (HealthStatus t) = encodeUtf8 t + grpcDecode bs = Just (HealthStatus (decodeUtf8 bs)) + +instance GrpcCodec CreateUserReq where + grpcEncode (CreateUserReq t) = encodeUtf8 t + grpcDecode bs = Just (CreateUserReq (decodeUtf8 bs)) + +instance GrpcCodec User where + grpcEncode (User t) = encodeUtf8 t + grpcDecode bs = Just (User (decodeUtf8 bs)) + +instance GrpcCodec Article where + grpcEncode (Article t) = encodeUtf8 t + grpcDecode bs = Just (Article (decodeUtf8 bs)) + +instance GrpcCodec Text where + grpcEncode = encodeUtf8 + grpcDecode = Just . decodeUtf8 + +instance ProtoMessageName HealthStatus where + protoMessageName = "HealthStatus" + +instance ProtoMessageName CreateUserReq where + protoMessageName = "CreateUserReq" + +instance ProtoMessageName User where + protoMessageName = "User" + +instance ProtoMessageName Article where + protoMessageName = "Article" + +instance ProtoMessageName Text where + protoMessageName = "StringValue" + +-- HasProtoFields instances for full message generation +instance HasProtoFields User where + protoFields = + [ ProtoField "name" 1 ProtoString + , ProtoField "id" 2 ProtoInt64 + ] + +instance HasProtoFields CreateUserReq where + protoFields = + [ ProtoField "name" 1 ProtoString + ] + +instance HasProtoFields Article where + protoFields = + [ ProtoField "title" 1 ProtoString + , ProtoField "body" 2 ProtoString + , ProtoField "author" 3 (ProtoMessage "User") + ] + +-- CollectTypeDef instances to enable automatic collection +instance {-# OVERLAPPING #-} CollectTypeDef User where + collectTypeDef = [MessageDef (protoMessageName @User) (protoFields @User)] + +instance {-# OVERLAPPING #-} CollectTypeDef CreateUserReq where + collectTypeDef = [MessageDef (protoMessageName @CreateUserReq) (protoFields @CreateUserReq)] + +instance {-# OVERLAPPING #-} CollectTypeDef Article where + collectTypeDef = [MessageDef (protoMessageName @Article) (protoFields @Article)] + +-- helpers +encodeUtf8 :: Text -> ByteString +encodeUtf8 = BS.pack . map (fromIntegral . fromEnum) . T.unpack + +decodeUtf8 :: ByteString -> Text +decodeUtf8 = T.pack . map (toEnum . fromIntegral) . BS.unpack + + +-- =================================================================== +-- Test API +-- =================================================================== + +type HealthPath = '[ 'Lit "health" ] +type UsersPath = '[ 'Lit "users" ] +type ArticlesPath = '[ 'Lit "articles" ] + +type TestAPI = + '[ Get HealthPath Text + , Post UsersPath (Json CreateUserReq) (Json User) + ] + + +-- =================================================================== +-- Three-endpoint API +-- =================================================================== + +type ThreeAPI = + '[ Get HealthPath Text + , Post UsersPath (Json CreateUserReq) (Json User) + , Get ArticlesPath (Json Article) + ] + + +-- =================================================================== +-- Capture-containing path API +-- =================================================================== + +type UserByIdPath = '[ 'Lit "users", 'Capture Int ] + +type CaptureAPI = + '[ Get UserByIdPath (Json User) + ] + + +-- =================================================================== +-- Helpers +-- =================================================================== + +assert :: String -> Bool -> IO () +assert msg True = putStrLn $ " OK: " ++ msg +assert msg False = error $ "FAIL: " ++ msg + + +-- =================================================================== +-- Tests +-- =================================================================== + +testBuildGrpcHandlers :: IO () +testBuildGrpcHandlers = do + putStrLn "BuildGrpcHandlers:" + + let svcMap = mkGrpcServiceMap @TestAPI "test" "TestSvc" + ( healthHandler + , createUserHandler + ) + -- Check the service map has 2 entries + assert "2 methods" (Map.size svcMap == 2) + assert "has Health" (Map.member ("test.TestSvc", "Health") svcMap) + assert "has Users" (Map.member ("test.TestSvc", "Users") svcMap) + + where + healthHandler :: GrpcHandlerFn + healthHandler _req = pure $ Right "ok" + + createUserHandler :: GrpcHandlerFn + createUserHandler req = pure $ Right ("created:" <> req) + + +testProtoGeneration :: IO () +testProtoGeneration = do + putStrLn "\nProto generation:" + + let proto = generateProto @TestAPI "test" "TestSvc" + assert "has syntax" (T.isInfixOf "syntax = \"proto3\"" proto) + assert "has package" (T.isInfixOf "package test;" proto) + assert "has service" (T.isInfixOf "service TestSvc {" proto) + assert "has Health rpc" (T.isInfixOf "rpc Health" proto) + assert "has Users rpc" (T.isInfixOf "rpc Users" proto) + assert "has Empty input" (T.isInfixOf "(Empty)" proto) + assert "has User output" (T.isInfixOf "User)" proto) + + +type EffectAPI = + '[ Requires Auth (Get HealthPath Text) + , Post UsersPath (Json CreateUserReq) (Json User) + ] + +testEffectDelegation :: IO () +testEffectDelegation = do + putStrLn "\nEffect delegation:" + + let svcMap = mkGrpcServiceMap @EffectAPI "test" "EffSvc" + ( healthH, createH ) + assert "effect: 2 methods" (Map.size svcMap == 2) + assert "effect: has Health" (Map.member ("test.EffSvc", "Health") svcMap) + + where + healthH :: GrpcHandlerFn + healthH _ = pure $ Right "ok" + createH :: GrpcHandlerFn + createH _ = pure $ Right "created" + + +-- =================================================================== +-- 1. Multi-endpoint API (3 endpoints) +-- =================================================================== + +testThreeEndpointAPI :: IO () +testThreeEndpointAPI = do + putStrLn "\nThree-endpoint API:" + + let svcMap = mkGrpcServiceMap @ThreeAPI "test" "ThreeSvc" + ( healthH, createH, articlesH ) + assert "3 methods" (Map.size svcMap == 3) + assert "has Health" (Map.member ("test.ThreeSvc", "Health") svcMap) + assert "has Users" (Map.member ("test.ThreeSvc", "Users") svcMap) + assert "has Articles" (Map.member ("test.ThreeSvc", "Articles") svcMap) + + where + healthH :: GrpcHandlerFn + healthH _ = pure $ Right "ok" + createH :: GrpcHandlerFn + createH _ = pure $ Right "created" + articlesH :: GrpcHandlerFn + articlesH _ = pure $ Right "article" + + +-- =================================================================== +-- 2. GrpcCodec roundtrip +-- =================================================================== + +testGrpcCodecRoundtrip :: IO () +testGrpcCodecRoundtrip = do + putStrLn "\nGrpcCodec roundtrip:" + + let user = User "alice" + encoded = grpcEncode user + decoded = grpcDecode encoded :: Maybe User + assert "User roundtrip" (decoded == Just user) + + let req = CreateUserReq "bob" + encodedReq = grpcEncode req + decodedReq = grpcDecode encodedReq :: Maybe CreateUserReq + assert "CreateUserReq roundtrip" (decodedReq == Just req) + + let txt = "hello world" :: Text + encodedTxt = grpcEncode txt + decodedTxt = grpcDecode encodedTxt :: Maybe Text + assert "Text roundtrip" (decodedTxt == Just txt) + + -- Empty bytestring roundtrip + let empty = "" :: Text + encodedEmpty = grpcEncode empty + decodedEmpty = grpcDecode encodedEmpty :: Maybe Text + assert "empty Text roundtrip" (decodedEmpty == Just empty) + + +-- =================================================================== +-- 3. Capture-containing paths +-- =================================================================== + +testCapturePaths :: IO () +testCapturePaths = do + putStrLn "\nCapture-containing paths:" + + -- Get '[ 'Lit "users", 'Capture Int ] (Json User) + -- Should produce method name "Users" (capture is skipped) + let svcMap = mkGrpcServiceMap @CaptureAPI "test" "CapSvc" + captureH + assert "capture: 1 method" (Map.size svcMap == 1) + assert "capture: has Users" (Map.member ("test.CapSvc", "Users") svcMap) + + where + captureH :: GrpcHandlerFn + captureH _ = pure $ Right "user-by-id" + + +-- =================================================================== +-- 4. Proto generation completeness (3-endpoint API) +-- =================================================================== + +testProtoCompleteness :: IO () +testProtoCompleteness = do + putStrLn "\nProto generation completeness:" + + let proto = generateProto @ThreeAPI "test" "ThreeSvc" + protoLines = T.lines proto + rpcLines = filter (T.isInfixOf "rpc ") protoLines + + assert "exactly 3 rpc lines" (length rpcLines == 3) + + -- Verify each rpc line has the expected input/output types + assert "Health: (Empty) returns (StringValue)" + (any (\l -> T.isInfixOf "rpc Health" l + && T.isInfixOf "(Empty)" l + && T.isInfixOf "(StringValue)" l) rpcLines) + + assert "Users: (CreateUserReq) returns (User)" + (any (\l -> T.isInfixOf "rpc Users" l + && T.isInfixOf "(CreateUserReq)" l + && T.isInfixOf "(User)" l) rpcLines) + + assert "Articles: (Empty) returns (Article)" + (any (\l -> T.isInfixOf "rpc Articles" l + && T.isInfixOf "(Empty)" l + && T.isInfixOf "(Article)" l) rpcLines) + + +-- =================================================================== +-- 5. GrpcReady negative test (commented out) +-- =================================================================== + +-- The following block demonstrates that an API containing a type +-- without a GrpcCodec instance will fail at compile time. +-- +-- data NoCodecType = NoCodecType +-- +-- instance ProtoMessageName NoCodecType where +-- protoMessageName = "NoCodecType" +-- +-- type BadAPI = '[ Get HealthPath NoCodecType ] +-- +-- testBadAPI :: GrpcReady BadAPI => IO () +-- testBadAPI = pure () +-- +-- Expected compile error: +-- No instance for 'GrpcCodec NoCodecType' +-- arising from a use of 'GrpcReady' +-- +-- This confirms that GrpcReady catches missing GrpcCodec instances +-- at compile time, preventing runtime serialization failures. + + +-- =================================================================== +-- 6. Proto generation for endpoint with request body +-- =================================================================== + +type PostUserAPI = '[ Post UsersPath (Json CreateUserReq) (Json User) ] + +testProtoWithRequestBody :: IO () +testProtoWithRequestBody = do + putStrLn "\nProto generation for endpoint with request body:" + + -- Post UsersPath (Json CreateUserReq) (Json User) + -- Should generate: rpc Users (CreateUserReq) returns (User); + let proto = generateProto @PostUserAPI "test" "PostSvc" + protoLines = T.lines proto + rpcLines = filter (T.isInfixOf "rpc ") protoLines + + assert "exactly 1 rpc line" (length rpcLines == 1) + assert "rpc Users (CreateUserReq) returns (User);" + (any (T.isInfixOf "rpc Users (CreateUserReq) returns (User);") rpcLines) + + +-- =================================================================== +-- 7. Proto generation for bodyless endpoint +-- =================================================================== + +type GetHealthAPI = '[ Get HealthPath Text ] + +testProtoBodyless :: IO () +testProtoBodyless = do + putStrLn "\nProto generation for bodyless endpoint:" + + -- Get HealthPath Text + -- Should generate: rpc Health (Empty) returns (StringValue); + let proto = generateProto @GetHealthAPI "test" "HealthSvc" + protoLines = T.lines proto + rpcLines = filter (T.isInfixOf "rpc ") protoLines + + assert "exactly 1 rpc line" (length rpcLines == 1) + assert "rpc Health (Empty) returns (StringValue);" + (any (T.isInfixOf "rpc Health (Empty) returns (StringValue);") rpcLines) + + +-- =================================================================== +-- 8. renderFieldType +-- =================================================================== + +testRenderFieldType :: IO () +testRenderFieldType = do + putStrLn "\nrenderFieldType:" + + assert "int32" (renderFieldType ProtoInt32 == "int32") + assert "int64" (renderFieldType ProtoInt64 == "int64") + assert "uint32" (renderFieldType ProtoUInt32 == "uint32") + assert "uint64" (renderFieldType ProtoUInt64 == "uint64") + assert "double" (renderFieldType ProtoDouble == "double") + assert "float" (renderFieldType ProtoFloat == "float") + assert "bool" (renderFieldType ProtoBool == "bool") + assert "string" (renderFieldType ProtoString == "string") + assert "bytes" (renderFieldType ProtoBytes == "bytes") + assert "message" (renderFieldType (ProtoMessage "Foo") == "Foo") + assert "repeated" (renderFieldType (ProtoRepeated ProtoString) == "repeated string") + assert "optional" (renderFieldType (ProtoOptional ProtoInt32) == "optional int32") + assert "repeated message" (renderFieldType (ProtoRepeated (ProtoMessage "Bar")) == "repeated Bar") + + +-- =================================================================== +-- 9. renderMessage +-- =================================================================== + +testRenderMessage :: IO () +testRenderMessage = do + putStrLn "\nrenderMessage:" + + let msg = MessageDef "User" + [ ProtoField "name" 1 ProtoString + , ProtoField "email" 2 ProtoString + , ProtoField "id" 3 ProtoInt64 + ] + rendered = renderMessage msg + + assert "message User {" (T.isInfixOf "message User {" rendered) + assert "string name = 1;" (T.isInfixOf "string name = 1;" rendered) + assert "string email = 2;" (T.isInfixOf "string email = 2;" rendered) + assert "int64 id = 3;" (T.isInfixOf "int64 id = 3;" rendered) + assert "closing brace" (T.isInfixOf "}" rendered) + + -- Nested message field + let msg2 = MessageDef "Article" + [ ProtoField "title" 1 ProtoString + , ProtoField "author" 2 (ProtoMessage "User") + ] + rendered2 = renderMessage msg2 + + assert "User author = 2;" (T.isInfixOf "User author = 2;" rendered2) + + +-- =================================================================== +-- 10. generateProtoFull +-- =================================================================== + +testGenerateProtoFull :: IO () +testGenerateProtoFull = do + putStrLn "\ngenerateProtoFull:" + + let msgs = + [ MessageDef "CreateUserReq" [ ProtoField "name" 1 ProtoString ] + , MessageDef "User" + [ ProtoField "name" 1 ProtoString + , ProtoField "id" 2 ProtoInt64 + ] + ] + proto = generateProtoFull @TestAPI "test" "TestSvc" msgs + + assert "has syntax" (T.isInfixOf "syntax = \"proto3\";" proto) + assert "has package" (T.isInfixOf "package test;" proto) + assert "has service" (T.isInfixOf "service TestSvc {" proto) + assert "has Health rpc" (T.isInfixOf "rpc Health" proto) + assert "has Users rpc" (T.isInfixOf "rpc Users" proto) + assert "has Empty import" (T.isInfixOf "import \"google/protobuf/empty.proto\";" proto) + + -- Full message definitions should be present + assert "message CreateUserReq" (T.isInfixOf "message CreateUserReq {" proto) + assert "string name = 1;" (T.isInfixOf "string name = 1;" proto) + assert "message User" (T.isInfixOf "message User {" proto) + assert "int64 id = 2;" (T.isInfixOf "int64 id = 2;" proto) + + -- No commented stubs + assert "no stubs" (not (T.isInfixOf "// message" proto)) + + +-- =================================================================== +-- 11. generateProto with CollectMessageDefs (auto-collected) +-- =================================================================== + +testGenerateProtoAutoCollect :: IO () +testGenerateProtoAutoCollect = do + putStrLn "\ngenerateProto with auto-collected message defs:" + + -- TestAPI has User and CreateUserReq which have CollectTypeDef instances + let proto = generateProto @TestAPI "test" "TestSvc" + + assert "has syntax" (T.isInfixOf "syntax = \"proto3\";" proto) + assert "has package" (T.isInfixOf "package test;" proto) + assert "has service" (T.isInfixOf "service TestSvc {" proto) + assert "has Empty import" (T.isInfixOf "import \"google/protobuf/empty.proto\";" proto) + + -- Auto-collected message defs + assert "message CreateUserReq" (T.isInfixOf "message CreateUserReq {" proto) + assert "message User" (T.isInfixOf "message User {" proto) + assert "string name = 1;" (T.isInfixOf "string name = 1;" proto) + + +-- =================================================================== +-- 12. generateProtoFull without Empty import +-- =================================================================== + +testGenerateProtoFullNoEmpty :: IO () +testGenerateProtoFullNoEmpty = do + putStrLn "\ngenerateProtoFull without Empty import:" + + let msgs = [ MessageDef "CreateUserReq" [ ProtoField "name" 1 ProtoString ] + , MessageDef "User" [ ProtoField "name" 1 ProtoString ] + ] + proto = generateProtoFull @PostUserAPI "test" "PostSvc" msgs + + assert "no Empty import" (not (T.isInfixOf "google/protobuf/empty.proto" proto)) + assert "has message defs" (T.isInfixOf "message CreateUserReq {" proto) + + +-- =================================================================== +-- Main +-- =================================================================== + +main :: IO () +main = do + putStrLn "acolyte-grpc tests:\n" + testBuildGrpcHandlers + testProtoGeneration + testEffectDelegation + testThreeEndpointAPI + testGrpcCodecRoundtrip + testCapturePaths + testProtoCompleteness + testProtoWithRequestBody + testProtoBodyless + testRenderFieldType + testRenderMessage + testGenerateProtoFull + testGenerateProtoAutoCollect + testGenerateProtoFullNoEmpty + putStrLn "\nAll acolyte-grpc tests passed." diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Acolyte.Core +import Acolyte.Server (Json) +import Acolyte.Grpc + + +-- =================================================================== +-- Test type with trivial GrpcCodec (identity on ByteString) +-- =================================================================== + +newtype TestMsg = TestMsg ByteString + deriving (Eq, Show) + +instance GrpcCodec TestMsg where + grpcEncode (TestMsg bs) = bs + grpcDecode bs = Just (TestMsg bs) + + +-- =================================================================== +-- Property: GrpcCodec roundtrip +-- =================================================================== + +prop_grpcCodecRoundtrip :: Property +prop_grpcCodecRoundtrip = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 200) + let msg = TestMsg bs + grpcDecode (grpcEncode msg) === Just msg + + +-- =================================================================== +-- Property: Proto generation produces valid syntax +-- =================================================================== + +-- Test types for proto generation +data TestUser = TestUser !Text + deriving (Eq, Show) + +instance GrpcCodec TestUser where + grpcEncode (TestUser t) = encodeText t + grpcDecode bs = Just (TestUser (decodeText bs)) + +instance ProtoMessageName TestUser where + protoMessageName = "TestUser" + +instance GrpcCodec Text where + grpcEncode = encodeText + grpcDecode = Just . decodeText + +instance ProtoMessageName Text where + protoMessageName = "StringValue" + +-- Simple UTF-8 helpers (matching the existing test pattern) +encodeText :: Text -> ByteString +encodeText t = BS.pack (map (fromIntegral . fromEnum) (T.unpack t)) + +decodeText :: ByteString -> Text +decodeText = T.pack . map (toEnum . fromIntegral) . BS.unpack + +-- API for proto generation test +type TestPath = '[ 'Lit "test" ] +type TestAPI = '[ Get TestPath Text + , Post TestPath (Json TestUser) (Json TestUser) + ] + +prop_protoGenerationValid :: Property +prop_protoGenerationValid = property $ do + -- Generate with varying package and service names + pkg <- forAll $ Gen.text (Range.linear 1 20) Gen.alpha + svc <- forAll $ Gen.text (Range.linear 1 20) Gen.alpha + + let proto = generateProto @TestAPI pkg svc + + -- Must start with proto3 syntax + assert $ T.isPrefixOf "syntax = \"proto3\";" proto + + -- Must contain package declaration + assert $ T.isInfixOf ("package " <> pkg <> ";") proto + + -- Must contain service declaration + assert $ T.isInfixOf ("service " <> svc <> " {") proto + + -- Must have balanced braces + let opens = T.count "{" proto + closes = T.count "}" proto + opens === closes + + +-- =================================================================== +-- Main +-- =================================================================== + +tests :: IO Bool +tests = checkParallel $$(discover) + +main :: IO () +main = do + ok <- tests + if ok then pure () else error "Property tests failed"