packages feed

acolyte-grpc (empty) → 0.1.0.0

raw patch · 9 files changed

+1573/−0 lines, 9 filesdep +acolyte-coredep +acolyte-grpcdep +acolyte-server

Dependencies added: acolyte-core, acolyte-grpc, acolyte-server, base, bytestring, case-insensitive, containers, hedgehog, http-core, http-types, spire, spire-grpc, spire-protobuf, text

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ acolyte-grpc.cabal view
@@ -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 <joshburgess.webdev@gmail.com>+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
+ src/Acolyte/Grpc.hs view
@@ -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
+ src/Acolyte/Grpc/Generate.hs view
@@ -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)]+-- @
+ src/Acolyte/Grpc/Proto.hs view
@@ -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
+ src/Acolyte/Grpc/Server.hs view
@@ -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
+ test/Main.hs view
@@ -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."
+ test/Properties.hs view
@@ -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"