diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for spire-protobuf + +## 0.1.0.0 -- 2026-04-27 + +* Initial release. Minimal Protocol Buffers library with zero-copy + decoding and GHC Generics integration. No code generation, no + Template Haskell, no external tools. 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/spire-protobuf.cabal b/spire-protobuf.cabal new file mode 100644 --- /dev/null +++ b/spire-protobuf.cabal @@ -0,0 +1,108 @@ +cabal-version: 3.0 +name: spire-protobuf +version: 0.1.0.0 +synopsis: Minimal Protocol Buffers for Haskell, no codegen +category: Data, Codec +description: + A fast, minimal protobuf library with zero-copy decoding and GHC + Generics integration. No code generation, no Template Haskell, no + external tools. + . + Define messages as Haskell records with 'Field' wrappers for field + numbers, derive 'Generic' and 'ProtoMessage', and get encode/decode + for free. + . + @ + data User = User + { name :: Field 1 Text + , age :: Field 2 Int32 + , email :: Field 3 (Maybe Text) + } deriving (Generic, ProtoMessage) + @ + . + Key design decisions: + . + * Single-pass decoding directly into target type (no intermediate Map) + * Zero-copy string\/bytes fields (ByteString slices into input buffer) + * Length-memoizing Builder for correct submessage encoding + * GHC 9.10 @-finline-generics@ eliminates Generic overhead + * 4 dependencies: base, bytestring, text, containers + +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-source-files: + test/test.proto + +extra-doc-files: + CHANGELOG.md + +library + exposed-modules: + Spire.Protobuf + Spire.Protobuf.Wire + Spire.Protobuf.Encode + Spire.Protobuf.Decode + Spire.Protobuf.Field + Spire.Protobuf.Message + + build-depends: + base >= 4.20 && < 5 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , containers >= 0.6 && < 0.8 + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + StrictData + OverloadedStrings + + ghc-options: -Wall -funbox-strict-fields -finline-generics + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + StrictData + OverloadedStrings + + ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K" + + build-depends: + base >= 4.20 && < 5 + , spire-protobuf + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , containers >= 0.6 && < 0.8 + , process >= 1.6 && < 1.8 + +test-suite properties + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + StrictData + OverloadedStrings + + ghc-options: -Wall + + build-depends: + base >= 4.20 && < 5 + , spire-protobuf + , hedgehog >= 1.4 && < 1.8 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , containers >= 0.6 && < 0.8 + +source-repository head + type: git + location: https://github.com/joshburgess/acolyte.git diff --git a/src/Spire/Protobuf.hs b/src/Spire/Protobuf.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf.hs @@ -0,0 +1,52 @@ +-- | High-performance Protocol Buffers for Haskell. +-- +-- Define messages as Haskell records with 'Field' wrappers for field +-- numbers, derive 'Generic' and 'ProtoMessage', and get encode\/decode +-- for free: +-- +-- @ +-- data User = User +-- { name :: Field 1 Text +-- , age :: Field 2 Int32 +-- , email :: Field 3 (Maybe Text) +-- } deriving (Generic) +-- +-- instance ProtoMessage User +-- +-- -- Encode: +-- let bs = encode (User (Field "Alice") (Field 30) (Field (Just "alice\@example.com"))) +-- +-- -- Decode: +-- case decode bs of +-- Right user -> print user +-- Left err -> error (show err) +-- @ +module Spire.Protobuf + ( -- * Messages + ProtoMessage (..) + , encode + , decode + -- * Field wrapper + , Field (..) + -- * Signed integer wrappers (zigzag encoding) + , SInt32 (..) + , SInt64 (..) + -- * Proto3 map fields + , ProtoMap (..) + -- * Errors + , DecodeError (..) + -- * Re-exports for advanced use + , ProtoEncode (..) + , ProtoDecode (..) + , decodePacked + , DecodeRepeatedEntry (..) + , ProtoDefault (..) + , ProtoBuilder + , WireType (..) + ) where + +import Spire.Protobuf.Wire (WireType (..)) +import Spire.Protobuf.Field (Field (..), SInt32(..), SInt64(..), ProtoMap(..)) +import Spire.Protobuf.Encode (ProtoEncode (..), ProtoBuilder, ProtoDefault (..)) +import Spire.Protobuf.Decode (ProtoDecode (..), DecodeError (..), decodePacked, DecodeRepeatedEntry(..)) +import Spire.Protobuf.Message (ProtoMessage (..), encode, decode) diff --git a/src/Spire/Protobuf/Decode.hs b/src/Spire/Protobuf/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf/Decode.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Protobuf decoding: single-pass wire format parser. +-- +-- Provides 'ProtoDecode' for individual value types and 'DecodeError' +-- for structured error reporting. The decoder works directly on strict +-- 'ByteString' with zero-copy slicing for bytes/string fields. +module Spire.Protobuf.Decode + ( -- * ProtoDecode class + ProtoDecode (..) + -- * Raw field parsing + , RawField (..) + , parseFields + -- * Packed repeated field decoding + , decodePacked + -- * Packed/unpacked repeated entry decoding (Generics support) + , DecodeRepeatedEntry (..) + -- * Errors + , DecodeError (..) + ) where + +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Int (Int32, Int64) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import Data.Word (Word32, Word64) +import GHC.Float (castWord32ToFloat, castWord64ToDouble) + +import Spire.Protobuf.Wire +import Spire.Protobuf.Field (SInt32(..), SInt64(..)) + + +-- =================================================================== +-- Errors +-- =================================================================== + +-- | Errors that can occur during protobuf decoding. +data DecodeError + = UnexpectedWireType !Int !WireType !WireType + -- ^ field number, expected wire type, actual wire type + | TruncatedInput + -- ^ input ended before a complete value could be read + | InvalidVarint + -- ^ varint encoding was malformed or overflowed + | InvalidUtf8 + -- ^ a string field contained invalid UTF-8 + | InvalidWireType !Int + -- ^ wire type id was not one of 0, 1, 2, 5 + deriving (Show, Eq) + + +-- =================================================================== +-- Raw field representation +-- =================================================================== + +-- | A raw (unparsed) field value as it appears on the wire. +-- Used as an intermediate representation during decoding: parse all +-- tag-value pairs first, then interpret each field. +data RawField + = RawVarint !Word64 + | RawFixed64 !Word64 + | RawFixed32 !Word32 + | RawBytes !ByteString -- ^ zero-copy slice of the input + deriving (Show, Eq) + + +-- | Parse all tag-value pairs from a protobuf message. +-- Returns a list of (field_number, raw_value) pairs in wire order. +-- Unknown wire types cause a 'Left' error; otherwise parsing is +-- lenient (unknown field numbers are preserved). +parseFields :: ByteString -> Either DecodeError [(Int, RawField)] +parseFields = go [] + where + go !acc bs + | BS.null bs = Right (reverse acc) + | otherwise = case decodeTag bs of + Nothing -> + -- Distinguish truncated input from invalid wire type + case decodeVarint bs of + Nothing -> Left TruncatedInput + Just (val, _) -> + let wireId = fromIntegral (val .&. 0x07) :: Int + in if wireId `elem` [0, 1, 2, 5] + then Left TruncatedInput + else Left (InvalidWireType wireId) + Just (fieldNum, wt, rest) -> case parseRawField wt rest of + Nothing -> Left TruncatedInput + Just (raw, rest') -> go ((fieldNum, raw) : acc) rest' + +-- | Parse a raw field value given its wire type. +parseRawField :: WireType -> ByteString -> Maybe (RawField, ByteString) +parseRawField WireVarint bs = do + (val, rest) <- decodeVarint bs + Just (RawVarint val, rest) +parseRawField WireFixed64 bs = do + (val, rest) <- decodeFixed64 bs + Just (RawFixed64 val, rest) +parseRawField WireFixed32 bs = do + (val, rest) <- decodeFixed32 bs + Just (RawFixed32 val, rest) +parseRawField WireLengthDelimited bs = do + (val, rest) <- decodeLengthDelimited bs + Just (RawBytes val, rest) + + +-- =================================================================== +-- ProtoDecode class +-- =================================================================== + +-- | Class for types that can be decoded from a raw protobuf field. +class ProtoDecode a where + -- | Decode a value from a 'RawField'. + protoDecodeValue :: RawField -> Either DecodeError a + +-- Int32: varint +instance ProtoDecode Int32 where + protoDecodeValue (RawVarint w) = Right (fromIntegral w :: Int32) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- Int64: varint +instance ProtoDecode Int64 where + protoDecodeValue (RawVarint w) = Right (fromIntegral w :: Int64) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- Word32: varint +instance ProtoDecode Word32 where + protoDecodeValue (RawVarint w) = Right (fromIntegral w :: Word32) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- Word64: varint +instance ProtoDecode Word64 where + protoDecodeValue (RawVarint w) = Right w + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- Bool: varint, 0 = False, nonzero = True +instance ProtoDecode Bool where + protoDecodeValue (RawVarint w) = Right (w /= 0) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- Float: fixed32 +instance ProtoDecode Float where + protoDecodeValue (RawFixed32 w) = + Right (castWord32ToFloat w) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireFixed32 WireVarint) + {-# INLINE protoDecodeValue #-} + +-- Double: fixed64 +instance ProtoDecode Double where + protoDecodeValue (RawFixed64 w) = + Right (castWord64ToDouble w) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireFixed64 WireVarint) + {-# INLINE protoDecodeValue #-} + +-- Text: length-delimited, UTF-8 decoded +instance ProtoDecode Text where + protoDecodeValue (RawBytes bs) = + case TE.decodeUtf8' bs of + Left _ -> Left InvalidUtf8 + Right t -> Right t + protoDecodeValue _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) + {-# INLINE protoDecodeValue #-} + +-- ByteString: length-delimited, zero-copy slice +instance ProtoDecode ByteString where + protoDecodeValue (RawBytes bs) = Right bs + protoDecodeValue _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) + {-# INLINE protoDecodeValue #-} + +-- SInt32: varint with zigzag decoding +instance ProtoDecode SInt32 where + protoDecodeValue (RawVarint w) = + Right (SInt32 (fromIntegral (zigzagDecode w))) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + +-- SInt64: varint with zigzag decoding +instance ProtoDecode SInt64 where + protoDecodeValue (RawVarint w) = + Right (SInt64 (zigzagDecode w)) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireVarint WireLengthDelimited) + {-# INLINE protoDecodeValue #-} + + +-- =================================================================== +-- Packed repeated field decoding +-- =================================================================== + +-- | Decode packed repeated scalar values from a 'RawBytes' blob. +-- In proto3, repeated scalar fields may be encoded as a single +-- length-delimited blob containing all values concatenated. +-- Returns 'Left' if the blob cannot be fully consumed. +decodePacked :: ProtoDecode a => (ByteString -> Maybe (a, ByteString)) -> RawField -> Either DecodeError [a] +decodePacked parser (RawBytes bs) = go bs [] + where + go remaining acc + | BS.null remaining = Right (reverse acc) + | otherwise = case parser remaining of + Just (val, rest) -> go rest (val : acc) + Nothing -> Left TruncatedInput +decodePacked _ _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) + + +-- =================================================================== +-- DecodeRepeatedEntry: handles both packed and unpacked entries +-- =================================================================== + +-- | Decode a single raw field entry as one or more values of type @a@. +-- +-- For packable scalar types (Int32, Int64, Word32, Word64, Bool, Float, +-- Double, SInt32, SInt64), a 'RawBytes' entry is treated as a packed +-- blob containing multiple concatenated values. For non-packable types +-- (Text, ByteString, submessages), 'RawBytes' is decoded as a single +-- value. +-- +-- This class is used by the Generics decoder for repeated fields to +-- transparently handle both packed and unpacked wire encodings. +class DecodeRepeatedEntry a where + decodeRepeatedEntry :: RawField -> Either DecodeError [a] + +-- | Default: non-packable types. Decode as a single value. +instance {-# OVERLAPPABLE #-} ProtoDecode a => DecodeRepeatedEntry a where + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +-- Varint-based packable scalars: Int32, Int64, Word32, Word64, Bool + +instance DecodeRepeatedEntry Int32 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +instance DecodeRepeatedEntry Int64 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +instance DecodeRepeatedEntry Word32 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +instance DecodeRepeatedEntry Word64 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +instance DecodeRepeatedEntry Bool where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +-- Fixed32-based: Float +instance DecodeRepeatedEntry Float where + decodeRepeatedEntry (RawBytes bs) = unpackFixed32s bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +-- Fixed64-based: Double +instance DecodeRepeatedEntry Double where + decodeRepeatedEntry (RawBytes bs) = unpackFixed64s bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +-- Varint-based with zigzag: SInt32, SInt64 +instance DecodeRepeatedEntry SInt32 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + +instance DecodeRepeatedEntry SInt64 where + decodeRepeatedEntry (RawBytes bs) = unpackVarints bs + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + + +-- =================================================================== +-- Unpacking helpers +-- =================================================================== + +-- | Unpack varints from a packed blob, decoding each via 'ProtoDecode'. +unpackVarints :: ProtoDecode a => ByteString -> Either DecodeError [a] +unpackVarints = go [] + where + go !acc bs + | BS.null bs = Right (reverse acc) + | otherwise = case decodeVarint bs of + Just (w, rest) -> case protoDecodeValue (RawVarint w) of + Right val -> go (val : acc) rest + Left err -> Left err + Nothing -> Left TruncatedInput +{-# INLINE unpackVarints #-} + +-- | Unpack fixed32 values from a packed blob. +unpackFixed32s :: ProtoDecode a => ByteString -> Either DecodeError [a] +unpackFixed32s = go [] + where + go !acc bs + | BS.null bs = Right (reverse acc) + | otherwise = case decodeFixed32 bs of + Just (w, rest) -> case protoDecodeValue (RawFixed32 w) of + Right val -> go (val : acc) rest + Left err -> Left err + Nothing -> Left TruncatedInput +{-# INLINE unpackFixed32s #-} + +-- | Unpack fixed64 values from a packed blob. +unpackFixed64s :: ProtoDecode a => ByteString -> Either DecodeError [a] +unpackFixed64s = go [] + where + go !acc bs + | BS.null bs = Right (reverse acc) + | otherwise = case decodeFixed64 bs of + Just (w, rest) -> case protoDecodeValue (RawFixed64 w) of + Right val -> go (val : acc) rest + Left err -> Left err + Nothing -> Left TruncatedInput +{-# INLINE unpackFixed64s #-} diff --git a/src/Spire/Protobuf/Encode.hs b/src/Spire/Protobuf/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf/Encode.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Length-memoizing builder and encoding for protobuf values. +-- +-- The key insight: protobuf submessages need their byte length encoded +-- as a varint /before/ the content. A normal 'Builder' doesn't know its +-- length until materialized. 'ProtoBuilder' tracks the byte count +-- alongside the builder, so submessage encoding is a single pass. +module Spire.Protobuf.Encode + ( -- * Length-memoizing Builder + ProtoBuilder (..) + , runProtoBuilder + , pbEmpty + -- * ProtoEncode class + , ProtoEncode (..) + -- * Field encoding + , encodeField + , encodeOptionalField + , encodeRepeatedField + , encodePackedField + -- * Submessage encoding + , encodeSubmessage + -- * Tag encoding (for advanced use) + , pbTag + -- * Proto3 default values + , ProtoDefault (..) + ) where + +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as BEx +import qualified Data.ByteString.Lazy as LBS +import Data.Int (Int32, Int64) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import Data.Word (Word32, Word64) +import GHC.TypeLits (KnownNat, natVal) +import Data.Proxy (Proxy(..)) + +import Spire.Protobuf.Wire +import Spire.Protobuf.Field + + +-- =================================================================== +-- ProtoBuilder +-- =================================================================== + +-- | A 'Builder' paired with its exact byte length. +-- +-- This is needed for submessage encoding: protobuf length-delimited +-- fields require the byte count as a varint prefix. Tracking it +-- incrementally avoids a double-pass. +data ProtoBuilder = ProtoBuilder + { pbLength :: {-# UNPACK #-} !Int + , pbBuilder :: !B.Builder + } + +instance Semigroup ProtoBuilder where + ProtoBuilder l1 b1 <> ProtoBuilder l2 b2 = + ProtoBuilder (l1 + l2) (b1 <> b2) + {-# INLINE (<>) #-} + +instance Monoid ProtoBuilder where + mempty = ProtoBuilder 0 mempty + {-# INLINE mempty #-} + +-- | Empty builder. +pbEmpty :: ProtoBuilder +pbEmpty = mempty +{-# INLINE pbEmpty #-} + +-- | Materialize a 'ProtoBuilder' into a strict 'ByteString'. +-- Uses 'safeStrategy' with the exact known length for a single allocation. +runProtoBuilder :: ProtoBuilder -> ByteString +runProtoBuilder (ProtoBuilder len bld) = + LBS.toStrict (BEx.toLazyByteStringWith + (BEx.safeStrategy len BEx.smallChunkSize) + LBS.empty + bld) +{-# INLINE runProtoBuilder #-} + + +-- =================================================================== +-- Helpers: wrap Wire primitives as ProtoBuilder +-- =================================================================== + +-- | Encode a varint as a 'ProtoBuilder'. +pbVarint :: Word64 -> ProtoBuilder +pbVarint n = ProtoBuilder (varintSize n) (encodeVarint n) +{-# INLINE pbVarint #-} + +-- | Number of bytes a varint takes on the wire. +varintSize :: Word64 -> Int +varintSize n + | n < 0x80 = 1 + | n < 0x4000 = 2 + | n < 0x200000 = 3 + | n < 0x10000000 = 4 + | n < 0x0800000000 = 5 + | n < 0x040000000000 = 6 + | n < 0x02000000000000 = 7 + | n < 0x0100000000000000 = 8 + | n < 0x8000000000000000 = 9 + | otherwise = 10 +{-# INLINE varintSize #-} + +-- | Encode a tag as a 'ProtoBuilder'. +pbTag :: Int -> WireType -> ProtoBuilder +pbTag fieldNum wt = + let tagVal = fromIntegral fieldNum `shiftL` 3 .|. wireTypeToWord wt + in pbVarint tagVal +{-# INLINE pbTag #-} + +wireTypeToWord :: WireType -> Word64 +wireTypeToWord WireVarint = 0 +wireTypeToWord WireFixed64 = 1 +wireTypeToWord WireLengthDelimited = 2 +wireTypeToWord WireFixed32 = 5 +{-# INLINE wireTypeToWord #-} + +-- | Encode raw bytes as a 'ProtoBuilder'. +pbBytes :: ByteString -> ProtoBuilder +pbBytes bs = ProtoBuilder (BS.length bs) (B.byteString bs) +{-# INLINE pbBytes #-} + + +-- =================================================================== +-- ProtoEncode class +-- =================================================================== + +-- | Class for types that can be encoded into protobuf wire format. +class ProtoEncode a where + -- | The wire type used for this value. + protoWireType :: WireType + -- | Encode the value (without a tag prefix). + protoEncodeValue :: a -> ProtoBuilder + +-- Int32: varint encoding (cast to Word64 preserving bit pattern) +instance ProtoEncode Int32 where + protoWireType = WireVarint + protoEncodeValue n = pbVarint (fromIntegral n :: Word64) + {-# INLINE protoEncodeValue #-} + +-- Int64: varint encoding +instance ProtoEncode Int64 where + protoWireType = WireVarint + protoEncodeValue n = pbVarint (fromIntegral n :: Word64) + {-# INLINE protoEncodeValue #-} + +-- Word32: varint encoding +instance ProtoEncode Word32 where + protoWireType = WireVarint + protoEncodeValue n = pbVarint (fromIntegral n) + {-# INLINE protoEncodeValue #-} + +-- Word64: varint encoding +instance ProtoEncode Word64 where + protoWireType = WireVarint + protoEncodeValue = pbVarint + {-# INLINE protoEncodeValue #-} + +-- Bool: varint 0 or 1 +instance ProtoEncode Bool where + protoWireType = WireVarint + protoEncodeValue b = pbVarint (if b then 1 else 0) + {-# INLINE protoEncodeValue #-} + +-- Float: fixed32 +instance ProtoEncode Float where + protoWireType = WireFixed32 + protoEncodeValue f = ProtoBuilder 4 (encodeProtoFloat f) + {-# INLINE protoEncodeValue #-} + +-- Double: fixed64 +instance ProtoEncode Double where + protoWireType = WireFixed64 + protoEncodeValue d = ProtoBuilder 8 (encodeProtoDouble d) + {-# INLINE protoEncodeValue #-} + +-- Text: length-delimited UTF-8 +instance ProtoEncode Text where + protoWireType = WireLengthDelimited + protoEncodeValue t = + let bs = TE.encodeUtf8 t + len = BS.length bs + in pbVarint (fromIntegral len) <> pbBytes bs + {-# INLINE protoEncodeValue #-} + +-- ByteString: length-delimited raw bytes +instance ProtoEncode ByteString where + protoWireType = WireLengthDelimited + protoEncodeValue bs = + let len = BS.length bs + in pbVarint (fromIntegral len) <> pbBytes bs + {-# INLINE protoEncodeValue #-} + +-- SInt32: varint with zigzag encoding +instance ProtoEncode SInt32 where + protoWireType = WireVarint + protoEncodeValue (SInt32 n) = pbVarint (zigzagEncode (fromIntegral n)) + {-# INLINE protoEncodeValue #-} + +-- SInt64: varint with zigzag encoding +instance ProtoEncode SInt64 where + protoWireType = WireVarint + protoEncodeValue (SInt64 n) = pbVarint (zigzagEncode n) + {-# INLINE protoEncodeValue #-} + + +-- =================================================================== +-- Submessage encoding +-- =================================================================== + +-- | Encode a pre-built submessage as a length-delimited value. +-- Prepends the byte length as a varint. +encodeSubmessage :: ProtoBuilder -> ProtoBuilder +encodeSubmessage (ProtoBuilder len bld) = + let lenPb = pbVarint (fromIntegral len) + in lenPb <> ProtoBuilder len bld +{-# INLINE encodeSubmessage #-} + + +-- =================================================================== +-- Field encoding +-- =================================================================== + +-- | Encode a single field: tag + value. +-- Proto3 semantics: skips the field if the value is the default. +encodeField :: forall n a. (KnownNat n, ProtoEncode a, Eq a, ProtoDefault a) + => Field n a -> ProtoBuilder +encodeField (Field val) + | val == protoDefault = mempty + | otherwise = + let fn = fromIntegral (natVal (Proxy @n)) :: Int + tag = pbTag fn (protoWireType @a) + in tag <> protoEncodeValue val +{-# INLINE encodeField #-} + +-- | Encode an optional field ('Maybe' wrapper). +-- 'Nothing' encodes to zero bytes. 'Just' encodes like a regular field. +encodeOptionalField :: forall n a. (KnownNat n, ProtoEncode a) + => Field n (Maybe a) -> ProtoBuilder +encodeOptionalField (Field Nothing) = mempty +encodeOptionalField (Field (Just val)) = + let fn = fromIntegral (natVal (Proxy @n)) :: Int + tag = pbTag fn (protoWireType @a) + in tag <> protoEncodeValue val +{-# INLINE encodeOptionalField #-} + +-- | Encode a repeated (non-packed) field: each element gets its own tag. +encodeRepeatedField :: forall n a. (KnownNat n, ProtoEncode a) + => Field n [a] -> ProtoBuilder +encodeRepeatedField (Field xs) = + let fn = fromIntegral (natVal (Proxy @n)) :: Int + tag = pbTag fn (protoWireType @a) + in foldMap (\v -> tag <> protoEncodeValue v) xs +{-# INLINE encodeRepeatedField #-} + +-- | Encode a packed repeated field: one length-delimited blob containing +-- all elements concatenated (only valid for scalar numeric types). +encodePackedField :: forall n a. (KnownNat n, ProtoEncode a) + => Field n [a] -> ProtoBuilder +encodePackedField (Field []) = mempty +encodePackedField (Field xs) = + let fn = fromIntegral (natVal (Proxy @n)) :: Int + tag = pbTag fn WireLengthDelimited + content = foldMap protoEncodeValue xs + in tag <> encodeSubmessage content +{-# INLINE encodePackedField #-} + + +-- =================================================================== +-- Proto3 default values +-- =================================================================== + +-- | Default values for proto3 field types. +-- In proto3, fields with the default value are omitted from the wire. +class ProtoDefault a where + protoDefault :: a + +instance ProtoDefault Int32 where protoDefault = 0 +instance ProtoDefault Int64 where protoDefault = 0 +instance ProtoDefault Word32 where protoDefault = 0 +instance ProtoDefault Word64 where protoDefault = 0 +instance ProtoDefault Bool where protoDefault = False +instance ProtoDefault Float where protoDefault = 0.0 +instance ProtoDefault Double where protoDefault = 0.0 +instance ProtoDefault Text where protoDefault = "" +instance ProtoDefault ByteString where protoDefault = BS.empty +instance ProtoDefault SInt32 where protoDefault = SInt32 0 +instance ProtoDefault SInt64 where protoDefault = SInt64 0 diff --git a/src/Spire/Protobuf/Field.hs b/src/Spire/Protobuf/Field.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf/Field.hs @@ -0,0 +1,67 @@ +-- | Type-level field numbers for protobuf messages. +-- +-- The 'Field' newtype embeds a compile-time field number (proto3 field tag) +-- into the type. At runtime it is a zero-cost wrapper (via 'coerce'). +-- +-- @ +-- data User = User +-- { name :: Field 1 Text +-- , age :: Field 2 Int32 +-- } +-- @ +module Spire.Protobuf.Field + ( Field (..) + , fieldVal + -- * Signed integer wrappers (zigzag encoding) + , SInt32 (..) + , SInt64 (..) + -- * Proto3 map fields + , ProtoMap (..) + ) where + +import Data.Int (Int32, Int64) +import Data.Map.Strict (Map) +import GHC.TypeLits (Nat, KnownNat, natVal) +import Data.Proxy (Proxy(..)) + +-- | A protobuf field with a compile-time field number. +-- +-- The field number is used for wire encoding; at runtime, 'Field' is +-- just a newtype wrapper (zero overhead via coerce). +newtype Field (n :: Nat) a = Field { unField :: a } + deriving (Show, Eq, Ord, Functor) + +-- | Get the field number at runtime. +fieldVal :: forall n a. KnownNat n => Field n a -> Int +fieldVal _ = fromIntegral (natVal (Proxy @n)) +{-# INLINE fieldVal #-} + + +-- | Signed 32-bit integer using zigzag encoding on the wire. +-- Use for fields declared as @sint32@ in .proto files. +-- Zigzag encoding maps small-magnitude values (positive or negative) +-- to small varints, unlike plain @int32@ which uses 10 bytes for negatives. +newtype SInt32 = SInt32 { unSInt32 :: Int32 } + deriving (Show, Eq, Ord) + +-- | Signed 64-bit integer using zigzag encoding on the wire. +-- Use for fields declared as @sint64@ in .proto files. +newtype SInt64 = SInt64 { unSInt64 :: Int64 } + deriving (Show, Eq, Ord) + + +-- | Proto3 map field: @map\@. +-- +-- On the wire, a map is encoded as a repeated message where each entry +-- has field 1 = key and field 2 = value. This newtype wraps 'Map' and +-- provides the correct protobuf encoding/decoding. +-- +-- @ +-- data Config = Config +-- { settings :: Field 1 (ProtoMap Text Text) +-- , counts :: Field 2 (ProtoMap Text Int32) +-- } deriving (Generic) +-- instance ProtoMessage Config +-- @ +newtype ProtoMap k v = ProtoMap { unProtoMap :: Map k v } + deriving (Show, Eq, Ord) diff --git a/src/Spire/Protobuf/Message.hs b/src/Spire/Protobuf/Message.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf/Message.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | GHC Generics integration for automatic protobuf encoding/decoding. +-- +-- Define your message as a Haskell record with 'Field' wrappers, +-- derive 'Generic', and write an empty 'ProtoMessage' instance: +-- +-- @ +-- data User = User +-- { name :: Field 1 Text +-- , age :: Field 2 Int32 +-- , email :: Field 3 (Maybe Text) +-- } deriving (Generic) +-- +-- instance ProtoMessage User +-- @ +-- +-- Encoding and decoding are then available via 'encode' and 'decode'. +module Spire.Protobuf.Message + ( ProtoMessage (..) + , encode + , decode + , GProtoEncode (..) + , GProtoDecode (..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.Map.Strict as Map +import GHC.Generics +import GHC.TypeLits (KnownNat, natVal) +import Data.Proxy (Proxy(..)) + +import Spire.Protobuf.Wire +import Spire.Protobuf.Field +import Spire.Protobuf.Encode +import Spire.Protobuf.Decode + + +-- =================================================================== +-- ProtoMessage class +-- =================================================================== + +-- | Class for protobuf messages that can be encoded and decoded. +-- +-- The default implementations use GHC Generics to walk the record +-- structure. Each field must be wrapped in 'Field' with a unique +-- field number. +class ProtoMessage a where + protoEncode :: a -> ProtoBuilder + default protoEncode :: (Generic a, GProtoEncode (Rep a)) => a -> ProtoBuilder + protoEncode = gProtoEncode . from + + protoDecode :: ByteString -> Either DecodeError a + default protoDecode :: (Generic a, GProtoDecode (Rep a)) => ByteString -> Either DecodeError a + protoDecode bs = do + rawFields <- parseFields bs + to <$> gProtoDecode rawFields + +-- | Encode a message to a strict 'ByteString'. +encode :: ProtoMessage a => a -> ByteString +encode = runProtoBuilder . protoEncode +{-# INLINE encode #-} + +-- | Decode a message from a strict 'ByteString'. +decode :: ProtoMessage a => ByteString -> Either DecodeError a +decode = protoDecode +{-# INLINE decode #-} + +-- ProtoMessage instance for submessage encoding +instance {-# OVERLAPPABLE #-} ProtoMessage a => ProtoEncode a where + protoWireType = WireLengthDelimited + protoEncodeValue a = encodeSubmessage (protoEncode a) + {-# INLINE protoEncodeValue #-} + +-- ProtoMessage instance for submessage decoding +instance {-# OVERLAPPABLE #-} ProtoMessage a => ProtoDecode a where + protoDecodeValue (RawBytes bs) = protoDecode bs + protoDecodeValue _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) + {-# INLINE protoDecodeValue #-} + + +-- =================================================================== +-- GProtoEncode: Generic encoding +-- =================================================================== + +-- | Generic encoding class. Walks the 'Rep' of a type and encodes +-- each 'Field n a' it encounters. +class GProtoEncode f where + gProtoEncode :: f p -> ProtoBuilder + +-- M1: metadata wrappers (datatype, constructor, selector) — pass through +instance GProtoEncode f => GProtoEncode (M1 i c f) where + gProtoEncode (M1 x) = gProtoEncode x + {-# INLINE gProtoEncode #-} + +-- :*: product — encode both sides +instance (GProtoEncode f, GProtoEncode g) => GProtoEncode (f :*: g) where + gProtoEncode (f :*: g) = gProtoEncode f <> gProtoEncode g + {-# INLINE gProtoEncode #-} + +-- U1: unit (empty record) +instance GProtoEncode U1 where + gProtoEncode U1 = mempty + {-# INLINE gProtoEncode #-} + +-- K1: a field of type Field n a — encode it +instance (KnownNat n, ProtoEncode a, Eq a, ProtoDefault a) + => GProtoEncode (K1 i (Field n a)) where + gProtoEncode (K1 fld) = encodeField fld + {-# INLINE gProtoEncode #-} + +-- K1: optional field — Field n (Maybe a) +instance {-# OVERLAPPING #-} (KnownNat n, ProtoEncode a) + => GProtoEncode (K1 i (Field n (Maybe a))) where + gProtoEncode (K1 fld) = encodeOptionalField fld + {-# INLINE gProtoEncode #-} + +-- K1: repeated field — Field n [a] +instance {-# OVERLAPPING #-} (KnownNat n, ProtoEncode a) + => GProtoEncode (K1 i (Field n [a])) where + gProtoEncode (K1 fld) = encodeRepeatedField fld + {-# INLINE gProtoEncode #-} + + +-- =================================================================== +-- GProtoDecode: Generic decoding +-- =================================================================== + +-- | Generic decoding class. Constructs the 'Rep' of a type from a +-- list of raw (field_number, value) pairs. +-- +-- The approach: parse all wire fields into @[(Int, RawField)]@ up front, +-- then for each record field, look up its field number in the list. +-- Unknown fields are silently ignored (proto3 forward-compatibility). +-- Last-wins semantics for duplicate field numbers. +class GProtoDecode f where + gProtoDecode :: [(Int, RawField)] -> Either DecodeError (f p) + +-- M1: metadata wrappers — pass through +instance GProtoDecode f => GProtoDecode (M1 i c f) where + gProtoDecode rfs = M1 <$> gProtoDecode rfs + {-# INLINE gProtoDecode #-} + +-- :*: product — decode both sides from the same field list +instance (GProtoDecode f, GProtoDecode g) => GProtoDecode (f :*: g) where + gProtoDecode rfs = do + l <- gProtoDecode rfs + r <- gProtoDecode rfs + Right (l :*: r) + {-# INLINE gProtoDecode #-} + +-- U1: unit +instance GProtoDecode U1 where + gProtoDecode _ = Right U1 + {-# INLINE gProtoDecode #-} + +-- K1: required field — Field n a. Look up field number n; if absent, use default. +instance (KnownNat n, ProtoDecode a, ProtoDefault a) + => GProtoDecode (K1 i (Field n a)) where + gProtoDecode rfs = + let fn = fromIntegral (natVal (Proxy @n)) + in case lookupLast fn rfs of + Nothing -> Right (K1 (Field protoDefault)) + Just raw -> K1 . Field <$> protoDecodeValue raw + {-# INLINE gProtoDecode #-} + +-- K1: optional field — Field n (Maybe a). Absent means Nothing. +instance {-# OVERLAPPING #-} (KnownNat n, ProtoDecode a) + => GProtoDecode (K1 i (Field n (Maybe a))) where + gProtoDecode rfs = + let fn = fromIntegral (natVal (Proxy @n)) + in case lookupLast fn rfs of + Nothing -> Right (K1 (Field Nothing)) + Just raw -> K1 . Field . Just <$> protoDecodeValue raw + {-# INLINE gProtoDecode #-} + +-- K1: repeated field — Field n [a]. Collect all occurrences. +-- Handles both unpacked (each element tagged separately) and packed +-- (all elements in a single length-delimited blob) wire encodings. +-- For packable scalar types (Int32, Int64, Word32, Word64, Bool, Float, +-- Double, SInt32, SInt64), a RawBytes entry is automatically unpacked +-- into multiple values. For non-packable types (Text, ByteString, +-- submessages), each RawBytes is decoded as a single value. +instance {-# OVERLAPPING #-} (KnownNat n, DecodeRepeatedEntry a) + => GProtoDecode (K1 i (Field n [a])) where + gProtoDecode rfs = + let fn = fromIntegral (natVal (Proxy @n)) + raws = [raw | (n', raw) <- rfs, n' == fn] + in K1 . Field . concat <$> traverse decodeRepeatedEntry raws + {-# INLINE gProtoDecode #-} + + +-- =================================================================== +-- Helpers +-- =================================================================== + +-- | Look up the last occurrence of a field number (last-wins proto3 semantics). +lookupLast :: Int -> [(Int, RawField)] -> Maybe RawField +lookupLast fn = go Nothing + where + go acc [] = acc + go acc ((n, v) : rest) + | n == fn = go (Just v) rest + | otherwise = go acc rest +{-# INLINE lookupLast #-} + + +-- =================================================================== +-- ProtoMap: Proto3 map field support +-- =================================================================== + +-- | Proto3 default for ProtoMap: empty map. +instance ProtoDefault (ProtoMap k v) where + protoDefault = ProtoMap Map.empty + +-- | Encode a ProtoMap as repeated length-delimited entries. +-- Each map entry is a submessage with field 1 = key, field 2 = value. +instance (Ord k, ProtoEncode k, ProtoEncode v) => ProtoEncode (ProtoMap k v) where + protoWireType = WireLengthDelimited + protoEncodeValue (ProtoMap m) = + let encodeEntry k v = + let keyEnc = pbTag 1 (protoWireType @k) <> protoEncodeValue k + valEnc = pbTag 2 (protoWireType @v) <> protoEncodeValue v + entryBody = keyEnc <> valEnc + in encodeSubmessage entryBody + in Map.foldlWithKey' (\acc k v -> acc <> encodeEntry k v) mempty m + {-# INLINE protoEncodeValue #-} + +-- | Decode a ProtoMap entry from a single RawBytes (one key-value pair submessage). +-- The caller (repeated field decoder) will collect all entries. +instance (Ord k, ProtoDecode k, ProtoDefault k, ProtoDecode v, ProtoDefault v) + => ProtoDecode (ProtoMap k v) where + protoDecodeValue (RawBytes bs) = do + -- Parse the entry submessage + rfs <- parseFields bs + -- Extract key (field 1) and value (field 2), using defaults if absent + k <- case lookupLast 1 rfs of + Nothing -> Right protoDefault + Just raw -> protoDecodeValue raw + v <- case lookupLast 2 rfs of + Nothing -> Right protoDefault + Just raw -> protoDecodeValue raw + Right (ProtoMap (Map.singleton k v)) + protoDecodeValue _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) + {-# INLINE protoDecodeValue #-} + +-- | DecodeRepeatedEntry for ProtoMap: each RawBytes is a single entry. +instance (Ord k, ProtoDecode k, ProtoDefault k, ProtoDecode v, ProtoDefault v) + => DecodeRepeatedEntry (ProtoMap k v) where + decodeRepeatedEntry raw = (: []) <$> protoDecodeValue raw + {-# INLINE decodeRepeatedEntry #-} + + +-- =================================================================== +-- ProtoMap Generics encoding/decoding +-- =================================================================== + +-- K1: ProtoMap field — Field n (ProtoMap k v). Encode all entries as +-- repeated submessages with the same field number. +instance {-# OVERLAPPING #-} + (KnownNat n, Ord k, ProtoEncode k, ProtoEncode v) + => GProtoEncode (K1 i (Field n (ProtoMap k v))) where + gProtoEncode (K1 (Field (ProtoMap m))) + | Map.null m = mempty + | otherwise = + let fn = fromIntegral (natVal (Proxy @n)) :: Int + tag = pbTag fn WireLengthDelimited + encodeEntry k v = + let keyEnc = pbTag 1 (protoWireType @k) <> protoEncodeValue k + valEnc = pbTag 2 (protoWireType @v) <> protoEncodeValue v + entryBody = keyEnc <> valEnc + in tag <> encodeSubmessage entryBody + in Map.foldlWithKey' (\acc k v -> acc <> encodeEntry k v) mempty m + {-# INLINE gProtoEncode #-} + +-- K1: ProtoMap field — Field n (ProtoMap k v). Decode by collecting all +-- repeated submessage entries for the field number and merging them. +instance {-# OVERLAPPING #-} + (KnownNat n, Ord k, ProtoDecode k, ProtoDefault k, ProtoDecode v, ProtoDefault v) + => GProtoDecode (K1 i (Field n (ProtoMap k v))) where + gProtoDecode rfs = + let fn = fromIntegral (natVal (Proxy @n)) + raws = [raw | (n', raw) <- rfs, n' == fn] + in do + entries <- traverse decodeMapEntry raws + Right (K1 (Field (ProtoMap (Map.unions entries)))) + {-# INLINE gProtoDecode #-} + +-- | Decode a single map entry submessage into a singleton Map. +decodeMapEntry :: (Ord k, ProtoDecode k, ProtoDefault k, ProtoDecode v, ProtoDefault v) + => RawField -> Either DecodeError (Map.Map k v) +decodeMapEntry (RawBytes bs) = do + rfs <- parseFields bs + k <- case lookupLast 1 rfs of + Nothing -> Right protoDefault + Just raw -> protoDecodeValue raw + v <- case lookupLast 2 rfs of + Nothing -> Right protoDefault + Just raw -> protoDecodeValue raw + Right (Map.singleton k v) +decodeMapEntry _ = Left (UnexpectedWireType 0 WireLengthDelimited WireVarint) diff --git a/src/Spire/Protobuf/Wire.hs b/src/Spire/Protobuf/Wire.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Protobuf/Wire.hs @@ -0,0 +1,249 @@ +-- | Protobuf wire format primitives. +-- +-- The proto3 wire format uses 5 wire types. Each field on the wire is +-- a tag (field_number << 3 | wire_type) followed by the value. +-- +-- This module provides low-level encoding and decoding of varints, +-- fixed-width values, and length-delimited fields. +module Spire.Protobuf.Wire + ( -- * Wire types + WireType (..) + -- * Tags + , encodeTag + , decodeTag + -- * Varint encoding/decoding + , encodeVarint + , decodeVarint + -- * Zigzag encoding (for sint32/sint64) + , zigzagEncode + , zigzagDecode + -- * Fixed-width encoding + , encodeFixed32 + , encodeFixed64 + , decodeFixed32 + , decodeFixed64 + -- * Float/Double encoding + , encodeProtoFloat + , encodeProtoDouble + , decodeProtoFloat + , decodeProtoDouble + -- * Length-delimited + , encodeLengthDelimited + , decodeLengthDelimited + -- * Field skipping + , skipField + ) where + +import Prelude hiding (encodeFloat, decodeFloat) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import Data.Int (Int64) +import Data.Word (Word8, Word32, Word64) +import GHC.Float (castWord32ToFloat, castFloatToWord32, + castWord64ToDouble, castDoubleToWord64) + + +-- | Proto3 wire types. +data WireType + = WireVarint -- ^ 0: int32, int64, uint32, uint64, sint32, sint64, bool, enum + | WireFixed64 -- ^ 1: fixed64, sfixed64, double + | WireLengthDelimited -- ^ 2: string, bytes, embedded messages, packed repeated + | WireFixed32 -- ^ 5: fixed32, sfixed32, float + deriving (Show, Eq) + +wireTypeId :: WireType -> Word8 +wireTypeId WireVarint = 0 +wireTypeId WireFixed64 = 1 +wireTypeId WireLengthDelimited = 2 +wireTypeId WireFixed32 = 5 + +wireTypeFromId :: Word8 -> Maybe WireType +wireTypeFromId 0 = Just WireVarint +wireTypeFromId 1 = Just WireFixed64 +wireTypeFromId 2 = Just WireLengthDelimited +wireTypeFromId 5 = Just WireFixed32 +wireTypeFromId _ = Nothing + + +-- =================================================================== +-- Tags +-- =================================================================== + +-- | Encode a field tag (field_number << 3 | wire_type). +encodeTag :: Int -> WireType -> B.Builder +encodeTag fieldNum wt = + encodeVarint (fromIntegral fieldNum `shiftL` 3 .|. fromIntegral (wireTypeId wt)) +{-# INLINE encodeTag #-} + +-- | Decode a field tag. Returns (field_number, wire_type, remaining bytes). +decodeTag :: ByteString -> Maybe (Int, WireType, ByteString) +decodeTag bs = do + (val, rest) <- decodeVarint bs + let wireId = fromIntegral (val .&. 0x07) :: Word8 + fieldNum = fromIntegral (val `shiftR` 3) + wt <- wireTypeFromId wireId + Just (fieldNum, wt, rest) +{-# INLINE decodeTag #-} + + +-- =================================================================== +-- Varint encoding/decoding +-- =================================================================== + +-- | Encode a value as a varint (7 bits per byte, MSB continuation). +encodeVarint :: Word64 -> B.Builder +encodeVarint n + | n < 0x80 = B.word8 (fromIntegral n) + | otherwise = B.word8 (fromIntegral (n .&. 0x7F) .|. 0x80) + <> encodeVarint (n `shiftR` 7) +{-# INLINE encodeVarint #-} + +-- | Decode a varint. Returns (value, remaining bytes). +-- Rejects overlong encodings (more than 10 bytes or invalid high bits +-- in the 10th byte). +decodeVarint :: ByteString -> Maybe (Word64, ByteString) +decodeVarint = go 0 0 + where + go !acc !shft !bs = case BS.uncons bs of + Nothing -> Nothing + Just (b, rest) -> + let val = acc .|. (fromIntegral (b .&. 0x7F) `shiftL` shft) + in if b .&. 0x80 == 0 + then if shft == 63 && (b .&. 0x7E) /= 0 + then Nothing -- reject overlong encoding at byte 10 + else Just (val, rest) + else if shft >= 63 + then Nothing -- overflow protection + else go val (shft + 7) rest +{-# INLINE decodeVarint #-} + + +-- =================================================================== +-- Zigzag encoding (for sint32/sint64) +-- =================================================================== + +-- | Zigzag-encode a signed integer: maps negatives to odds, positives to evens. +-- This makes small negative numbers small on the wire. +zigzagEncode :: Int64 -> Word64 +zigzagEncode n = fromIntegral ((n `shiftL` 1) `xor` (n `shiftR` 63)) +{-# INLINE zigzagEncode #-} + +-- | Zigzag-decode. +zigzagDecode :: Word64 -> Int64 +zigzagDecode n = fromIntegral ((n `shiftR` 1) `xor` negate (n .&. 1)) +{-# INLINE zigzagDecode #-} + + +-- =================================================================== +-- Fixed-width encoding +-- =================================================================== + +-- | Encode a 32-bit value in little-endian. +encodeFixed32 :: Word32 -> B.Builder +encodeFixed32 = B.word32LE +{-# INLINE encodeFixed32 #-} + +-- | Encode a 64-bit value in little-endian. +encodeFixed64 :: Word64 -> B.Builder +encodeFixed64 = B.word64LE +{-# INLINE encodeFixed64 #-} + +-- | Decode a 32-bit little-endian value. +decodeFixed32 :: ByteString -> Maybe (Word32, ByteString) +decodeFixed32 bs + | BS.length bs < 4 = Nothing + | otherwise = + let b0 = fromIntegral (BS.index bs 0) :: Word32 + b1 = fromIntegral (BS.index bs 1) :: Word32 + b2 = fromIntegral (BS.index bs 2) :: Word32 + b3 = fromIntegral (BS.index bs 3) :: Word32 + in Just (b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24), + BS.drop 4 bs) +{-# INLINE decodeFixed32 #-} + +-- | Decode a 64-bit little-endian value. +decodeFixed64 :: ByteString -> Maybe (Word64, ByteString) +decodeFixed64 bs + | BS.length bs < 8 = Nothing + | otherwise = + let readByte i = fromIntegral (BS.index bs i) :: Word64 + in Just ( readByte 0 .|. (readByte 1 `shiftL` 8) .|. (readByte 2 `shiftL` 16) + .|. (readByte 3 `shiftL` 24) .|. (readByte 4 `shiftL` 32) + .|. (readByte 5 `shiftL` 40) .|. (readByte 6 `shiftL` 48) + .|. (readByte 7 `shiftL` 56), + BS.drop 8 bs) +{-# INLINE decodeFixed64 #-} + + +-- =================================================================== +-- Float/Double +-- =================================================================== + +-- | Encode a Float (as fixed32, little-endian IEEE 754). +encodeProtoFloat :: Float -> B.Builder +encodeProtoFloat = encodeFixed32 . castFloatToWord32 +{-# INLINE encodeProtoFloat #-} + +-- | Encode a Double (as fixed64, little-endian IEEE 754). +encodeProtoDouble :: Double -> B.Builder +encodeProtoDouble = encodeFixed64 . castDoubleToWord64 +{-# INLINE encodeProtoDouble #-} + +-- | Decode a Float. +decodeProtoFloat :: ByteString -> Maybe (Float, ByteString) +decodeProtoFloat bs = do + (w, rest) <- decodeFixed32 bs + Just (castWord32ToFloat w, rest) +{-# INLINE decodeProtoFloat #-} + +-- | Decode a Double. +decodeProtoDouble :: ByteString -> Maybe (Double, ByteString) +decodeProtoDouble bs = do + (w, rest) <- decodeFixed64 bs + Just (castWord64ToDouble w, rest) +{-# INLINE decodeProtoDouble #-} + + +-- =================================================================== +-- Length-delimited +-- =================================================================== + +-- | Encode a length-delimited value: varint length + bytes. +encodeLengthDelimited :: ByteString -> B.Builder +encodeLengthDelimited bs = + encodeVarint (fromIntegral (BS.length bs)) <> B.byteString bs +{-# INLINE encodeLengthDelimited #-} + +-- | Decode a length-delimited value. Returns (bytes, remaining). +-- Zero-copy: returns a slice of the input ByteString. +decodeLengthDelimited :: ByteString -> Maybe (ByteString, ByteString) +decodeLengthDelimited bs = do + (len, rest) <- decodeVarint bs + let n = fromIntegral len + if BS.length rest < n + then Nothing + else Just (BS.take n rest, BS.drop n rest) +{-# INLINE decodeLengthDelimited #-} + + +-- =================================================================== +-- Field skipping (for unknown fields) +-- =================================================================== + +-- | Skip a field value based on its wire type. Returns remaining bytes. +skipField :: WireType -> ByteString -> Maybe ByteString +skipField WireVarint bs = do + (_, rest) <- decodeVarint bs + Just rest +skipField WireFixed64 bs + | BS.length bs >= 8 = Just (BS.drop 8 bs) + | otherwise = Nothing +skipField WireLengthDelimited bs = do + (_, rest) <- decodeLengthDelimited bs + Just rest +skipField WireFixed32 bs + | BS.length bs >= 4 = Just (BS.drop 4 bs) + | otherwise = Nothing +{-# INLINE skipField #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1511 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import Control.Exception (try, SomeException) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Either (isRight) +import Data.Int (Int32, Int64) +import Data.List (isInfixOf) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import System.IO (hSetBinaryMode, hFlush, hClose, hGetContents) +import System.Process (proc, createProcess, waitForProcess, + readProcess, StdStream(..), std_in, std_out, std_err) + +import Spire.Protobuf +import Spire.Protobuf.Wire +import Spire.Protobuf.Encode +import Spire.Protobuf.Decode + + +-- =================================================================== +-- Test helpers +-- =================================================================== + +assert :: String -> Bool -> IO () +assert label True = putStrLn $ " OK: " ++ label +assert label False = error $ "FAIL: " ++ label + +-- | Helper: build a ByteString from a Builder-producing function +buildBS :: ProtoBuilder -> ByteString +buildBS = runProtoBuilder + + +-- =================================================================== +-- Test message types +-- =================================================================== + +data Simple = Simple + { sName :: Field 1 Text + , sAge :: Field 2 Int32 + } deriving (Show, Eq, Generic) + +instance ProtoMessage Simple + +data WithOpt = WithOpt + { wName :: Field 1 Text + , wNick :: Field 2 (Maybe Text) + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithOpt + +data WithList = WithList + { wTags :: Field 1 [Text] + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithList + +data AllDefaults = AllDefaults + { dName :: Field 1 Text + , dAge :: Field 2 Int32 + , dFlag :: Field 3 Bool + } deriving (Show, Eq, Generic) + +instance ProtoMessage AllDefaults + +data Address = Address + { city :: Field 1 Text + , addrZip :: Field 2 Int32 + } deriving (Show, Eq, Generic) + +instance ProtoMessage Address + +data Person = Person + { pName :: Field 1 Text + , pAddr :: Field 2 (Maybe Address) + } deriving (Show, Eq, Generic) + +instance ProtoMessage Person + +data WithRepeatedInt = WithRepeatedInt + { riName :: Field 1 Text + , riNums :: Field 2 [Int32] + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithRepeatedInt + + +-- =================================================================== +-- 1. Wire primitives: Varint +-- =================================================================== + +testVarintRoundtrip :: IO () +testVarintRoundtrip = do + putStrLn "=== Varint roundtrip ===" + let check val = do + let bs = buildBS (ProtoBuilder (varintSz val) (encodeVarint val)) + case decodeVarint bs of + Just (v, rest) -> do + assert ("varint roundtrip " ++ show val) (v == val) + assert ("varint no leftover " ++ show val) (BS.null rest) + Nothing -> error $ "FAIL: varint decode failed for " ++ show val + check 0 + check 1 + check 127 + check 128 + check 300 + check (fromIntegral (maxBound @Word32) :: Word64) + check (maxBound @Word64) + where + varintSz :: Word64 -> Int + varintSz n + | n < 0x80 = 1 + | n < 0x4000 = 2 + | n < 0x200000 = 3 + | n < 0x10000000 = 4 + | n < 0x0800000000 = 5 + | n < 0x040000000000 = 6 + | n < 0x02000000000000 = 7 + | n < 0x0100000000000000 = 8 + | n < 0x8000000000000000 = 9 + | otherwise = 10 + +-- =================================================================== +-- 2. Wire primitives: Zigzag +-- =================================================================== + +testZigzagRoundtrip :: IO () +testZigzagRoundtrip = do + putStrLn "=== Zigzag roundtrip ===" + let check val = assert ("zigzag roundtrip " ++ show val) + (zigzagDecode (zigzagEncode val) == val) + check 0 + check (-1) + check 1 + check (-2) + check 2 + check (minBound @Int64) + check (maxBound @Int64) + + +-- =================================================================== +-- 3. Wire primitives: Fixed32/Fixed64 +-- =================================================================== + +testFixed32Roundtrip :: IO () +testFixed32Roundtrip = do + putStrLn "=== Fixed32 roundtrip ===" + let check val = do + let bs = buildBS (ProtoBuilder 4 (encodeFixed32 val)) + case decodeFixed32 bs of + Just (v, rest) -> do + assert ("fixed32 roundtrip " ++ show val) (v == val) + assert ("fixed32 no leftover " ++ show val) (BS.null rest) + Nothing -> error $ "FAIL: fixed32 decode failed for " ++ show val + check 0 + check 1 + check 255 + check 65535 + check (maxBound @Word32) + +testFixed64Roundtrip :: IO () +testFixed64Roundtrip = do + putStrLn "=== Fixed64 roundtrip ===" + let check val = do + let bs = buildBS (ProtoBuilder 8 (encodeFixed64 val)) + case decodeFixed64 bs of + Just (v, rest) -> do + assert ("fixed64 roundtrip " ++ show val) (v == val) + assert ("fixed64 no leftover " ++ show val) (BS.null rest) + Nothing -> error $ "FAIL: fixed64 decode failed for " ++ show val + check 0 + check 1 + check (maxBound @Word64) + check 0xDEADBEEFCAFEBABE + + +-- =================================================================== +-- 4. Wire primitives: Float/Double +-- =================================================================== + +testFloatRoundtrip :: IO () +testFloatRoundtrip = do + putStrLn "=== Float roundtrip ===" + let check val = do + let bs = buildBS (ProtoBuilder 4 (encodeProtoFloat val)) + case decodeProtoFloat bs of + Just (v, rest) -> do + assert ("float roundtrip " ++ show val) (v == val) + assert ("float no leftover " ++ show val) (BS.null rest) + Nothing -> error $ "FAIL: float decode failed for " ++ show val + check 0.0 + check 1.5 + check (-3.14) + check (1.0 / 0.0) -- infinity + + -- NaN: NaN /= NaN, so test with isNaN + let nanBs = buildBS (ProtoBuilder 4 (encodeProtoFloat (0.0 / 0.0))) + case decodeProtoFloat nanBs of + Just (v, rest) -> do + assert "float NaN roundtrip" (isNaN v) + assert "float NaN no leftover" (BS.null rest) + Nothing -> error "FAIL: float NaN decode failed" + +testDoubleRoundtrip :: IO () +testDoubleRoundtrip = do + putStrLn "=== Double roundtrip ===" + let check val = do + let bs = buildBS (ProtoBuilder 8 (encodeProtoDouble val)) + case decodeProtoDouble bs of + Just (v, rest) -> do + assert ("double roundtrip " ++ show val) (v == val) + assert ("double no leftover " ++ show val) (BS.null rest) + Nothing -> error $ "FAIL: double decode failed for " ++ show val + check 0.0 + check 1.5 + check (-3.14) + check (1.0 / 0.0) + + let nanBs = buildBS (ProtoBuilder 8 (encodeProtoDouble (0.0 / 0.0))) + case decodeProtoDouble nanBs of + Just (v, rest) -> do + assert "double NaN roundtrip" (isNaN v) + assert "double NaN no leftover" (BS.null rest) + Nothing -> error "FAIL: double NaN decode failed" + + +-- =================================================================== +-- 5. Wire primitives: Tags +-- =================================================================== + +testTagEncodeDecode :: IO () +testTagEncodeDecode = do + putStrLn "=== Tag encode/decode ===" + + -- field 1, varint + let bs1 = buildBS (ProtoBuilder 1 (encodeTag 1 WireVarint)) + case decodeTag bs1 of + Just (fn, wt, rest) -> do + assert "tag field 1 varint: field number" (fn == 1) + assert "tag field 1 varint: wire type" (wt == WireVarint) + assert "tag field 1 varint: no leftover" (BS.null rest) + Nothing -> error "FAIL: tag decode failed" + + -- field 15, length-delimited + let bs2 = buildBS (ProtoBuilder 1 (encodeTag 15 WireLengthDelimited)) + case decodeTag bs2 of + Just (fn, wt, rest) -> do + assert "tag field 15 ld: field number" (fn == 15) + assert "tag field 15 ld: wire type" (wt == WireLengthDelimited) + assert "tag field 15 ld: no leftover" (BS.null rest) + Nothing -> error "FAIL: tag decode failed" + + -- field 536870911 (max field number: 2^29 - 1) + let bs3 = buildBS (ProtoBuilder 5 (encodeTag 536870911 WireVarint)) + case decodeTag bs3 of + Just (fn, wt, _) -> do + assert "tag max field: field number" (fn == 536870911) + assert "tag max field: wire type" (wt == WireVarint) + Nothing -> error "FAIL: tag decode failed for max field" + + +-- =================================================================== +-- 6. Wire primitives: Length-delimited +-- =================================================================== + +testLengthDelimitedRoundtrip :: IO () +testLengthDelimitedRoundtrip = do + putStrLn "=== Length-delimited roundtrip ===" + + -- empty + let emptyBs = buildBS (ProtoBuilder 1 (encodeLengthDelimited BS.empty)) + case decodeLengthDelimited emptyBs of + Just (val, rest) -> do + assert "length-delimited empty: value" (val == BS.empty) + assert "length-delimited empty: no leftover" (BS.null rest) + Nothing -> error "FAIL: length-delimited empty decode failed" + + -- "hello" + let hello = "hello" :: ByteString + helloBs = buildBS (ProtoBuilder (1 + BS.length hello) (encodeLengthDelimited hello)) + case decodeLengthDelimited helloBs of + Just (val, rest) -> do + assert "length-delimited hello: value" (val == hello) + assert "length-delimited hello: no leftover" (BS.null rest) + Nothing -> error "FAIL: length-delimited hello decode failed" + + -- 1000 bytes + let bigBs = BS.replicate 1000 0x42 + bigEncoded = buildBS (ProtoBuilder (2 + 1000) (encodeLengthDelimited bigBs)) + case decodeLengthDelimited bigEncoded of + Just (val, rest) -> do + assert "length-delimited 1000 bytes: value" (val == bigBs) + assert "length-delimited 1000 bytes: no leftover" (BS.null rest) + Nothing -> error "FAIL: length-delimited 1000 bytes decode failed" + + +-- =================================================================== +-- 7. Wire primitives: Skip field +-- =================================================================== + +testSkipField :: IO () +testSkipField = do + putStrLn "=== Skip field ===" + + -- skip varint + let varintBs = buildBS (ProtoBuilder 1 (encodeVarint 42)) <> "tail" + case skipField WireVarint varintBs of + Just rest -> assert "skip varint" (rest == "tail") + Nothing -> error "FAIL: skip varint failed" + + -- skip fixed32 + let f32Bs = buildBS (ProtoBuilder 4 (encodeFixed32 0)) <> "tail" + case skipField WireFixed32 f32Bs of + Just rest -> assert "skip fixed32" (rest == "tail") + Nothing -> error "FAIL: skip fixed32 failed" + + -- skip fixed64 + let f64Bs = buildBS (ProtoBuilder 8 (encodeFixed64 0)) <> "tail" + case skipField WireFixed64 f64Bs of + Just rest -> assert "skip fixed64" (rest == "tail") + Nothing -> error "FAIL: skip fixed64 failed" + + -- skip length-delimited + let ldBs = buildBS (ProtoBuilder 6 (encodeLengthDelimited "hello")) <> "tail" + case skipField WireLengthDelimited ldBs of + Just rest -> assert "skip length-delimited" (rest == "tail") + Nothing -> error "FAIL: skip length-delimited failed" + + +-- =================================================================== +-- 8. Encoding: ProtoEncode Int32 +-- =================================================================== + +testEncodeInt32 :: IO () +testEncodeInt32 = do + putStrLn "=== ProtoEncode Int32 ===" + + -- Non-default encodes as varint + let pb = protoEncodeValue @Int32 42 + assert "Int32 42: encodes non-empty" (pbLength pb > 0) + + -- Field encoding: tag + value + let fpb = encodeField (Field 42 :: Field 1 Int32) + assert "Int32 field 1 42: encodes non-empty" (pbLength fpb > 0) + + -- Default (0) is skipped + let defPb = encodeField (Field 0 :: Field 1 Int32) + assert "Int32 default (0) is skipped" (pbLength defPb == 0) + + +-- =================================================================== +-- 9. Encoding: ProtoEncode Bool +-- =================================================================== + +testEncodeBool :: IO () +testEncodeBool = do + putStrLn "=== ProtoEncode Bool ===" + + -- True -> varint 1 + let truePb = protoEncodeValue True + let trueBytes = runProtoBuilder truePb + case decodeVarint trueBytes of + Just (v, _) -> assert "Bool True encodes to varint 1" (v == 1) + Nothing -> error "FAIL: Bool True encode failed" + + -- False -> field is skipped (default) + let defPb = encodeField (Field False :: Field 1 Bool) + assert "Bool False (default) is skipped" (pbLength defPb == 0) + + +-- =================================================================== +-- 10. Encoding: ProtoEncode Text +-- =================================================================== + +testEncodeText :: IO () +testEncodeText = do + putStrLn "=== ProtoEncode Text ===" + + let pb = protoEncodeValue ("hello" :: Text) + -- length-delimited: varint(5) + "hello" = 6 bytes + assert "Text 'hello': length 6" (pbLength pb == 6) + + -- Field encoding + let fpb = encodeField (Field "hello" :: Field 1 Text) + assert "Text field non-empty" (pbLength fpb > 0) + + -- Default ("") is skipped + let defPb = encodeField (Field "" :: Field 1 Text) + assert "Text default ('') is skipped" (pbLength defPb == 0) + + +-- =================================================================== +-- 11. Encoding: ProtoEncode ByteString +-- =================================================================== + +testEncodeByteString :: IO () +testEncodeByteString = do + putStrLn "=== ProtoEncode ByteString ===" + + let bs = "world" :: ByteString + pb = protoEncodeValue bs + -- varint(5) + "world" = 6 bytes + assert "ByteString 'world': length 6" (pbLength pb == 6) + + -- Default (empty) is skipped + let defPb = encodeField (Field BS.empty :: Field 1 ByteString) + assert "ByteString default (empty) is skipped" (pbLength defPb == 0) + + +-- =================================================================== +-- 12. Encoding: Optional and Repeated fields +-- =================================================================== + +testEncodeOptionalField :: IO () +testEncodeOptionalField = do + putStrLn "=== Optional field encoding ===" + + -- Nothing -> empty + let nothingPb = encodeOptionalField (Field Nothing :: Field 1 (Maybe Text)) + assert "Nothing encodes to empty" (pbLength nothingPb == 0) + + -- Just val -> field + let justPb = encodeOptionalField (Field (Just "hi") :: Field 1 (Maybe Text)) + assert "Just 'hi' encodes non-empty" (pbLength justPb > 0) + +testEncodeRepeatedField :: IO () +testEncodeRepeatedField = do + putStrLn "=== Repeated field encoding ===" + + -- Empty list -> empty + let emptyPb = encodeRepeatedField (Field [] :: Field 1 [Text]) + assert "empty list encodes to empty" (pbLength emptyPb == 0) + + -- Non-empty list + let listPb = encodeRepeatedField (Field ["a", "b", "c"] :: Field 1 [Text]) + assert "list [a,b,c] encodes non-empty" (pbLength listPb > 0) + + +-- =================================================================== +-- 13. Encoding: ProtoBuilder length tracking +-- =================================================================== + +testProtoBuilderLength :: IO () +testProtoBuilderLength = do + putStrLn "=== ProtoBuilder length tracking ===" + + -- Build several values and verify pbLength matches actual encoded bytes + let pb1 = protoEncodeValue @Int32 42 + bs1 = runProtoBuilder pb1 + assert "Int32 42: pbLength matches actual" (pbLength pb1 == BS.length bs1) + + let pb2 = protoEncodeValue ("hello world" :: Text) + bs2 = runProtoBuilder pb2 + assert "Text: pbLength matches actual" (pbLength pb2 == BS.length bs2) + + let pb3 = protoEncodeValue @Double 3.14 + bs3 = runProtoBuilder pb3 + assert "Double: pbLength matches actual" (pbLength pb3 == BS.length bs3) + + -- Combined + let combined = pb1 <> pb2 <> pb3 + bsAll = runProtoBuilder combined + assert "combined: pbLength matches actual" (pbLength combined == BS.length bsAll) + + +-- =================================================================== +-- 14. Decoding: ProtoDecode Int32 +-- =================================================================== + +testDecodeInt32 :: IO () +testDecodeInt32 = do + putStrLn "=== ProtoDecode Int32 ===" + + assert "Int32 from varint 42" (protoDecodeValue @Int32 (RawVarint 42) == Right 42) + assert "Int32 from varint 0" (protoDecodeValue @Int32 (RawVarint 0) == Right 0) + + -- Wrong wire type + case protoDecodeValue @Int32 (RawBytes "hello") of + Left _ -> assert "Int32 rejects RawBytes" True + Right _ -> assert "Int32 rejects RawBytes" False + + +-- =================================================================== +-- 15. Decoding: ProtoDecode Text +-- =================================================================== + +testDecodeText :: IO () +testDecodeText = do + putStrLn "=== ProtoDecode Text ===" + + assert "Text from RawBytes 'hello'" (protoDecodeValue @Text (RawBytes "hello") == Right "hello") + assert "Text from RawBytes empty" (protoDecodeValue @Text (RawBytes "") == Right "") + + -- Invalid UTF-8 + let badUtf8 = BS.pack [0xFF, 0xFE] + case protoDecodeValue @Text (RawBytes badUtf8) of + Left InvalidUtf8 -> assert "Text rejects invalid UTF-8" True + _ -> assert "Text rejects invalid UTF-8" False + + +-- =================================================================== +-- 16. Decoding: ProtoDecode ByteString +-- =================================================================== + +testDecodeByteString :: IO () +testDecodeByteString = do + putStrLn "=== ProtoDecode ByteString ===" + + assert "ByteString from RawBytes" (protoDecodeValue @ByteString (RawBytes "hello") == Right "hello") + assert "ByteString from RawBytes empty" (protoDecodeValue @ByteString (RawBytes "") == Right "") + + +-- =================================================================== +-- 17. Decoding: parseFields +-- =================================================================== + +testParseFields :: IO () +testParseFields = do + putStrLn "=== parseFields ===" + + -- Encode a Simple message and parse the raw fields + let msg = Simple (Field "Alice") (Field 30) + bs = encode msg + case parseFields bs of + Right fields -> do + assert "parseFields: 2 fields" (length fields == 2) + -- field 1 should be RawBytes (text) + case lookup 1 fields of + Just (RawBytes v) -> assert "parseFields: field 1 is 'Alice'" (v == "Alice") + _ -> assert "parseFields: field 1 is RawBytes" False + -- field 2 should be RawVarint + case lookup 2 fields of + Just (RawVarint v) -> assert "parseFields: field 2 is 30" (v == 30) + _ -> assert "parseFields: field 2 is RawVarint" False + Left err -> error $ "FAIL: parseFields failed: " ++ show err + + -- Empty input + case parseFields BS.empty of + Right fields -> assert "parseFields: empty input -> empty list" (null fields) + Left err -> error $ "FAIL: parseFields empty failed: " ++ show err + + +-- =================================================================== +-- 18. Decoding: Unknown fields skipped +-- =================================================================== + +testUnknownFields :: IO () +testUnknownFields = do + putStrLn "=== Unknown fields skipped ===" + + -- Encode a Simple message, then try to decode it as AllDefaults + -- (which expects fields 1, 2, 3). Since Simple only has fields 1, 2, + -- field 3 will use its default. + let msg = Simple (Field "Bob") (Field 25) + bs = encode msg + case decode @AllDefaults bs of + Right ad -> do + assert "unknown fields: name preserved" (unField (dName ad) == "Bob") + assert "unknown fields: age preserved" (unField (dAge ad) == 25) + assert "unknown fields: flag defaults to False" (unField (dFlag ad) == False) + Left err -> error $ "FAIL: unknown fields decode failed: " ++ show err + + +-- =================================================================== +-- 19. ProtoMessage: Simple roundtrip +-- =================================================================== + +testSimpleRoundtrip :: IO () +testSimpleRoundtrip = do + putStrLn "=== Simple message roundtrip ===" + + let msg = Simple (Field "Alice") (Field 30) + bs = encode msg + case decode bs of + Right msg' -> assert "Simple roundtrip" (msg == msg') + Left err -> error $ "FAIL: Simple roundtrip: " ++ show err + + +-- =================================================================== +-- 20. ProtoMessage: Optional fields +-- =================================================================== + +testOptionalRoundtrip :: IO () +testOptionalRoundtrip = do + putStrLn "=== Optional fields roundtrip ===" + + -- With value + let msg1 = WithOpt (Field "Alice") (Field (Just "Ali")) + case decode (encode msg1) of + Right msg1' -> assert "WithOpt Just roundtrip" (msg1 == msg1') + Left err -> error $ "FAIL: WithOpt Just roundtrip: " ++ show err + + -- Without value + let msg2 = WithOpt (Field "Bob") (Field Nothing) + case decode (encode msg2) of + Right msg2' -> assert "WithOpt Nothing roundtrip" (msg2 == msg2') + Left err -> error $ "FAIL: WithOpt Nothing roundtrip: " ++ show err + + +-- =================================================================== +-- 21. ProtoMessage: Repeated fields +-- =================================================================== + +testRepeatedRoundtrip :: IO () +testRepeatedRoundtrip = do + putStrLn "=== Repeated fields roundtrip ===" + + let msg = WithList (Field ["alpha", "beta", "gamma"]) + case decode (encode msg) of + Right msg' -> assert "WithList roundtrip" (msg == msg') + Left err -> error $ "FAIL: WithList roundtrip: " ++ show err + + -- Empty list + let msgEmpty = WithList (Field []) + case decode (encode msgEmpty) of + Right msg' -> assert "WithList empty roundtrip" (msg' == msgEmpty) + Left err -> error $ "FAIL: WithList empty roundtrip: " ++ show err + + +-- =================================================================== +-- 22. ProtoMessage: All-default values +-- =================================================================== + +testDefaultsEncoding :: IO () +testDefaultsEncoding = do + putStrLn "=== Default values encoding ===" + + let msg = AllDefaults (Field "") (Field 0) (Field False) + bs = encode msg + assert "all-default message encodes to empty bytes" (BS.null bs) + + +-- =================================================================== +-- 23. ProtoMessage: Missing fields use defaults +-- =================================================================== + +testMissingFieldsDefault :: IO () +testMissingFieldsDefault = do + putStrLn "=== Missing fields use defaults ===" + + -- Decode empty bytes as AllDefaults + case decode @AllDefaults BS.empty of + Right ad -> do + assert "missing field: name defaults to ''" (unField (dName ad) == "") + assert "missing field: age defaults to 0" (unField (dAge ad) == 0) + assert "missing field: flag defaults to False" (unField (dFlag ad) == False) + Left err -> error $ "FAIL: missing fields decode: " ++ show err + + +-- =================================================================== +-- 24. Nested message roundtrip +-- =================================================================== + +testNestedMessageRoundtrip :: IO () +testNestedMessageRoundtrip = do + putStrLn "=== Nested message roundtrip ===" + + let addr = Address (Field "Springfield") (Field 62704) + person = Person (Field "Homer") (Field (Just addr)) + bs = encode person + case decode bs of + Right person' -> assert "nested message roundtrip" (person == person') + Left err -> error $ "FAIL: nested message roundtrip: " ++ show err + + -- Nested with Nothing + let person2 = Person (Field "Bart") (Field Nothing) + case decode (encode person2) of + Right person2' -> assert "nested message Nothing roundtrip" (person2 == person2') + Left err -> error $ "FAIL: nested Nothing roundtrip: " ++ show err + + +-- =================================================================== +-- 25. Out-of-order field decoding +-- =================================================================== + +testOutOfOrderDecoding :: IO () +testOutOfOrderDecoding = do + putStrLn "=== Out-of-order field decoding ===" + + -- Manually build bytes with field 2 (Int32, varint) before field 1 (Text, length-delimited) + -- Field 2: tag = (2 << 3 | 0) = 16 = 0x10, value = varint 25 + -- Field 1: tag = (1 << 3 | 2) = 10 = 0x0A, value = length-delimited "Alice" + let field2Bytes = buildBS (ProtoBuilder 1 (encodeTag 2 WireVarint)) + <> buildBS (ProtoBuilder 1 (encodeVarint 25)) + field1Bytes = buildBS (ProtoBuilder 1 (encodeTag 1 WireLengthDelimited)) + <> buildBS (ProtoBuilder 6 (encodeLengthDelimited "Alice")) + outOfOrder = field2Bytes <> field1Bytes + case decode @Simple outOfOrder of + Right msg -> do + assert "out-of-order: name is Alice" (unField (sName msg) == "Alice") + assert "out-of-order: age is 25" (unField (sAge msg) == 25) + Left err -> error $ "FAIL: out-of-order decode: " ++ show err + + +-- =================================================================== +-- 26. Duplicate field (last-wins) +-- =================================================================== + +testDuplicateFieldLastWins :: IO () +testDuplicateFieldLastWins = do + putStrLn "=== Duplicate field (last-wins) ===" + + -- Encode field 1 as "first", then field 2 as 10, then field 1 again as "second" + let f1first = buildBS (ProtoBuilder 1 (encodeTag 1 WireLengthDelimited)) + <> buildBS (ProtoBuilder 6 (encodeLengthDelimited "first")) + f2val = buildBS (ProtoBuilder 1 (encodeTag 2 WireVarint)) + <> buildBS (ProtoBuilder 1 (encodeVarint 10)) + f1second = buildBS (ProtoBuilder 1 (encodeTag 1 WireLengthDelimited)) + <> buildBS (ProtoBuilder 7 (encodeLengthDelimited "second")) + combined = f1first <> f2val <> f1second + case decode @Simple combined of + Right msg -> do + assert "duplicate field last-wins: name is 'second'" (unField (sName msg) == "second") + assert "duplicate field last-wins: age is 10" (unField (sAge msg) == 10) + Left err -> error $ "FAIL: duplicate field decode: " ++ show err + + +-- =================================================================== +-- 27. Malformed input tests +-- =================================================================== + +testMalformedInput :: IO () +testMalformedInput = do + putStrLn "=== Malformed input tests ===" + + -- Truncated varint: 0x80 has continuation bit set but no following byte + let truncVarint = BS.pack [0x80] + case decode @Simple truncVarint of + Left _ -> assert "truncated varint returns Left" True + Right _ -> assert "truncated varint returns Left" False + + -- Truncated length-delimited: tag for field 1 string + varint length 100 + only 5 bytes + let tagBytes = buildBS (ProtoBuilder 1 (encodeTag 1 WireLengthDelimited)) + lenBytes = buildBS (ProtoBuilder 1 (encodeVarint 100)) + dataBytes = BS.replicate 5 0x41 + truncLD = tagBytes <> lenBytes <> dataBytes + case decode @Simple truncLD of + Left _ -> assert "truncated length-delimited returns Left" True + Right _ -> assert "truncated length-delimited returns Left" False + + -- Empty input: decode as Simple -> returns message with all defaults + case decode @Simple BS.empty of + Right msg -> do + assert "empty input: name defaults to ''" (unField (sName msg) == "") + assert "empty input: age defaults to 0" (unField (sAge msg) == 0) + Left err -> error $ "FAIL: empty input decode: " ++ show err + + -- Single byte 0xFF -> decode returns Left (invalid tag: wire type 7 is unknown) + let badByte = BS.pack [0xFF] + case decode @Simple badByte of + Left _ -> assert "single byte 0xFF returns Left" True + Right _ -> assert "single byte 0xFF returns Left" False + + +-- =================================================================== +-- 28. Overlong varint rejection +-- =================================================================== + +testOverlongVarintRejection :: IO () +testOverlongVarintRejection = do + putStrLn "=== Overlong varint rejection ===" + + -- Construct a 10-byte varint where byte 10 has bits 1-6 set. + -- 9 continuation bytes (0x80) + final byte with high bits: 0x7E (bits 1-6 set) + -- This represents a varint that overflows the 64-bit space. + let overlongVarint = BS.pack [0x80, 0x80, 0x80, 0x80, 0x80, + 0x80, 0x80, 0x80, 0x80, 0x7E] + case decodeVarint overlongVarint of + Nothing -> assert "overlong varint rejected" True + Just _ -> assert "overlong varint rejected" False + + -- A valid 10-byte varint (max Word64) should still decode + -- maxBound :: Word64 = 0xFFFFFFFFFFFFFFFF + -- As varint: 9 bytes of 0xFF + final byte 0x01 + let maxVarint = BS.pack [0xFF, 0xFF, 0xFF, 0xFF, 0xFF, + 0xFF, 0xFF, 0xFF, 0xFF, 0x01] + case decodeVarint maxVarint of + Just (v, rest) -> do + assert "max varint decodes correctly" (v == maxBound @Word64) + assert "max varint no leftover" (BS.null rest) + Nothing -> assert "max varint decodes correctly" False + + +-- =================================================================== +-- 29. Zigzag encoding of negative values +-- =================================================================== + +testZigzagNegativeEfficiency :: IO () +testZigzagNegativeEfficiency = do + putStrLn "=== Zigzag negative value efficiency ===" + + -- Small negatives should produce small zigzag-encoded values + assert "zigzag(-1) = 1" (zigzagEncode (-1) == 1) + assert "zigzag(-2) = 3" (zigzagEncode (-2) == 3) + assert "zigzag(-100) = 199" (zigzagEncode (-100) == 199) + + -- Positive values should also be small + assert "zigzag(0) = 0" (zigzagEncode 0 == 0) + assert "zigzag(1) = 2" (zigzagEncode 1 == 2) + assert "zigzag(100) = 200" (zigzagEncode 100 == 200) + + -- Verify zigzag of small negatives uses fewer bytes than plain int encoding + -- -1 as Int32 on wire (varint) is 10 bytes (sign-extended to Word64) + -- -1 as zigzag -> 1 -> 1 byte + let plainNeg1Bytes = BS.length $ runProtoBuilder (protoEncodeValue @Int32 (-1)) + zigzagNeg1 = zigzagEncode (-1) + zigzagVarintSz n + | n < 0x80 = 1 + | n < 0x4000 = 2 + | otherwise = 3 + assert "zigzag(-1) more compact than plain Int32(-1)" + (zigzagVarintSz zigzagNeg1 < plainNeg1Bytes) + + +-- =================================================================== +-- 30. Large message test +-- =================================================================== + +testLargeMessage :: IO () +testLargeMessage = do + putStrLn "=== Large message test ===" + + -- Create a message with a 10KB Text field and a 100-element repeated Int32 list + let bigText = T.replicate 10000 "a" -- 10KB text + nums = map fromIntegral [1..100 :: Int] :: [Int32] + msg = WithRepeatedInt (Field bigText) (Field nums) + bs = encode msg + case decode @WithRepeatedInt bs of + Right msg' -> do + assert "large message roundtrip" (msg == msg') + assert "large text preserved" (T.length (unField (riName msg')) == 10000) + assert "repeated list length preserved" (length (unField (riNums msg')) == 100) + Left err -> error $ "FAIL: large message roundtrip: " ++ show err + + +-- =================================================================== +-- 31. Wire compatibility with proto3 spec +-- =================================================================== + +-- | Equivalent of: +-- message TestCompat { +-- string name = 1; +-- int32 id = 2; +-- bool active = 3; +-- } +data TestCompat = TestCompat + { tcName :: Field 1 Text + , tcId :: Field 2 Int32 + , tcActive :: Field 3 Bool + } deriving (Show, Eq, Generic) + +instance ProtoMessage TestCompat + +testWireCompatibility :: IO () +testWireCompatibility = do + putStrLn "=== Wire compatibility with proto3 spec ===" + + let msg = TestCompat (Field "alice") (Field 42) (Field True) + encoded = encode msg + + -- Expected wire bytes computed from proto3 spec: + -- Field 1 (string): tag=0x0A (field 1, wire type 2), length=5, "alice" + -- Field 2 (int32): tag=0x10 (field 2, wire type 0), varint 42 = 0x2A + -- Field 3 (bool): tag=0x18 (field 3, wire type 0), varint 1 = 0x01 + let expected = BS.pack [0x0A, 0x05, 0x61, 0x6C, 0x69, 0x63, 0x65, 0x10, 0x2A, 0x18, 0x01] + + assert "wire compat: encode matches proto3 spec bytes" (encoded == expected) + + -- Reverse: decode known bytes and verify values + case decode @TestCompat expected of + Right msg' -> do + assert "wire compat: decode name" (unField (tcName msg') == "alice") + assert "wire compat: decode id" (unField (tcId msg') == 42) + assert "wire compat: decode active" (unField (tcActive msg') == True) + Left err -> error $ "FAIL: wire compat decode: " ++ show err + + +-- =================================================================== +-- 31b. Negative Int32 wire compatibility +-- =================================================================== + +testNegativeInt32Wire :: IO () +testNegativeInt32Wire = do + putStrLn "=== Negative Int32 wire compatibility ===" + + -- Proto3 encodes negative int32 as 10-byte varint (sign-extended to 64 bits). + -- Simple { sName = Field "test", sAge = Field (-1) } + -- Field 1 (Text "test"): tag = 0x0A (field 1, wire type 2), length = 4, "test" = 74 65 73 74 + -- Field 2 (Int32 -1): tag = 0x10 (field 2, wire type 0), + -- value = varint(0xFFFFFFFFFFFFFFFF) = FF FF FF FF FF FF FF FF FF 01 (10 bytes) + let msg = Simple (Field "test") (Field (-1)) + encoded = encode msg + expected = BS.pack + [ 0x0A, 0x04, 0x74, 0x65, 0x73, 0x74 -- field 1: "test" + , 0x10 -- field 2: tag + , 0xFF, 0xFF, 0xFF, 0xFF, 0xFF -- 10-byte varint for -1 + , 0xFF, 0xFF, 0xFF, 0xFF, 0x01 -- (sign-extended to 64 bits) + ] + assert "negative int32: encode matches proto3 spec" (encoded == expected) + + -- Reverse: decode known bytes + case decode @Simple expected of + Right msg' -> do + assert "negative int32: decode name" (unField (sName msg') == "test") + assert "negative int32: decode age" (unField (sAge msg') == -1) + Left err -> error $ "FAIL: negative int32 decode: " ++ show err + + +-- =================================================================== +-- 31c. Bool field wire format +-- =================================================================== + +testBoolWireFormat :: IO () +testBoolWireFormat = do + putStrLn "=== Bool field wire format ===" + + -- true encodes as varint 1; false is omitted (proto3 default) + -- AllDefaults { dName = "", dAge = 0, dFlag = True } + -- name="" -> skipped, age=0 -> skipped + -- field 3 (Bool True): tag = 0x18 (field 3, wire type 0), value = varint 1 = 0x01 + let msgTrue = AllDefaults (Field "") (Field 0) (Field True) + encodedTrue = encode msgTrue + expectedTrue = BS.pack [0x18, 0x01] + assert "bool true: encode matches proto3 spec" (encodedTrue == expectedTrue) + + case decode @AllDefaults expectedTrue of + Right msg' -> do + assert "bool true: decode flag" (unField (dFlag msg') == True) + assert "bool true: decode name default" (unField (dName msg') == "") + assert "bool true: decode age default" (unField (dAge msg') == 0) + Left err -> error $ "FAIL: bool true decode: " ++ show err + + -- false is proto3 default -> all-default message encodes to empty + let msgFalse = AllDefaults (Field "") (Field 0) (Field False) + encodedFalse = encode msgFalse + assert "bool false: omitted on wire (empty bytes)" (BS.null encodedFalse) + + +-- =================================================================== +-- 31d. Empty string field wire format +-- =================================================================== + +testEmptyStringWire :: IO () +testEmptyStringWire = do + putStrLn "=== Empty string field wire format ===" + + -- Proto3: "" is default for string, so present-but-empty is omitted. + -- Simple { sName = "", sAge = 42 } + -- name="" -> skipped, age=42 -> tag=0x10, varint 42=0x2A + let msg = Simple (Field "") (Field 42) + encoded = encode msg + expected = BS.pack [0x10, 0x2A] + assert "empty string: omitted on wire" (encoded == expected) + + case decode @Simple expected of + Right msg' -> do + assert "empty string: decode name defaults to ''" (unField (sName msg') == "") + assert "empty string: decode age" (unField (sAge msg') == 42) + Left err -> error $ "FAIL: empty string decode: " ++ show err + + +-- =================================================================== +-- 31e. Varint edge cases (multi-byte boundaries) +-- =================================================================== + +testVarintEdgeCases :: IO () +testVarintEdgeCases = do + putStrLn "=== Varint edge cases ===" + + -- Value 128: 2-byte varint 0x80 0x01 + -- Simple { sName = "", sAge = 128 } + -- name="" -> skipped, age=128 -> tag=0x10, varint [0x80, 0x01] + let msg128 = Simple (Field "") (Field 128) + encoded128 = encode msg128 + expected128 = BS.pack [0x10, 0x80, 0x01] + assert "varint 128: 2-byte encoding" (encoded128 == expected128) + + case decode @Simple expected128 of + Right msg' -> assert "varint 128: roundtrip" (unField (sAge msg') == 128) + Left err -> error $ "FAIL: varint 128 decode: " ++ show err + + -- Value 16384: 3-byte varint 0x80 0x80 0x01 + -- Simple { sName = "", sAge = 16384 } + let msg16384 = Simple (Field "") (Field 16384) + encoded16384 = encode msg16384 + expected16384 = BS.pack [0x10, 0x80, 0x80, 0x01] + assert "varint 16384: 3-byte encoding" (encoded16384 == expected16384) + + case decode @Simple expected16384 of + Right msg' -> assert "varint 16384: roundtrip" (unField (sAge msg') == 16384) + Left err -> error $ "FAIL: varint 16384 decode: " ++ show err + + +-- =================================================================== +-- 31f. Nested message wire bytes +-- =================================================================== + +testNestedMessageWire :: IO () +testNestedMessageWire = do + putStrLn "=== Nested message wire bytes ===" + + -- Person { pName = "Homer", pAddr = Just (Address { city = "NYC", addrZip = 100 }) } + -- + -- Address submessage: + -- field 1 (Text "NYC"): tag=0x0A, len=3, 4E 59 43 + -- field 2 (Int32 100): tag=0x10, varint 100=0x64 + -- submessage bytes: 0A 03 4E 59 43 10 64 (7 bytes) + -- + -- Person: + -- field 1 (Text "Homer"): tag=0x0A, len=5, 48 6F 6D 65 72 + -- field 2 (submessage): tag=0x12 (field 2, wire type 2), len=7, + let addr = Address (Field "NYC") (Field 100) + person = Person (Field "Homer") (Field (Just addr)) + encoded = encode person + expected = BS.pack + [ 0x0A, 0x05, 0x48, 0x6F, 0x6D, 0x65, 0x72 -- field 1: "Homer" + , 0x12, 0x07 -- field 2: tag + length 7 + , 0x0A, 0x03, 0x4E, 0x59, 0x43 -- submessage field 1: "NYC" + , 0x10, 0x64 -- submessage field 2: 100 + ] + assert "nested message: encode matches hand-computed bytes" (encoded == expected) + + case decode @Person expected of + Right person' -> do + assert "nested message: decode name" (unField (pName person') == "Homer") + case unField (pAddr person') of + Just addr' -> do + assert "nested message: decode city" (unField (city addr') == "NYC") + assert "nested message: decode zip" (unField (addrZip addr') == 100) + Nothing -> error "FAIL: nested message decode: addr is Nothing" + Left err -> error $ "FAIL: nested message wire decode: " ++ show err + + +-- =================================================================== +-- 31g. Repeated field (unpacked) wire bytes +-- =================================================================== + +testRepeatedFieldWire :: IO () +testRepeatedFieldWire = do + putStrLn "=== Repeated field (unpacked) wire bytes ===" + + -- WithList { wTags = ["ab", "cd"] } + -- Each string gets its own tag (field 1, wire type 2 = 0x0A): + -- "ab": tag=0x0A, len=2, 61 62 + -- "cd": tag=0x0A, len=2, 63 64 + let msg = WithList (Field ["ab", "cd"]) + encoded = encode msg + expected = BS.pack + [ 0x0A, 0x02, 0x61, 0x62 -- "ab" + , 0x0A, 0x02, 0x63, 0x64 -- "cd" + ] + assert "repeated unpacked: encode matches hand-computed bytes" (encoded == expected) + + case decode @WithList expected of + Right msg' -> assert "repeated unpacked: decode roundtrip" + (unField (wTags msg') == ["ab", "cd"]) + Left err -> error $ "FAIL: repeated unpacked decode: " ++ show err + + -- Verify that multiple entries for same field are correctly merged on decode + -- Manually construct: "ab" entry, then "cd" entry, then "ef" entry + let extraEntry = BS.pack [0x0A, 0x02, 0x65, 0x66] -- "ef" + extended = expected <> extraEntry + case decode @WithList extended of + Right msg' -> assert "repeated unpacked: merge 3 entries" + (unField (wTags msg') == ["ab", "cd", "ef"]) + Left err -> error $ "FAIL: repeated unpacked merge: " ++ show err + + +-- =================================================================== +-- 32. Packed repeated field decoding +-- =================================================================== + +data Packed = Packed + { pScores :: Field 1 [Int32] + } deriving (Show, Eq, Generic) + +instance ProtoMessage Packed + +testPackedRepeatedRoundtrip :: IO () +testPackedRepeatedRoundtrip = do + putStrLn "=== Packed repeated field decoding ===" + + -- Encode using packed format (single length-delimited blob) + let scores = [10, 20, 30, 40, 50] :: [Int32] + packedBytes = runProtoBuilder (encodePackedField (Field scores :: Field 1 [Int32])) + -- Decode using Generics decoder (which now handles packed) + case decode @Packed packedBytes of + Right msg -> assert "packed repeated roundtrip" (unField (pScores msg) == scores) + Left err -> error $ "FAIL: packed repeated roundtrip: " ++ show err + + -- Encode using unpacked format (each element individually tagged) + let unpackedBytes = runProtoBuilder (encodeRepeatedField (Field scores :: Field 1 [Int32])) + case decode @Packed unpackedBytes of + Right msg -> assert "unpacked repeated roundtrip" (unField (pScores msg) == scores) + Left err -> error $ "FAIL: unpacked repeated roundtrip: " ++ show err + + -- Empty packed field + let emptyPacked = runProtoBuilder (encodePackedField (Field [] :: Field 1 [Int32])) + case decode @Packed emptyPacked of + Right msg -> assert "empty packed roundtrip" (unField (pScores msg) == []) + Left err -> error $ "FAIL: empty packed roundtrip: " ++ show err + + +-- =================================================================== +-- 33. Mixed packed/unpacked entries +-- =================================================================== + +testMixedPackedUnpacked :: IO () +testMixedPackedUnpacked = do + putStrLn "=== Mixed packed/unpacked entries ===" + + -- Manually construct wire bytes with a packed blob AND individual entries + -- for the same field number 1. + -- First: unpacked entry for value 1 + let unpacked1 = runProtoBuilder (encodeRepeatedField (Field [1 :: Int32] :: Field 1 [Int32])) + -- Second: packed blob for values [2, 3, 4] + let packed234 = runProtoBuilder (encodePackedField (Field [2, 3, 4 :: Int32] :: Field 1 [Int32])) + -- Third: unpacked entry for value 5 + let unpacked5 = runProtoBuilder (encodeRepeatedField (Field [5 :: Int32] :: Field 1 [Int32])) + -- Concatenate them (this is valid proto3: decoder must merge all entries) + let mixed = unpacked1 <> packed234 <> unpacked5 + case decode @Packed mixed of + Right msg -> assert "mixed packed/unpacked decodes all values" + (unField (pScores msg) == [1, 2, 3, 4, 5]) + Left err -> error $ "FAIL: mixed packed/unpacked: " ++ show err + + +-- =================================================================== +-- 34. ProtoMap field roundtrip +-- =================================================================== + +data WithMap = WithMap + { wmLabels :: Field 1 (ProtoMap Text Int32) + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithMap + +testMapRoundtrip :: IO () +testMapRoundtrip = do + putStrLn "=== ProtoMap field roundtrip ===" + + -- Non-empty map + let m = Map.fromList [("alpha", 1), ("beta", 2), ("gamma", 3)] + msg = WithMap (Field (ProtoMap m)) + case decode (encode msg) of + Right msg' -> assert "map roundtrip" (msg == msg') + Left err -> error $ "FAIL: map roundtrip: " ++ show err + + +-- =================================================================== +-- 35. Empty map +-- =================================================================== + +testEmptyMap :: IO () +testEmptyMap = do + putStrLn "=== Empty map ===" + + let msg = WithMap (Field (ProtoMap Map.empty)) + bs = encode msg + -- Empty map should encode to empty bytes (no entries) + assert "empty map encodes to empty bytes" (BS.null bs) + + case decode @WithMap bs of + Right msg' -> assert "empty map roundtrip" (msg == msg') + Left err -> error $ "FAIL: empty map roundtrip: " ++ show err + + +-- =================================================================== +-- 36. Map with multiple entry types +-- =================================================================== + +data WithMaps = WithMaps + { wmStrStr :: Field 1 (ProtoMap Text Text) + , wmStrInt :: Field 2 (ProtoMap Text Int32) + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithMaps + +testMultipleMaps :: IO () +testMultipleMaps = do + putStrLn "=== Multiple map fields ===" + + let msg = WithMaps + (Field (ProtoMap (Map.fromList [("key1", "val1"), ("key2", "val2")]))) + (Field (ProtoMap (Map.fromList [("count", 42)]))) + case decode (encode msg) of + Right msg' -> assert "multiple maps roundtrip" (msg == msg') + Left err -> error $ "FAIL: multiple maps roundtrip: " ++ show err + + +-- =================================================================== +-- Protoc cross-validation: message types matching test.proto +-- =================================================================== + +-- | Matches test.SimpleMsg in test.proto +data ProtoSimpleMsg = ProtoSimpleMsg + { psName :: Field 1 Text + , psAge :: Field 2 Int32 + , psActive :: Field 3 Bool + } deriving (Show, Eq, Generic) + +instance ProtoMessage ProtoSimpleMsg + +-- | Matches test.NestedMsg in test.proto +data ProtoNestedMsg = ProtoNestedMsg + { pnTitle :: Field 1 Text + , pnAuthor :: Field 2 (Maybe ProtoSimpleMsg) + } deriving (Show, Eq, Generic) + +instance ProtoMessage ProtoNestedMsg + +-- | Matches test.RepeatedMsg in test.proto +data ProtoRepeatedMsg = ProtoRepeatedMsg + { prValues :: Field 1 [Int32] + , prTags :: Field 2 [Text] + } deriving (Show, Eq, Generic) + +instance ProtoMessage ProtoRepeatedMsg + +-- | Matches test.MapMsg in test.proto +data ProtoMapMsg = ProtoMapMsg + { pmScores :: Field 1 (ProtoMap Text Int32) + } deriving (Show, Eq, Generic) + +instance ProtoMessage ProtoMapMsg + + +-- =================================================================== +-- Protoc cross-validation: helpers +-- =================================================================== + +-- | Check if protoc is available on the system. +hasProtoc :: IO Bool +hasProtoc = do + result <- try @SomeException (readProcess "protoc" ["--version"] "") + pure (isRight result) + +-- | Pipe binary bytes to protoc --decode, returning the text-format output. +protocDecode :: String -> ByteString -> IO String +protocDecode msgName bytes = do + let cp = (proc "protoc" ["--decode=" ++ msgName, "--proto_path=test", "test.proto"]) + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just hin, Just hout, Just _herr, ph) <- createProcess cp + hSetBinaryMode hin True + BS.hPut hin bytes + hFlush hin + hClose hin + output <- hGetContents hout + _ <- waitForProcess ph + pure output + +-- | Pipe text-format to protoc --encode, returning the binary output. +protocEncode :: String -> String -> IO ByteString +protocEncode msgName textFormat = do + let cp = (proc "protoc" ["--encode=" ++ msgName, "--proto_path=test", "test.proto"]) + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + (Just hin, Just hout, Just _herr, ph) <- createProcess cp + hSetBinaryMode hout True + hPutStr' hin textFormat + hFlush hin + hClose hin + output <- BS.hGetContents hout + _ <- waitForProcess ph + pure output + where + hPutStr' h s = do + let bs = BS.pack (map (toEnum . fromEnum) s) + BS.hPut h bs + + +-- =================================================================== +-- Protoc cross-validation: Test A — Our encode -> protoc decode +-- =================================================================== + +testProtocDecodeSimple :: IO () +testProtocDecodeSimple = do + putStrLn "=== Protoc cross-validation: our encode -> protoc decode (SimpleMsg) ===" + let msg = ProtoSimpleMsg (Field "alice") (Field 30) (Field True) + bytes = Spire.Protobuf.encode msg + output <- protocDecode "test.SimpleMsg" bytes + assert "protoc decode: has name" ("name: \"alice\"" `isInfixOf` output) + assert "protoc decode: has age" ("age: 30" `isInfixOf` output) + assert "protoc decode: has active" ("active: true" `isInfixOf` output) + +testProtocDecodeNested :: IO () +testProtocDecodeNested = do + putStrLn "=== Protoc cross-validation: our encode -> protoc decode (NestedMsg) ===" + let author = ProtoSimpleMsg (Field "bob") (Field 25) (Field False) + msg = ProtoNestedMsg (Field "My Article") (Field (Just author)) + bytes = Spire.Protobuf.encode msg + output <- protocDecode "test.NestedMsg" bytes + assert "protoc decode nested: has title" ("title: \"My Article\"" `isInfixOf` output) + assert "protoc decode nested: has author name" ("name: \"bob\"" `isInfixOf` output) + assert "protoc decode nested: has author age" ("age: 25" `isInfixOf` output) + +testProtocDecodeRepeated :: IO () +testProtocDecodeRepeated = do + putStrLn "=== Protoc cross-validation: our encode -> protoc decode (RepeatedMsg) ===" + let msg = ProtoRepeatedMsg (Field [10, 20, 30]) (Field ["hello", "world"]) + bytes = Spire.Protobuf.encode msg + output <- protocDecode "test.RepeatedMsg" bytes + assert "protoc decode repeated: has values" ("values: 10" `isInfixOf` output) + assert "protoc decode repeated: has value 30" ("values: 30" `isInfixOf` output) + assert "protoc decode repeated: has tag hello" ("tags: \"hello\"" `isInfixOf` output) + assert "protoc decode repeated: has tag world" ("tags: \"world\"" `isInfixOf` output) + +testProtocDecodeMap :: IO () +testProtocDecodeMap = do + putStrLn "=== Protoc cross-validation: our encode -> protoc decode (MapMsg) ===" + let msg = ProtoMapMsg (Field (ProtoMap (Map.fromList [("alice", 100), ("bob", 200)]))) + bytes = Spire.Protobuf.encode msg + output <- protocDecode "test.MapMsg" bytes + assert "protoc decode map: has alice" ("key: \"alice\"" `isInfixOf` output) + assert "protoc decode map: has alice score" ("value: 100" `isInfixOf` output) + assert "protoc decode map: has bob" ("key: \"bob\"" `isInfixOf` output) + assert "protoc decode map: has bob score" ("value: 200" `isInfixOf` output) + + +-- =================================================================== +-- Protoc cross-validation: Test B — protoc encode -> our decode +-- =================================================================== + +testProtocEncodeSimple :: IO () +testProtocEncodeSimple = do + putStrLn "=== Protoc cross-validation: protoc encode -> our decode (SimpleMsg) ===" + let textFormat = unlines + [ "name: \"bob\"" + , "age: 25" + , "active: false" + ] + bytes <- protocEncode "test.SimpleMsg" textFormat + case Spire.Protobuf.decode bytes of + Right msg -> do + assert "protoc encode: name matches" (unField (psName msg) == "bob") + assert "protoc encode: age matches" (unField (psAge msg) == 25) + assert "protoc encode: active matches" (unField (psActive msg) == False) + Left err -> error $ "FAIL: protoc encode simple decode: " ++ show err + +testProtocEncodeNested :: IO () +testProtocEncodeNested = do + putStrLn "=== Protoc cross-validation: protoc encode -> our decode (NestedMsg) ===" + let textFormat = unlines + [ "title: \"Research Paper\"" + , "author {" + , " name: \"carol\"" + , " age: 35" + , " active: true" + , "}" + ] + bytes <- protocEncode "test.NestedMsg" textFormat + case Spire.Protobuf.decode @ProtoNestedMsg bytes of + Right msg -> do + assert "protoc encode nested: title matches" (unField (pnTitle msg) == "Research Paper") + case unField (pnAuthor msg) of + Just author -> do + assert "protoc encode nested: author name" (unField (psName author) == "carol") + assert "protoc encode nested: author age" (unField (psAge author) == 35) + assert "protoc encode nested: author active" (unField (psActive author) == True) + Nothing -> error "FAIL: protoc encode nested: author is Nothing" + Left err -> error $ "FAIL: protoc encode nested decode: " ++ show err + +testProtocEncodeRepeated :: IO () +testProtocEncodeRepeated = do + putStrLn "=== Protoc cross-validation: protoc encode -> our decode (RepeatedMsg) ===" + let textFormat = unlines + [ "values: 5" + , "values: 10" + , "values: 15" + , "tags: \"foo\"" + , "tags: \"bar\"" + ] + bytes <- protocEncode "test.RepeatedMsg" textFormat + case Spire.Protobuf.decode @ProtoRepeatedMsg bytes of + Right msg -> do + assert "protoc encode repeated: values match" (unField (prValues msg) == [5, 10, 15]) + assert "protoc encode repeated: tags match" (unField (prTags msg) == ["foo", "bar"]) + Left err -> error $ "FAIL: protoc encode repeated decode: " ++ show err + + +-- =================================================================== +-- Protoc cross-validation: Test C — roundtrip (our encode -> protoc -> our decode) +-- =================================================================== + +testProtocRoundtrip :: IO () +testProtocRoundtrip = do + putStrLn "=== Protoc cross-validation: full roundtrip ===" + -- Encode with our library, decode to text with protoc, re-encode with protoc, + -- decode with our library — should get the same message back. + let original = ProtoSimpleMsg (Field "roundtrip") (Field 99) (Field True) + bytes1 = Spire.Protobuf.encode original + -- Our bytes -> protoc text + textOutput <- protocDecode "test.SimpleMsg" bytes1 + -- protoc text -> protoc bytes + bytes2 <- protocEncode "test.SimpleMsg" textOutput + -- protoc bytes -> our decode + case Spire.Protobuf.decode @ProtoSimpleMsg bytes2 of + Right decoded -> assert "full roundtrip: message preserved" (decoded == original) + Left err -> error $ "FAIL: full roundtrip decode: " ++ show err + + +-- =================================================================== +-- Protoc cross-validation: Test D — default values (empty message) +-- =================================================================== + +testProtocDefaults :: IO () +testProtocDefaults = do + putStrLn "=== Protoc cross-validation: default/empty message ===" + -- Encode a default (all-zeros) message with our library + let msg = ProtoSimpleMsg (Field "") (Field 0) (Field False) + bytes = Spire.Protobuf.encode msg + -- Proto3: default values are not encoded on the wire, so the output + -- should be empty (protoc --decode shows nothing for default values) + assert "default msg: empty encoding" (BS.null bytes) + -- Decode an empty message from protoc + bytes2 <- protocEncode "test.SimpleMsg" "" + case Spire.Protobuf.decode @ProtoSimpleMsg bytes2 of + Right decoded -> do + assert "protoc default: name is empty" (unField (psName decoded) == "") + assert "protoc default: age is 0" (unField (psAge decoded) == 0) + assert "protoc default: active is false" (unField (psActive decoded) == False) + Left err -> error $ "FAIL: protoc default decode: " ++ show err + + +-- =================================================================== +-- Protoc cross-validation: entry point +-- =================================================================== + +testProtocCrossValidation :: IO () +testProtocCrossValidation = do + ok <- hasProtoc + if ok + then do + testProtocDecodeSimple + testProtocDecodeNested + testProtocDecodeRepeated + testProtocDecodeMap + testProtocEncodeSimple + testProtocEncodeNested + testProtocEncodeRepeated + testProtocRoundtrip + testProtocDefaults + else putStrLn " SKIP: protoc not found (install with: brew install protobuf)" + + +-- =================================================================== +-- Main +-- =================================================================== + +main :: IO () +main = do + putStrLn "spire-protobuf unit tests" + putStrLn (replicate 40 '-') + + testVarintRoundtrip + testZigzagRoundtrip + testFixed32Roundtrip + testFixed64Roundtrip + testFloatRoundtrip + testDoubleRoundtrip + testTagEncodeDecode + testLengthDelimitedRoundtrip + testSkipField + testEncodeInt32 + testEncodeBool + testEncodeText + testEncodeByteString + testEncodeOptionalField + testEncodeRepeatedField + testProtoBuilderLength + testDecodeInt32 + testDecodeText + testDecodeByteString + testParseFields + testUnknownFields + testSimpleRoundtrip + testOptionalRoundtrip + testRepeatedRoundtrip + testDefaultsEncoding + testMissingFieldsDefault + testNestedMessageRoundtrip + testOutOfOrderDecoding + testDuplicateFieldLastWins + testMalformedInput + testOverlongVarintRejection + testZigzagNegativeEfficiency + testLargeMessage + testWireCompatibility + testNegativeInt32Wire + testBoolWireFormat + testEmptyStringWire + testVarintEdgeCases + testNestedMessageWire + testRepeatedFieldWire + testPackedRepeatedRoundtrip + testMixedPackedUnpacked + testMapRoundtrip + testEmptyMap + testMultipleMaps + testProtocCrossValidation + + putStrLn (replicate 40 '-') + putStrLn "All 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,253 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import qualified Data.ByteString as BS +import Data.Int (Int32) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Data.Word (Word64) +import GHC.Generics (Generic) + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Spire.Protobuf +import Spire.Protobuf.Wire (encodeFixed32, encodeFixed64, decodeVarint, decodeFixed32, + decodeFixed64, encodeLengthDelimited, decodeLengthDelimited, + zigzagEncode, zigzagDecode) +import Spire.Protobuf.Encode (runProtoBuilder, ProtoBuilder(..), encodePackedField) + + +-- =================================================================== +-- Test message types +-- =================================================================== + +data Simple = Simple + { sName :: Field 1 Text + , sAge :: Field 2 Int32 + } deriving (Show, Eq, Generic) + +instance ProtoMessage Simple + +data WithOpt = WithOpt + { wName :: Field 1 Text + , wNick :: Field 2 (Maybe Text) + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithOpt + +data AllDefaults = AllDefaults + { dName :: Field 1 Text + , dAge :: Field 2 Int32 + , dFlag :: Field 3 Bool + } deriving (Show, Eq, Generic) + +instance ProtoMessage AllDefaults + +data Address = Address + { city :: Field 1 Text + , addrZip :: Field 2 Int32 + } deriving (Show, Eq, Generic) + +instance ProtoMessage Address + +data Person = Person + { pName :: Field 1 Text + , pAddr :: Field 2 (Maybe Address) + } deriving (Show, Eq, Generic) + +instance ProtoMessage Person + + +-- =================================================================== +-- Generators +-- =================================================================== + +genText :: Gen Text +genText = Gen.text (Range.linear 0 200) Gen.unicode + +genSimple :: Gen Simple +genSimple = Simple + <$> (Field <$> genText) + <*> (Field <$> Gen.int32 Range.linearBounded) + +genWithOpt :: Gen WithOpt +genWithOpt = WithOpt + <$> (Field <$> genText) + <*> (Field <$> Gen.maybe genText) + +genAddress :: Gen Address +genAddress = Address + <$> (Field <$> genText) + <*> (Field <$> Gen.int32 Range.linearBounded) + +genPerson :: Gen Person +genPerson = Person + <$> (Field <$> genText) + <*> (Field <$> Gen.maybe genAddress) + + +-- =================================================================== +-- Properties +-- =================================================================== + +-- | For any Word64, decoding the varint encoding gives back the original. +prop_varintRoundtrip :: Property +prop_varintRoundtrip = property $ do + n <- forAll $ Gen.word64 Range.linearBounded + let bs = runProtoBuilder (protoEncodeValue @Word64 n) + case decodeVarint bs of + Just (v, rest) -> do + v === n + assert (BS.null rest) + Nothing -> failure + +-- | For any Int64, zigzagDecode (zigzagEncode n) == n. +prop_zigzagRoundtrip :: Property +prop_zigzagRoundtrip = property $ do + n <- forAll $ Gen.int64 Range.linearBounded + zigzagDecode (zigzagEncode n) === n + +-- | For any Word32, fixed32 roundtrip works. +prop_fixed32Roundtrip :: Property +prop_fixed32Roundtrip = property $ do + n <- forAll $ Gen.word32 Range.linearBounded + let bs = runProtoBuilder (ProtoBuilder 4 (encodeFixed32 n)) + case decodeFixed32 bs of + Just (v, rest) -> do + v === n + assert (BS.null rest) + Nothing -> failure + +-- | For any Word64, fixed64 roundtrip works. +prop_fixed64Roundtrip :: Property +prop_fixed64Roundtrip = property $ do + n <- forAll $ Gen.word64 Range.linearBounded + let bs = runProtoBuilder (ProtoBuilder 8 (encodeFixed64 n)) + case decodeFixed64 bs of + Just (v, rest) -> do + v === n + assert (BS.null rest) + Nothing -> failure + +-- | For any ByteString, length-delimited roundtrip works. +prop_lengthDelimitedRoundtrip :: Property +prop_lengthDelimitedRoundtrip = property $ do + input <- forAll $ Gen.bytes (Range.linear 0 5000) + let len = BS.length input + varintLen n + | n < 0x80 = 1 + | n < 0x4000 = 2 + | n < 0x200000 = 3 + | otherwise = 4 + totalLen = varintLen len + len + bs = runProtoBuilder (ProtoBuilder totalLen (encodeLengthDelimited input)) + case decodeLengthDelimited bs of + Just (v, rest) -> do + v === input + assert (BS.null rest) + Nothing -> failure + +-- | For a Simple message with random name/age, decode (encode msg) == Right msg. +prop_messageRoundtrip :: Property +prop_messageRoundtrip = property $ do + msg <- forAll genSimple + decode (encode msg) === Right msg + +-- | For WithOpt with random Maybe Text, roundtrip works. +prop_optionalFieldRoundtrip :: Property +prop_optionalFieldRoundtrip = property $ do + msg <- forAll genWithOpt + decode (encode msg) === Right msg + +-- | A message with all-default values encodes to empty bytes. +prop_defaultsProduceEmptyEncoding :: Property +prop_defaultsProduceEmptyEncoding = property $ do + let msg = AllDefaults (Field "") (Field 0) (Field False) + encode msg === BS.empty + +-- | For any random Person with random Address, roundtrip succeeds. +prop_nestedMessageRoundtrip :: Property +prop_nestedMessageRoundtrip = property $ do + msg <- forAll genPerson + decode (encode msg) === Right msg + +-- | For any random ByteString, decode @Simple never crashes (always returns Left or Right). +prop_malformedInputDoesNotCrash :: Property +prop_malformedInputDoesNotCrash = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 500) + case decode @Simple bs of + Left _ -> success + Right _ -> success + +-- | For any Int64, zigzag encode/decode roundtrips. +prop_zigzagInt64Roundtrip :: Property +prop_zigzagInt64Roundtrip = property $ do + n <- forAll $ Gen.int64 Range.linearBounded + zigzagDecode (zigzagEncode n) === n + + +-- =================================================================== +-- Packed repeated field properties +-- =================================================================== + +data Packed = Packed + { pScores :: Field 1 [Int32] + } deriving (Show, Eq, Generic) + +instance ProtoMessage Packed + +-- | For any [Int32], packed encoding then Generics decode roundtrips. +prop_packedRoundtrip :: Property +prop_packedRoundtrip = property $ do + xs <- forAll $ Gen.list (Range.linear 0 100) (Gen.int32 Range.linearBounded) + let packed = runProtoBuilder (encodePackedField (Field xs :: Field 1 [Int32])) + decode @Packed packed === Right (Packed (Field xs)) + + +-- =================================================================== +-- Map field properties +-- =================================================================== + +data WithMap = WithMap + { wmLabels :: Field 1 (ProtoMap Text Int32) + } deriving (Show, Eq, Generic) + +instance ProtoMessage WithMap + +genProtoMap :: Gen (ProtoMap Text Int32) +genProtoMap = do + kvs <- Gen.list (Range.linear 0 20) + ((,) <$> genText <*> Gen.int32 Range.linearBounded) + pure (ProtoMap (Map.fromList kvs)) + +-- | For any Map Text Int32, encode then decode roundtrips. +prop_mapRoundtrip :: Property +prop_mapRoundtrip = property $ do + m <- forAll genProtoMap + let msg = WithMap (Field m) + decode (encode msg) === Right msg + + +-- =================================================================== +-- Main (TemplateHaskell discovery) +-- =================================================================== + +tests :: IO Bool +tests = checkParallel $$(discover) + +main :: IO () +main = do + ok <- tests + if ok + then putStrLn "All property tests passed!" + else do + putStrLn "Some property tests FAILED!" + error "Property test failure" diff --git a/test/test.proto b/test/test.proto new file mode 100644 --- /dev/null +++ b/test/test.proto @@ -0,0 +1,22 @@ +syntax = "proto3"; +package test; + +message SimpleMsg { + string name = 1; + int32 age = 2; + bool active = 3; +} + +message NestedMsg { + string title = 1; + SimpleMsg author = 2; +} + +message RepeatedMsg { + repeated int32 values = 1; + repeated string tags = 2; +} + +message MapMsg { + map scores = 1; +}