diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright 2016 Awake Networks + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/proto3-wire.cabal b/proto3-wire.cabal new file mode 100644 --- /dev/null +++ b/proto3-wire.cabal @@ -0,0 +1,49 @@ +name: proto3-wire +version: 1.0.0 +synopsis: A low-level implementation of the Protocol Buffers (version 3) wire format +license: Apache-2.0 +license-file: LICENSE +author: Awake Networks +maintainer: opensource@awakenetworks.com +copyright: 2016 Awake Networks +category: Codec +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Proto3.Wire + Proto3.Wire.Builder + Proto3.Wire.Decode + Proto3.Wire.Encode + Proto3.Wire.Tutorial + Proto3.Wire.Types + build-depends: base >=4.9 && <=5.0, + bytestring >=0.10.6.0 && <0.11.0, + cereal >= 0.5.1 && <0.6, + containers >=0.5 && < 0.7, + deepseq ==1.4.*, + hashable <1.3, + safe ==0.3.*, + text >= 0.2 && <1.3, + unordered-containers >= 0.1.0.0 && <0.3, + QuickCheck >=2.8 && <3.0 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O2 -Wall + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: base >=4.9 && <=5.0, + bytestring >=0.10.6.0 && <0.11.0, + cereal >= 0.5.1 && <0.6, + doctest >= 0.7.0 && <0.17, + proto3-wire, + QuickCheck >=2.8 && <3.0, + tasty >= 0.11 && <1.3, + tasty-hunit >= 0.9 && <0.11, + tasty-quickcheck >= 0.8.4 && <0.11, + text >= 0.2 && <1.3 diff --git a/src/Proto3/Wire.hs b/src/Proto3/Wire.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire.hs @@ -0,0 +1,31 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | See the "Proto3.Wire.Tutorial" module. + +module Proto3.Wire + ( -- * Message Structure + FieldNumber(..) + , fieldNumber + -- * Decoding Messages + , at + , oneof + , one + , repeated + ) where + +import Proto3.Wire.Types +import Proto3.Wire.Decode diff --git a/src/Proto3/Wire/Builder.hs b/src/Proto3/Wire/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Builder.hs @@ -0,0 +1,593 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | This module extends the "Data.ByteString.Builder" module by memoizing the +-- resulting length of each `Builder` +-- +-- Example use: +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32BE 42 <> charUtf8 'λ')) +-- [0,0,0,42,206,187] + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Proto3.Wire.Builder + ( + -- * `Builder` type + Builder + + -- * Create `Builder`s + , byteString + , lazyByteString + , shortByteString + , word8 + , word16BE + , word16LE + , word32BE + , word32LE + , word64BE + , word64LE + , word64Base128LEVar + , int8 + , int16BE + , int16LE + , int32BE + , int32LE + , int64BE + , int64LE + , floatBE + , floatLE + , doubleBE + , doubleLE + , char7 + , string7 + , char8 + , string8 + , charUtf8 + , stringUtf8 + + -- * Consume `Builder`s + , builderLength + , rawBuilder + , toLazyByteString + , hPutBuilder + + -- * Internal API + , unsafeMakeBuilder + ) where + +import Data.Bits ((.|.), shiftR) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Extra as BB +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS +import Data.Char ( ord ) +import Data.Int ( Int8, Int16, Int32, Int64 ) +import Data.Semigroup ( Semigroup(..), Sum(..) ) +import Data.Word ( Word8, Word16, Word32, Word64 ) +import System.IO ( Handle ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Semigroup + +-- | A `Builder` is like a @"Data.ByteString.Builder".`BB.Builder`@, but also +-- memoizes the resulting length so that we can efficiently encode nested +-- embedded messages. +-- +-- You create a `Builder` by using one of the primitives provided in the +-- \"Create `Builder`s\" section. +-- +-- You combine `Builder`s using the `Monoid` and `Semigroup` instances. +-- +-- You consume a `Builder` by using one of the utilities provided in the +-- \"Consume `Builder`s\" section. +data Builder = Builder {-# UNPACK #-} !(Sum Word) BB.Builder + +instance Semigroup Builder where + Builder s b <> Builder s1 b1 = Builder (s <> s1) (b <> b1) + +instance Monoid Builder where + mempty = Builder mempty mempty + mappend = (<>) + +instance Show Builder where + showsPrec prec builder = + showParen (prec > 10) + (showString "Proto3.Wire.Builder.lazyByteString " . shows bytes) + where + bytes = toLazyByteString builder + +-- | Retrieve the length of a `Builder` +-- +-- > builderLength (x <> y) = builderLength x + builderLength y +-- > +-- > builderLength mempty = 0 +-- +-- >>> builderLength (word32BE 42) +-- 4 +-- >>> builderLength (stringUtf8 "ABC") +-- 3 +builderLength :: Builder -> Word +builderLength (Builder x _) = getSum x + +-- | Retrieve the underlying @"Data.ByteString.Builder".`BB.Builder`@ +-- +-- > rawBuilder (x <> y) = rawBuilder x <> rawBuilder y +-- > +-- > rawBuilder mempty = mempty +-- +-- >>> Data.ByteString.Builder.toLazyByteString (rawBuilder (stringUtf8 "ABC")) +-- "ABC" +rawBuilder :: Builder -> BB.Builder +rawBuilder (Builder _ x) = x + +-- | Create a `Builder` from a @"Data.ByteString.Builder".`BB.Builder`@ and a +-- length. This is unsafe because you are responsible for ensuring that the +-- provided length value matches the length of the +-- @"Data.ByteString.Builder".`BB.Builder`@ +-- +-- >>> unsafeMakeBuilder 3 (Data.ByteString.Builder.stringUtf8 "ABC") +-- Proto3.Wire.Builder.lazyByteString "ABC" +unsafeMakeBuilder :: Word -> BB.Builder -> Builder +unsafeMakeBuilder len bldr = Builder (Sum len) bldr + +-- | Create a lazy `BL.ByteString` from a `Builder` +-- +-- > toLazyByteString (x <> y) = toLazyByteString x <> toLazyByteString y +-- > +-- > toLazyByteString mempty = mempty +-- +-- >>> toLazyByteString (stringUtf8 "ABC") +-- "ABC" +toLazyByteString :: Builder -> BL.ByteString +toLazyByteString (Builder (Sum len) bb) = + BB.toLazyByteStringWith strat BL.empty bb + where + -- If the supplied length is accurate then we will perform just + -- one allocation. An inaccurate length would indicate a bug + -- in one of the primitives that produces a 'Builder'. + strat = BB.safeStrategy (fromIntegral len) BB.defaultChunkSize +{-# NOINLINE toLazyByteString #-} + -- NOINLINE to avoid bloating caller; see docs for 'BB.toLazyByteStringWith'. + +-- | Write a `Builder` to a `Handle` +-- +-- > hPutBuilder handle (x <> y) = hPutBuilder handle x <> hPutBuilder handle y +-- > +-- > hPutBuilder handle mempty = mempty +-- +-- >>> hPutBuilder System.IO.stdout (stringUtf8 "ABC\n") +-- ABC +hPutBuilder :: Handle -> Builder -> IO () +hPutBuilder handle = BB.hPutBuilder handle . rawBuilder + +-- | Convert a strict `B.ByteString` to a `Builder` +-- +-- > byteString (x <> y) = byteString x <> byteString y +-- > +-- > byteString mempty = mempty +-- +-- >>> byteString "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +byteString :: B.ByteString -> Builder +byteString bs = + Builder (Sum (fromIntegral (B.length bs))) (BB.byteStringCopy bs) + -- NOTE: We want 'toLazyByteString' to produce a single chunk (unless + -- incorrect uses of 'unsafeMakeBuilder' sabotage the length prediction). + -- + -- To that end, 'toLazyByteString' allocates a first chunk of exactly the + -- builder length. That length should be accurate unless there is a bug, + -- either within this library or in some arguments to 'unsafeMakeBuilder'. + -- + -- If the given 'bs :: B.ByteString' is longer than a certain threshold, + -- then passing it to 'BB.byteString' would produce a builder that closes + -- the current chunk and appends 'bs' as its own chunk, without copying. + -- That would waste some of the chunk allocated by 'toLazyByteString'. + -- + -- Therefore we force copying of 'bs' by using 'BB.byteStringCopy' here. + +-- | Convert a lazy `BL.ByteString` to a `Builder` +-- +-- Warning: evaluating the length will force the lazy `BL.ByteString`'s chunks, +-- and they will remain allocated until you finish using the builder. +-- +-- > lazyByteString (x <> y) = lazyByteString x <> lazyByteString y +-- > +-- > lazyByteString mempty = mempty +-- +-- > lazyByteString . toLazyByteString = id +-- > +-- > toLazyByteString . lazyByteString = id +-- +-- >>> lazyByteString "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +lazyByteString :: BL.ByteString -> Builder +lazyByteString bl = + Builder (Sum (fromIntegral (BL.length bl))) (BB.lazyByteStringCopy bl) + -- NOTE: We use 'BB.lazyByteStringCopy' here for the same reason + -- that 'byteString' uses 'BB.byteStringCopy'. For the rationale, + -- please see the comments in the implementation of 'byteString'. + +-- | Convert a `BS.ShortByteString` to a `Builder` +-- +-- > shortByteString (x <> y) = shortByteString x <> shortByteString y +-- > +-- > shortByteString mempty = mempty +-- +-- >>> shortByteString "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +shortByteString :: BS.ShortByteString -> Builder +shortByteString bs = + Builder (Sum (fromIntegral (BS.length bs))) (BB.shortByteString bs) + +-- | Convert a `Word8` to a `Builder` +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word8 42)) +-- [42] +word8 :: Word8 -> Builder +word8 w = Builder (Sum 1) (BB.word8 w) + +-- | Convert a `Int8` to a `Builder` +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int8 (-5))) +-- [251] +int8 :: Int8 -> Builder +int8 w = Builder (Sum 1) (BB.int8 w) + +-- | Convert a `Word16` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16BE 42)) +-- [0,42] +word16BE :: Word16 -> Builder +word16BE w = Builder (Sum 2) (BB.word16BE w) + +-- | Convert a `Word16` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word16LE 42)) +-- [42,0] +word16LE :: Word16 -> Builder +word16LE w = Builder (Sum 2) (BB.word16LE w) + +-- | Convert an `Int16` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16BE (-5))) +-- [255,251] +int16BE :: Int16 -> Builder +int16BE w = Builder (Sum 2) (BB.int16BE w) + +-- | Convert an `Int16` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int16LE (-5))) +-- [251,255] +int16LE :: Int16 -> Builder +int16LE w = Builder (Sum 2) (BB.int16LE w) + +-- | Convert a `Word32` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32BE 42)) +-- [0,0,0,42] +word32BE :: Word32 -> Builder +word32BE w = Builder (Sum 4) (BB.word32BE w) + +-- | Convert a `Word32` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word32LE 42)) +-- [42,0,0,0] +word32LE :: Word32 -> Builder +word32LE w = Builder (Sum 4) (BB.word32LE w) + +-- | Convert an `Int32` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32BE (-5))) +-- [255,255,255,251] +int32BE :: Int32 -> Builder +int32BE w = Builder (Sum 4) (BB.int32BE w) + +-- | Convert an `Int32` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int32LE (-5))) +-- [251,255,255,255] +int32LE :: Int32 -> Builder +int32LE w = Builder (Sum 4) (BB.int32LE w) + +-- | Convert a `Float` to a `Builder` by storing the bytes in IEEE-754 format in +-- big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatBE 4.2)) +-- [64,134,102,102] +floatBE :: Float -> Builder +floatBE f = Builder (Sum 4) (BB.floatBE f) + +-- | Convert a `Float` to a `Builder` by storing the bytes in IEEE-754 format in +-- little-endian order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (floatLE 4.2)) +-- [102,102,134,64] +floatLE :: Float -> Builder +floatLE f = Builder (Sum 4) (BB.floatLE f) + +-- | Convert a `Word64` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64BE 42)) +-- [0,0,0,0,0,0,0,42] +word64BE :: Word64 -> Builder +word64BE w = Builder (Sum 8) (BB.word64BE w) + +-- | Convert a `Word64` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (word64LE 42)) +-- [42,0,0,0,0,0,0,0] +word64LE :: Word64 -> Builder +word64LE w = Builder (Sum 8) (BB.word64LE w) + +-- | Convert a `Word64` to a `Builder` using this variable-length encoding: +-- +-- 1. Convert the given value to a base 128 representation +-- without unnecessary digits (that is, omit zero digits +-- unless they are less significant than nonzero digits). +-- +-- 2. Present those base-128 digits in order of increasing +-- significance (that is, in little-endian order). +-- +-- 3. Add 128 to every digit except the most significant digit, +-- yielding a sequence of octets terminated by one that is <= 127. +-- +-- This encoding is used in the wire format of Protocol Buffers version 3. +word64Base128LEVar :: Word64 -> Builder +{- +Prelude Data.Bits Numeric> map (("0x"++) .($"").showHex) $ map bit $ take 11 [0,7..] +["0x1","0x80","0x4000","0x200000","0x10000000","0x800000000","0x40000000000","0x2000000000000","0x100000000000000","0x8000000000000000","0x400000000000000000"] +-} +word64Base128LEVar i + | i < 0x80 = word8 (fromIntegral i) + | i < 0x4000 = Builder (Sum 2) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7))) + | i < 0x200000 = Builder (Sum 3) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14))) + | i < 0x10000000 = Builder (Sum 4) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21))) + | i < 0x800000000 = Builder (Sum 5) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28))) + | i < 0x40000000000 = Builder (Sum 6) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 35))) + | i < 0x2000000000000 = Builder (Sum 7) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 35) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 42))) + | i < 0x100000000000000 = Builder (Sum 8) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 35) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 42) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 49))) + | i < 0x8000000000000000 = Builder (Sum 9) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 35) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 42) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 49) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 56))) + | otherwise = Builder (Sum 10) (BB.word8 (fromIntegral i .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 7) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 14) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 21) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 28) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 35) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 42) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 49) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 56) .|. 0x80) <> + BB.word8 (fromIntegral (i `shiftR` 63))) + + +-- | Convert an `Int64` to a `Builder` by storing the bytes in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64BE (-5))) +-- [255,255,255,255,255,255,255,251] +int64BE :: Int64 -> Builder +int64BE w = Builder (Sum 8) (BB.int64BE w) + +-- | Convert an `Int64` to a `Builder` by storing the bytes in little-endian +-- order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (int64LE (-5))) +-- [251,255,255,255,255,255,255,255] +int64LE :: Int64 -> Builder +int64LE w = Builder (Sum 8) (BB.int64LE w) + +-- | Convert a `Double` to a `Builder` by storing the bytes in IEEE-754 format +-- in big-endian order +-- +-- In other words, the most significant byte is stored first and the least +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleBE 4.2)) +-- [64,16,204,204,204,204,204,205] +doubleBE :: Double -> Builder +doubleBE f = Builder (Sum 8) (BB.doubleBE f) + +-- | Convert a `Double` to a `Builder` by storing the bytes in IEEE-754 format +-- in little-endian order +-- +-- In other words, the least significant byte is stored first and the most +-- significant byte is stored last +-- +-- >>> Data.ByteString.Lazy.unpack (toLazyByteString (doubleLE 4.2)) +-- [205,204,204,204,204,204,16,64] +doubleLE :: Double -> Builder +doubleLE f = Builder (Sum 8) (BB.doubleLE f) + +-- | Convert an @ASCII@ `Char` to a `Builder` +-- +-- __Careful:__ If you provide a Unicode character that is not part of the +-- @ASCII@ alphabet this will only encode the lowest 7 bits +-- +-- >>> char7 ';' +-- Proto3.Wire.Builder.lazyByteString ";" +-- >>> char7 'λ' -- Example of truncation +-- Proto3.Wire.Builder.lazyByteString ";" +char7 :: Char -> Builder +char7 c = Builder (Sum 1) (BB.char7 c) + +-- | Convert an @ASCII@ `String` to a `Builder` +-- +-- __Careful:__ If you provide a Unicode `String` that has non-@ASCII@ +-- characters then this will only encode the lowest 7 bits of each character +-- +-- > string7 (x <> y) = string7 x <> string7 y +-- > +-- > string7 mempty = mempty +-- +-- >>> string7 "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +-- >>> string7 "←↑→↓" -- Example of truncation +-- Proto3.Wire.Builder.lazyByteString "\DLE\DC1\DC2\DC3" +string7 :: String -> Builder +string7 s = Builder (Sum (fromIntegral (length s))) (BB.string7 s) + +-- | Convert an @ISO/IEC 8859-1@ `Char` to a `Builder` +-- +-- __Careful:__ If you provide a Unicode character that is not part of the +-- @ISO/IEC 8859-1@ alphabet then this will only encode the lowest 8 bits +-- +-- >>> char8 ';' +-- Proto3.Wire.Builder.lazyByteString ";" +-- >>> char8 'λ' -- Example of truncation +-- Proto3.Wire.Builder.lazyByteString "\187" +char8 :: Char -> Builder +char8 c = Builder (Sum 1) (BB.char8 c) + +-- | Convert an @ISO/IEC 8859-1@ `String` to a `Builder` +-- +-- __Careful:__ If you provide a Unicode `String` that has non-@ISO/IEC 8859-1@ +-- characters then this will only encode the lowest 8 bits of each character +-- +-- > string8 (x <> y) = string8 x <> string8 y +-- > +-- > string8 mempty = mempty +-- +-- >>> string8 "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +-- >>> string8 "←↑→↓" -- Example of truncation +-- Proto3.Wire.Builder.lazyByteString "\144\145\146\147" +string8 :: String -> Builder +string8 s = Builder (Sum (fromIntegral (length s))) (BB.string8 s) + +-- | Convert a Unicode `Char` to a `Builder` using a @UTF-8@ encoding +-- +-- >>> charUtf8 'A' +-- Proto3.Wire.Builder.lazyByteString "A" +-- >>> charUtf8 'λ' +-- Proto3.Wire.Builder.lazyByteString "\206\187" +-- >>> hPutBuilder System.IO.stdout (charUtf8 'λ' <> charUtf8 '\n') +-- λ +charUtf8 :: Char -> Builder +charUtf8 c = Builder (Sum (utf8Width c)) (BB.charUtf8 c) + +-- | Convert a Unicode `String` to a `Builder` using a @UTF-8@ encoding +-- +-- > stringUtf8 (x <> y) = stringUtf8 x <> stringUtf8 y +-- > +-- > stringUtf8 mempty = mempty +-- +-- >>> stringUtf8 "ABC" +-- Proto3.Wire.Builder.lazyByteString "ABC" +-- >>> stringUtf8 "←↑→↓" +-- Proto3.Wire.Builder.lazyByteString "\226\134\144\226\134\145\226\134\146\226\134\147" +-- >>> hPutBuilder System.IO.stdout (stringUtf8 "←↑→↓\n") +-- ←↑→↓ +stringUtf8 :: String -> Builder +stringUtf8 s = Builder (Sum (len 0 s)) (BB.stringUtf8 s) + where + len !n [] = n + len !n (h : t) = len (n + utf8Width h) t +{-# INLINABLE stringUtf8 #-} + -- INLINABLE so that if the input is constant, the + -- compiler has the opportunity to precompute its length. + +utf8Width :: Char -> Word +utf8Width c = case ord c of + o | o <= 0x007F -> 1 + | o <= 0x07FF -> 2 + | o <= 0xFFFF -> 3 + | otherwise -> 4 +{-# INLINE utf8Width #-} diff --git a/src/Proto3/Wire/Decode.hs b/src/Proto3/Wire/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Decode.hs @@ -0,0 +1,576 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | Low level functions for reading data in the protobufs wire format. +-- +-- This module exports a function 'decodeWire' which parses data in the raw wire +-- format into an untyped 'Map' representation. +-- +-- This module also provides 'Parser' types and functions for reading messages +-- from the untyped 'Map' representation obtained from 'decodeWire'. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Proto3.Wire.Decode + ( -- * Untyped Representation + ParsedField(..) + , decodeWire + -- * Parser Types + , Parser(..) + , RawPrimitive + , RawField + , RawMessage + , ParseError(..) + , foldFields + , parse + -- * Primitives + , bool + , int32 + , int64 + , uint32 + , uint64 + , sint32 + , sint64 + , enum + , byteString + , lazyByteString + , text + , packedVarints + , packedFixed32 + , packedFixed64 + , packedFloats + , packedDoubles + , fixed32 + , fixed64 + , sfixed32 + , sfixed64 + , float + , double + -- * Decoding Messages + , at + , oneof + , one + , repeated + , embedded + , embedded' + ) where + +import Control.Applicative +import Control.Arrow (first) +import Control.Exception ( Exception ) +import Control.Monad ( msum, foldM ) +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Foldable ( foldl' ) +import qualified Data.IntMap.Strict as M -- TODO intmap +import Data.Maybe ( fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Serialize.Get ( Get, getWord8, getInt32le + , getInt64le, getWord32le, getWord64le + , runGet ) +import Data.Serialize.IEEE754 ( getFloat32le, getFloat64le ) +import Data.Text.Lazy ( Text, pack ) +import Data.Text.Lazy.Encoding ( decodeUtf8' ) +import qualified Data.Traversable as T +import Data.Int ( Int32, Int64 ) +import Data.Word ( Word8, Word32, Word64 ) +import Proto3.Wire.Types +import qualified Safe + +-- | Decode a zigzag-encoded numeric type. +-- See: http://stackoverflow.com/questions/2210923/zig-zag-decoding +zigZagDecode :: (Num a, Bits a) => a -> a +zigZagDecode i = shiftR i 1 `xor` (-(i .&. 1)) + +-- | One field in a protobuf message. +-- +-- We don't know what's inside some of these fields until we know what type +-- we're deserializing to, so we leave them as 'ByteString' until a later step +-- in the process. +data ParsedField = VarintField Word64 + | Fixed32Field B.ByteString + | Fixed64Field B.ByteString + | LengthDelimitedField B.ByteString + deriving (Show, Eq) + +-- | Convert key-value pairs to a map of keys to a sequence of values with that +-- key, in their reverse occurrence order. +-- +-- >>> toMap ([(FieldNumber 1, 3),(FieldNumber 2, 4),(FieldNumber 1, 6)] :: [(FieldNumber,Int)]) +-- fromList [(1,[6,3]),(2,[4])] +-- +toMap :: [(FieldNumber, v)] -> M.IntMap [v] +toMap kvs0 = M.fromListWith (<>) . map (fmap (:[])) . map (first (fromIntegral . getFieldNumber)) $ kvs0 + +decodeWire :: B.ByteString -> Either String [(FieldNumber, ParsedField)] +decodeWire bstr = drloop bstr [] + where + drloop !bs xs | B.null bs = Right $ reverse xs + drloop !bs xs | otherwise = do + (w, rest) <- takeVarInt bs + wt <- gwireType $ fromIntegral (w .&. 7) + let fn = w `shiftR` 3 + (res, rest2) <- takeWT wt rest + drloop rest2 ((FieldNumber fn,res):xs) + + +eitherUncons :: B.ByteString -> Either String (Word8, B.ByteString) +eitherUncons = maybe (Left "failed to parse varint128") Right . B.uncons + + +takeVarInt :: B.ByteString -> Either String (Word64, B.ByteString) +takeVarInt !bs = + case B.uncons bs of + Nothing -> Right (0, B.empty) + Just (w1, r1) -> do + if w1 < 128 then return (fromIntegral w1, r1) else do + let val1 = fromIntegral (w1 - 0x80) + + (w2,r2) <- eitherUncons r1 + if w2 < 128 then return (val1 + (fromIntegral w2 `shiftL` 7), r2) else do + let val2 = (val1 + (fromIntegral (w2 - 0x80) `shiftL` 7)) + + (w3,r3) <- eitherUncons r2 + if w3 < 128 then return (val2 + (fromIntegral w3 `shiftL` 14), r3) else do + let val3 = (val2 + (fromIntegral (w3 - 0x80) `shiftL` 14)) + + (w4,r4) <- eitherUncons r3 + if w4 < 128 then return (val3 + (fromIntegral w4 `shiftL` 21), r4) else do + let val4 = (val3 + (fromIntegral (w4 - 0x80) `shiftL` 21)) + + (w5,r5) <- eitherUncons r4 + if w5 < 128 then return (val4 + (fromIntegral w5 `shiftL` 28), r5) else do + let val5 = (val4 + (fromIntegral (w5 - 0x80) `shiftL` 28)) + + (w6,r6) <- eitherUncons r5 + if w6 < 128 then return (val5 + (fromIntegral w6 `shiftL` 35), r6) else do + let val6 = (val5 + (fromIntegral (w6 - 0x80) `shiftL` 35)) + + (w7,r7) <- eitherUncons r6 + if w7 < 128 then return (val6 + (fromIntegral w7 `shiftL` 42), r7) else do + let val7 = (val6 + (fromIntegral (w7 - 0x80) `shiftL` 42)) + + (w8,r8) <- eitherUncons r7 + if w8 < 128 then return (val7 + (fromIntegral w8 `shiftL` 49), r8) else do + let val8 = (val7 + (fromIntegral (w8 - 0x80) `shiftL` 49)) + + (w9,r9) <- eitherUncons r8 + if w9 < 128 then return (val8 + (fromIntegral w9 `shiftL` 56), r9) else do + let val9 = (val8 + (fromIntegral (w9 - 0x80) `shiftL` 56)) + + (w10,r10) <- eitherUncons r9 + if w10 < 128 then return (val9 + (fromIntegral w10 `shiftL` 63), r10) else do + + Left ("failed to parse varint128: too big; " ++ show val6) + + +gwireType :: Word8 -> Either String WireType +gwireType 0 = return Varint +gwireType 5 = return Fixed32 +gwireType 1 = return Fixed64 +gwireType 2 = return LengthDelimited +gwireType wt = Left $ "wireType got unknown wire type: " ++ show wt + +safeSplit :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString) +safeSplit !i! b | B.length b < i = Left "failed to parse varint128: not enough bytes" + | otherwise = Right $ B.splitAt i b + +takeWT :: WireType -> B.ByteString -> Either String (ParsedField, B.ByteString) +takeWT Varint !b = fmap (first VarintField) $ takeVarInt b +takeWT Fixed32 !b = fmap (first Fixed32Field) $ safeSplit 4 b +takeWT Fixed64 !b = fmap (first Fixed64Field) $ safeSplit 8 b +takeWT LengthDelimited b = do + (!len, rest) <- takeVarInt b + fmap (first LengthDelimitedField) $ safeSplit (fromIntegral len) rest + + +-- * Parser Interface + +-- | Type describing possible errors that can be encountered while parsing. +data ParseError = + -- | A 'WireTypeError' occurs when the type of the data in the protobuf + -- binary format does not match the type encountered by the parser. This can + -- indicate that the type of a field has changed or is incorrect. + WireTypeError Text + | + -- | A 'BinaryError' occurs when we can't successfully parse the contents of + -- the field. + BinaryError Text + | + -- | An 'EmbeddedError' occurs when we encounter an error while parsing an + -- embedded message. + EmbeddedError Text + (Maybe ParseError) + deriving (Show, Eq, Ord) + +-- | This library does not use this instance, but it is provided for convenience, +-- so that 'ParseError' may be used with functions like `throwIO` +instance Exception ParseError + +-- | A parsing function type synonym, to tidy up type signatures. +-- +-- This synonym is used in three ways: +-- +-- * Applied to 'RawPrimitive', to parse primitive fields. +-- * Applied to 'RawField', to parse fields which correspond to a single 'FieldNumber'. +-- * Applied to 'RawMessage', to parse entire messages. +-- +-- Many of the combinators in this module are used to combine and convert between +-- these three parser types. +-- +-- 'Parser's can be combined using the 'Applicative', 'Monad' and 'Alternative' +-- instances. +newtype Parser input a = Parser { runParser :: input -> Either ParseError a } + deriving Functor + +instance Applicative (Parser input) where + pure = Parser . const . pure + Parser p1 <*> Parser p2 = + Parser $ \input -> p1 input <*> p2 input + +instance Monad (Parser input) where + -- return = pure + Parser p >>= f = Parser $ \input -> p input >>= (`runParser` input) . f + +-- | Raw data corresponding to a single encoded key/value pair. +type RawPrimitive = ParsedField + +-- | Raw data corresponding to a single 'FieldNumber'. +type RawField = [RawPrimitive] + +-- | Raw data corresponding to an entire message. +-- +-- A 'Map' from 'FieldNumber's to the those values associated with +-- that 'FieldNumber'. +type RawMessage = M.IntMap RawField + +-- | Fold over a list of parsed fields accumulating a result +foldFields :: M.IntMap (Parser RawPrimitive a, a -> acc -> acc) + -> acc + -> [(FieldNumber, ParsedField)] + -> Either ParseError acc +foldFields parsers = foldM applyOne + where applyOne acc (fn, field) = + case M.lookup (fromIntegral . getFieldNumber $ fn) parsers of + Nothing -> pure acc + Just (parser, apply) -> + case runParser parser field of + Left err -> Left err + Right a -> pure $ apply a acc + +-- | Parse a message (encoded in the raw wire format) using the specified +-- `Parser`. +parse :: Parser RawMessage a -> B.ByteString -> Either ParseError a +parse parser bs = case decodeWire bs of + Left err -> Left (BinaryError (pack err)) + Right res -> runParser parser (toMap res) + +-- | To comply with the protobuf spec, if there are multiple fields with the same +-- field number, this will always return the last one. +parsedField :: RawField -> Maybe RawPrimitive +parsedField xs = case xs of + [] -> Nothing + (x:_) -> Just x + +throwWireTypeError :: Show input + => String + -> input + -> Either ParseError expected +throwWireTypeError expected wrong = + Left (WireTypeError (pack msg)) + where + msg = "Wrong wiretype. Expected " ++ expected ++ " but got " ++ show wrong + +throwCerealError :: String -> String -> Either ParseError a +throwCerealError expected cerealErr = + Left (BinaryError (pack msg)) + where + msg = "Failed to parse contents of " ++ + expected ++ " field. " ++ "Error from cereal was: " ++ cerealErr + +parseVarInt :: Integral a => Parser RawPrimitive a +parseVarInt = Parser $ + \case + VarintField i -> Right (fromIntegral i) + wrong -> throwWireTypeError "varint" wrong + +runGetPacked :: Get a -> Parser RawPrimitive a +runGetPacked g = Parser $ + \case + LengthDelimitedField bs -> + case runGet g bs of + Left e -> throwCerealError "packed repeated field" e + Right xs -> return xs + wrong -> throwWireTypeError "packed repeated field" wrong + +runGetFixed32 :: Get a -> Parser RawPrimitive a +runGetFixed32 g = Parser $ + \case + Fixed32Field bs -> case runGet g bs of + Left e -> throwCerealError "fixed32 field" e + Right x -> return x + wrong -> throwWireTypeError "fixed 32 field" wrong + +runGetFixed64 :: Get a -> Parser RawPrimitive a +runGetFixed64 g = Parser $ + \case + Fixed64Field bs -> case runGet g bs of + Left e -> throwCerealError "fixed 64 field" e + Right x -> return x + wrong -> throwWireTypeError "fixed 64 field" wrong + +bytes :: Parser RawPrimitive B.ByteString +bytes = Parser $ + \case + LengthDelimitedField bs -> + return $! B.copy bs + wrong -> throwWireTypeError "bytes" wrong + +-- | Parse a Boolean value. +bool :: Parser RawPrimitive Bool +bool = fmap (Safe.toEnumDef False) parseVarInt + +-- | Parse a primitive with the @int32@ wire type. +int32 :: Parser RawPrimitive Int32 +int32 = parseVarInt + +-- | Parse a primitive with the @int64@ wire type. +int64 :: Parser RawPrimitive Int64 +int64 = parseVarInt + +-- | Parse a primitive with the @uint32@ wire type. +uint32 :: Parser RawPrimitive Word32 +uint32 = parseVarInt + +-- | Parse a primitive with the @uint64@ wire type. +uint64 :: Parser RawPrimitive Word64 +uint64 = parseVarInt + +-- | Parse a primitive with the @sint32@ wire type. +sint32 :: Parser RawPrimitive Int32 +sint32 = fmap (fromIntegral . (zigZagDecode :: Word32 -> Word32)) parseVarInt + +-- | Parse a primitive with the @sint64@ wire type. +sint64 :: Parser RawPrimitive Int64 +sint64 = fmap (fromIntegral . (zigZagDecode :: Word64 -> Word64)) parseVarInt + +-- | Parse a primitive with the @bytes@ wire type as a 'B.ByteString'. +byteString :: Parser RawPrimitive B.ByteString +byteString = bytes + +-- | Parse a primitive with the @bytes@ wire type as a lazy 'BL.ByteString'. +lazyByteString :: Parser RawPrimitive BL.ByteString +lazyByteString = fmap BL.fromStrict bytes + +-- | Parse a primitive with the @bytes@ wire type as 'Text'. +text :: Parser RawPrimitive Text +text = Parser $ + \case + LengthDelimitedField bs -> + case decodeUtf8' $ BL.fromStrict bs of + Left err -> Left (BinaryError (pack ("Failed to decode UTF-8: " ++ + show err))) + Right txt -> return txt + wrong -> throwWireTypeError "string" wrong + +-- | Parse a primitive with an enumerated type. +-- +-- This parser will return 'Left' if the encoded integer value is outside the +-- acceptable range of the 'Bounded' instance. +enum :: forall e. (Enum e, Bounded e) => Parser RawPrimitive (Either Int e) +enum = fmap toEither parseVarInt + where + toEither :: Int -> Either Int e + toEither i + | Just e <- Safe.toEnumMay i = Right e + | otherwise = Left i + +-- | Parse a packed collection of variable-width integer values (any of @int32@, +-- @int64@, @sint32@, @sint64@, @uint32@, @uint64@ or enumerations). +packedVarints :: Integral a => Parser RawPrimitive [a] +packedVarints = fmap (fmap fromIntegral) (runGetPacked (many getBase128Varint)) + +getBase128Varint :: Get Word64 +getBase128Varint = loop 0 0 + where + loop !i !w64 = do + w8 <- getWord8 + if base128Terminal w8 + then return $ combine i w64 w8 + else loop (i + 1) (combine i w64 w8) + base128Terminal w8 = (not . (`testBit` 7)) $ w8 + combine i w64 w8 = (w64 .|. + (fromIntegral (w8 `clearBit` 7) + `shiftL` + (i * 7))) + + + +-- | Parse a packed collection of @float@ values. +packedFloats :: Parser RawPrimitive [Float] +packedFloats = runGetPacked (many getFloat32le) + +-- | Parse a packed collection of @double@ values. +packedDoubles :: Parser RawPrimitive [Double] +packedDoubles = runGetPacked (many getFloat64le) + +-- | Parse a packed collection of @fixed32@ values. +packedFixed32 :: Integral a => Parser RawPrimitive [a] +packedFixed32 = fmap (fmap fromIntegral) (runGetPacked (many getWord32le)) + +-- | Parse a packed collection of @fixed64@ values. +packedFixed64 :: Integral a => Parser RawPrimitive [a] +packedFixed64 = fmap (fmap fromIntegral) (runGetPacked (many getWord64le)) + +-- | Parse a @float@. +float :: Parser RawPrimitive Float +float = runGetFixed32 getFloat32le + +-- | Parse a @double@. +double :: Parser RawPrimitive Double +double = runGetFixed64 getFloat64le + +-- | Parse an integer primitive with the @fixed32@ wire type. +fixed32 :: Parser RawPrimitive Word32 +fixed32 = runGetFixed32 getWord32le + +-- | Parse an integer primitive with the @fixed64@ wire type. +fixed64 :: Parser RawPrimitive Word64 +fixed64 = runGetFixed64 getWord64le + +-- | Parse a signed integer primitive with the @fixed32@ wire type. +sfixed32 :: Parser RawPrimitive Int32 +sfixed32 = runGetFixed32 getInt32le + +-- | Parse a signed integer primitive with the @fixed64@ wire type. +sfixed64 :: Parser RawPrimitive Int64 +sfixed64 = runGetFixed64 getInt64le + +-- | Turn a field parser into a message parser, by specifying the 'FieldNumber'. +-- +-- This parser will fail if the specified 'FieldNumber' is not present. +-- +-- For example: +-- +-- > one float `at` fieldNumber 1 :: Parser RawMessage (Maybe Float) +at :: Parser RawField a -> FieldNumber -> Parser RawMessage a +at parser fn = Parser $ runParser parser . fromMaybe mempty . M.lookup (fromIntegral . getFieldNumber $ fn) + +-- | Try to parse different field numbers with their respective parsers. This is +-- used to express alternative between possible fields of a oneof. +-- +-- TODO: contrary to the protobuf spec, in the case of multiple fields number +-- matching the oneof content, the choice of field is biased to the order of the +-- list, instead of being biased to the last field of group of field number in +-- the oneof. This is related to the Map used for input that preserve order +-- across multiple invocation of the same field, but not across a group of +-- field. +oneof :: a + -- ^ The value to produce when no field numbers belonging to the oneof + -- are present in the input + -> [(FieldNumber, Parser RawField a)] + -- ^ Left-biased oneof field parsers, one per field number belonging to + -- the oneof + -> Parser RawMessage a +oneof def parsersByFieldNum = Parser $ \input -> + case msum ((\(num,p) -> (p,) <$> M.lookup (fromIntegral . getFieldNumber $ num) input) <$> parsersByFieldNum) of + Nothing -> pure def + Just (p, v) -> runParser p v + +-- | This turns a primitive parser into a field parser by keeping the +-- last received value, or return a default value if the field number is missing. +-- +-- Used to ensure that we return the last value with the given field number +-- in the message, in compliance with the protobuf standard. +-- +-- The protocol buffers specification specifies default values for +-- primitive types. +-- +-- For example: +-- +-- > one float 0 :: Parser RawField Float +one :: Parser RawPrimitive a -> a -> Parser RawField a +one parser def = Parser (fmap (fromMaybe def) . traverse (runParser parser) . parsedField) + +-- | Parse a repeated field, or an unpacked collection of primitives. +-- +-- Each value with the identified 'FieldNumber' will be passed to the parser +-- in the first argument, to be converted into a value of the correct type. +-- +-- For example, to parse a packed collection of @uint32@ values: +-- +-- > repeated uint32 :: Parser RawField ([Word32]) +-- +-- or to parse a collection of embedded messages: +-- +-- > repeated . embedded' :: Parser RawMessage a -> Parser RawField ([a]) +repeated :: Parser RawPrimitive a -> Parser RawField [a] +repeated parser = Parser $ fmap reverse . mapM (runParser parser) + +-- | For a field containing an embedded message, parse as far as getting the +-- wire-level fields out of the message. +embeddedToParsedFields :: RawPrimitive -> Either ParseError RawMessage +embeddedToParsedFields (LengthDelimitedField bs) = + case decodeWire bs of + Left err -> Left (EmbeddedError ("Failed to parse embedded message: " + <> (pack err)) + Nothing) + Right result -> return (toMap result) +embeddedToParsedFields wrong = + throwWireTypeError "embedded" wrong + +-- | Create a field parser for an embedded message, from a message parser. +-- +-- The protobuf spec requires that embedded messages be mergeable, so that +-- protobuf encoding has the flexibility to transmit embedded messages in +-- pieces. This function reassembles the pieces, and must be used to parse all +-- embedded non-repeated messages. +-- +-- If the embedded message is not found in the outer message, this function +-- returns 'Nothing'. +embedded :: Parser RawMessage a -> Parser RawField (Maybe a) +embedded p = Parser $ + \xs -> if xs == empty + then return Nothing + else do + innerMaps <- T.mapM embeddedToParsedFields xs + let combinedMap = foldl' (M.unionWith (<>)) M.empty innerMaps + parsed <- runParser p combinedMap + return $ Just parsed + +-- | Create a primitive parser for an embedded message from a message parser. +-- +-- This parser does no merging of fields if multiple message fragments are +-- sent separately. +embedded' :: Parser RawMessage a -> Parser RawPrimitive a +embedded' parser = Parser $ + \case + LengthDelimitedField bs -> + case parse parser bs of + Left err -> Left (EmbeddedError "Failed to parse embedded message." + (Just err)) + Right result -> return result + wrong -> throwWireTypeError "embedded" wrong + + +-- TODO test repeated and embedded better for reverse logic... diff --git a/src/Proto3/Wire/Encode.hs b/src/Proto3/Wire/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Encode.hs @@ -0,0 +1,378 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | Low level functions for writing the protobufs wire format. +-- +-- Because protobuf messages are encoded as a collection of fields, +-- one can use the 'Monoid' instance for 'MessageBuilder' to encode multiple +-- fields. +-- +-- One should be careful to make sure that 'FieldNumber's appear in +-- increasing order. +-- +-- In protocol buffers version 3, all fields are optional. To omit a value +-- for a field, simply do not append it to the 'MessageBuilder'. One can +-- create functions for wrapping optional fields with a 'Maybe' type. +-- +-- Similarly, repeated fields can be encoded by concatenating several values +-- with the same 'FieldNumber'. +-- +-- For example: +-- +-- > strings :: Foldable f => FieldNumber -> f String -> MessageBuilder +-- > strings = foldMap . string +-- > +-- > 1 `strings` Just "some string" <> +-- > 2 `strings` [ "foo", "bar", "baz" ] + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Proto3.Wire.Encode + ( -- * `MessageBuilder` type + MessageBuilder + , messageLength + , sizedMessageBuilder + , rawMessageBuilder + , toLazyByteString + , unsafeFromLazyByteString + + -- * Standard Integers + , int32 + , int64 + -- * Unsigned Integers + , uint32 + , uint64 + -- * Signed Integers + , sint32 + , sint64 + -- * Non-varint Numbers + , fixed32 + , fixed64 + , sfixed32 + , sfixed64 + , float + , double + , enum + -- * Strings + , bytes + , string + , text + , byteString + , lazyByteString + -- * Embedded Messages + , embedded + -- * Packed repeated fields + , packedVarints + , packedFixed32 + , packedFixed64 + , packedFloats + , packedDoubles + ) where + +import Data.Bits ( (.|.), shiftL, shiftR, xor ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL +import Data.Int ( Int32, Int64 ) +import Data.Monoid ( (<>) ) +import Data.Semigroup ( Semigroup ) +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Encoding as Text.Lazy.Encoding +import Data.Word ( Word8, Word32, Word64 ) +import qualified Proto3.Wire.Builder as WB +import Proto3.Wire.Types + +-- $setup +-- +-- >>> :set -XOverloadedStrings + +-- | A `MessageBuilder` represents a serialized protobuf message +-- +-- Use the utilities provided by this module to create `MessageBuilder`s +-- +-- You can concatenate two messages using the `Monoid` instance for +-- `MessageBuilder` +-- +-- Use `toLazyByteString` when you're done assembling the `MessageBuilder` +newtype MessageBuilder = MessageBuilder { unMessageBuilder :: WB.Builder } + deriving (Semigroup, Monoid) + +instance Show MessageBuilder where + showsPrec prec builder = + showParen (prec > 10) + (showString "Proto3.Wire.Encode.unsafeFromLazyByteString " . shows bytes') + where + bytes' = toLazyByteString builder + +-- | Retrieve the length of a message, in bytes +messageLength :: MessageBuilder -> Word +messageLength = WB.builderLength . unMessageBuilder + +-- | Convert a message to a @"Proto3.Wire.Builder".`WB.Builder`@ +sizedMessageBuilder :: MessageBuilder -> WB.Builder +sizedMessageBuilder = unMessageBuilder + +-- | Convert a message to a @"Data.ByteString.Builder".`BB.Builder`@ +rawMessageBuilder :: MessageBuilder -> BB.Builder +rawMessageBuilder = WB.rawBuilder . unMessageBuilder + +-- | Convert a message to a lazy `BL.ByteString` +toLazyByteString :: MessageBuilder -> BL.ByteString +toLazyByteString = WB.toLazyByteString . unMessageBuilder + +-- | This lets you cast an arbitrary `ByteString` to a `MessageBuilder`, whether +-- or not the `ByteString` corresponds to a valid serialized protobuf message +-- +-- Do not use this function unless you know what you're doing because it lets +-- you assemble malformed protobuf `MessageBuilder`s +unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder +unsafeFromLazyByteString bytes' = + MessageBuilder { unMessageBuilder = WB.lazyByteString bytes' } + +base128Varint :: Word64 -> MessageBuilder +base128Varint = MessageBuilder . WB.word64Base128LEVar + +wireType :: WireType -> Word8 +wireType Varint = 0 +wireType Fixed32 = 5 +wireType Fixed64 = 1 +wireType LengthDelimited = 2 + +fieldHeader :: FieldNumber -> WireType -> MessageBuilder +fieldHeader num wt = base128Varint ((getFieldNumber num `shiftL` 3) .|. + fromIntegral (wireType wt)) + +-- | Encode a 32-bit "standard" integer +-- +-- For example: +-- +-- >>> 1 `int32` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" +int32 :: FieldNumber -> Int32 -> MessageBuilder +int32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) + +-- | Encode a 64-bit "standard" integer +-- +-- For example: +-- +-- >>> 1 `int64` (-42) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\214\255\255\255\255\255\255\255\255\SOH" +int64 :: FieldNumber -> Int64 -> MessageBuilder +int64 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) + +-- | Encode a 32-bit unsigned integer +-- +-- For example: +-- +-- >>> 1 `uint32` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" +uint32 :: FieldNumber -> Word32 -> MessageBuilder +uint32 num i = fieldHeader num Varint <> base128Varint (fromIntegral i) + +-- | Encode a 64-bit unsigned integer +-- +-- For example: +-- +-- >>> 1 `uint64` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b*" +uint64 :: FieldNumber -> Word64 -> MessageBuilder +uint64 num i = fieldHeader num Varint <> base128Varint i + +-- | Encode a 32-bit signed integer +-- +-- For example: +-- +-- >>> 1 `sint32` (-42) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS" +sint32 :: FieldNumber -> Int32 -> MessageBuilder +sint32 num i = int32 num ((i `shiftL` 1) `xor` (i `shiftR` 31)) + +-- | Encode a 64-bit signed integer +-- +-- For example: +-- +-- >>> 1 `sint64` (-42) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\bS" +sint64 :: FieldNumber -> Int64 -> MessageBuilder +sint64 num i = int64 num ((i `shiftL` 1) `xor` (i `shiftR` 63)) + +-- | Encode a fixed-width 32-bit integer +-- +-- For example: +-- +-- >>> 1 `fixed32` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\r*\NUL\NUL\NUL" +fixed32 :: FieldNumber -> Word32 -> MessageBuilder +fixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.word32LE i) + +-- | Encode a fixed-width 64-bit integer +-- +-- For example: +-- +-- >>> 1 `fixed64` 42 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t*\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +fixed64 :: FieldNumber -> Word64 -> MessageBuilder +fixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.word64LE i) + +-- | Encode a fixed-width signed 32-bit integer +-- +-- For example: +-- +-- > 1 `sfixed32` (-42) +sfixed32 :: FieldNumber -> Int32 -> MessageBuilder +sfixed32 num i = fieldHeader num Fixed32 <> MessageBuilder (WB.int32LE i) + +-- | Encode a fixed-width signed 64-bit integer +-- +-- For example: +-- +-- >>> 1 `sfixed64` (-42) +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\214\255\255\255\255\255\255\255" +sfixed64 :: FieldNumber -> Int64 -> MessageBuilder +sfixed64 num i = fieldHeader num Fixed64 <> MessageBuilder (WB.int64LE i) + +-- | Encode a floating point number +-- +-- For example: +-- +-- >>> 1 `float` 3.14 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\r\195\245H@" +float :: FieldNumber -> Float -> MessageBuilder +float num f = fieldHeader num Fixed32 <> MessageBuilder (WB.floatLE f) + +-- | Encode a double-precision number +-- +-- For example: +-- +-- >>> 1 `double` 3.14 +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\t\US\133\235Q\184\RS\t@" +double :: FieldNumber -> Double -> MessageBuilder +double num d = fieldHeader num Fixed64 <> MessageBuilder (WB.doubleLE d) + +-- | Encode a value with an enumerable type. +-- +-- It can be useful to derive an 'Enum' instance for a type in order to +-- emulate enums appearing in .proto files. +-- +-- For example: +-- +-- >>> data Shape = Circle | Square | Triangle deriving (Enum) +-- >>> 1 `enum` True <> 2 `enum` Circle +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\b\SOH\DLE\NUL" +enum :: Enum e => FieldNumber -> e -> MessageBuilder +enum num e = fieldHeader num Varint <> base128Varint (fromIntegral (fromEnum e)) + +-- | Encode a sequence of octets as a field of type 'bytes'. +-- +-- >>> 1 `bytes` (Proto3.Wire.Builder.stringUtf8 "testing") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +bytes :: FieldNumber -> WB.Builder -> MessageBuilder +bytes num = embedded num . MessageBuilder + +-- | Encode a UTF-8 string. +-- +-- For example: +-- +-- >>> 1 `string` "testing" +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +string :: FieldNumber -> String -> MessageBuilder +string num = embedded num . MessageBuilder . WB.stringUtf8 + +-- | Encode lazy `Text` as UTF-8 +-- +-- For example: +-- +-- >>> 1 `text` "testing" +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder +text num txt = + embedded num (MessageBuilder (WB.unsafeMakeBuilder len (Text.Lazy.Encoding.encodeUtf8Builder txt))) + where + -- It would be nice to avoid actually allocating encoded chunks, + -- but we leave that enhancement for a future time. + len = Text.Lazy.foldrChunks op 0 txt + op chnk acc = fromIntegral (B.length (Text.Encoding.encodeUtf8 chnk)) + acc +{-# INLINABLE text #-} + -- INLINABLE so that if the input is constant, the compiler + -- has the opportunity to express its length as a CAF. + +-- | Encode a collection of bytes in the form of a strict 'B.ByteString'. +-- +-- For example: +-- +-- >>> 1 `byteString` "testing" +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +byteString :: FieldNumber -> B.ByteString -> MessageBuilder +byteString num bs = embedded num (MessageBuilder (WB.byteString bs)) + +-- | Encode a lazy bytestring. +-- +-- For example: +-- +-- >>> 1 `lazyByteString` "testing" +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\atesting" +lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder +lazyByteString num bl = embedded num (MessageBuilder (WB.lazyByteString bl)) + +-- | Encode varints in the space-efficient packed format. +-- +-- >>> 1 `packedVarints` [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\ETX\SOH\STX\ETX" +packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder +packedVarints num = embedded num . foldMap base128Varint + +-- | Encode fixed-width Word32s in the space-efficient packed format. +-- +-- >>> 1 `packedFixed32` [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\SOH\NUL\NUL\NUL\STX\NUL\NUL\NUL\ETX\NUL\NUL\NUL" +packedFixed32 :: Foldable f => FieldNumber -> f Word32 -> MessageBuilder +packedFixed32 num = embedded num . foldMap (MessageBuilder . WB.word32LE) + +-- | Encode fixed-width Word64s in the space-efficient packed format. +-- +-- >>> 1 `packedFixed64` [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +packedFixed64 :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder +packedFixed64 num = embedded num . foldMap (MessageBuilder . WB.word64LE) + +-- | Encode floats in the space-efficient packed format. +-- +-- >>> 1 `packedFloats` [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\f\NUL\NUL\128?\NUL\NUL\NUL@\NUL\NUL@@" +packedFloats :: Foldable f => FieldNumber -> f Float -> MessageBuilder +packedFloats num = embedded num . foldMap (MessageBuilder . WB.floatLE) + +-- | Encode doubles in the space-efficient packed format. +-- +-- >>> 1 `packedDoubles` [1, 2, 3] +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\CAN\NUL\NUL\NUL\NUL\NUL\NUL\240?\NUL\NUL\NUL\NUL\NUL\NUL\NUL@\NUL\NUL\NUL\NUL\NUL\NUL\b@" +packedDoubles :: Foldable f => FieldNumber -> f Double -> MessageBuilder +packedDoubles num = embedded num . foldMap (MessageBuilder . WB.doubleLE) + +-- | Encode an embedded message. +-- +-- The message is represented as a 'MessageBuilder', so it is possible to chain +-- encoding functions. +-- +-- For example: +-- +-- >>> 1 `embedded` (1 `string` "this message" <> 2 `string` " is embedded") +-- Proto3.Wire.Encode.unsafeFromLazyByteString "\n\FS\n\fthis message\DC2\f is embedded" +embedded :: FieldNumber -> MessageBuilder -> MessageBuilder +embedded num bb = fieldHeader num LengthDelimited <> + base128Varint (fromIntegral (messageLength bb)) <> + bb diff --git a/src/Proto3/Wire/Tutorial.hs b/src/Proto3/Wire/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Tutorial.hs @@ -0,0 +1,218 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} +-- | This module is an executable tutorial for the @proto3-wire@ library. +-- It will demonstrate how to encode and decode messages of various types. +-- +-- = Imports +-- +-- We recommend importing the "Proto3.Wire.Encode" and "Proto3.Wire.Decode" +-- modules qualified, since they define encoding and decoding functions with the +-- same names. +-- +-- The "Proto3.Wire" module reexports some useful functions, so a good default +-- set of imports is: +-- +-- > import Proto3.Wire +-- > import qualified Proto3.Wire.Encode as Encode +-- > import qualified Proto3.Wire.Decode as Decode +-- +-- = Primitives +-- +-- Let's translate this simple @.proto@ file into a Haskell data type and a pair +-- of encoding and decoding functions: +-- +-- > message EchoRequest { +-- > string message = 1; +-- > } +-- +-- We begin by defining a data type to represent our messages: +-- +-- > data EchoRequest = EchoRequest { echoRequestMessage :: Text } +-- +-- == Encoding +-- +-- To encode an 'EchoRequest', we use the @Encode.'Encode.text'@ function, and provide +-- the field number and the text value: +-- +-- > encodeEchoRequest :: EchoRequest -> Encode.MessageBuilder +-- > encodeEchoRequest EchoRequest{..} = +-- > Encode.text 1 echoRequestMessage +-- +-- Fields of type @string@ can be encoded\/decoded from\/to values of type 'String', +-- 'ByteString' and 'Text'. Here we use the 'Text' type, which is encoded using +-- the 'Encode.text' function. Different primitive types have different encoding +-- functions, which are usually named after the Protocol Buffers type. +-- +-- == Decoding +-- +-- To decode an 'EchoRequest', we use the 'Decode.parse' function, and provide +-- a 'Decode.Parser' to extract the fields: +-- +-- > decodeEchoRequest :: ByteString -> Either Decode.ParseError EchoRequest +-- > decodeEchoRequest = Decode.parse echoRequestParser +-- +-- The decoding function for 'Text' is called @Decode.'Decode.text'@. However, we must +-- specify the field number, which is done using the `at` function, and provide +-- a default value, using the `one` function. The types will ensure that +-- the field number and default value are provided. +-- +-- We use the 'Functor' instance for 'Decode.Parser' to apply the 'EchoRequest' +-- constructor to the result: +-- +-- > echoRequestParser :: Decode.Parser Decode.RawMessage EchoRequest +-- > echoRequestParser = EchoRequest <$> (one Decode.text mempty `at` 1 +-- +-- = Messages with multiple fields +-- +-- Let's make our example more interesting by including multiple fields: +-- +-- > message EchoResponse { +-- > string message = 1; +-- > uint64 timestamp = 2; +-- > } +-- +-- We begin by defining a data type to represent our messages: +-- +-- > data EchoResponse = EchoResponse { echoResponseMessage :: Text +-- > , echoResponseTimestamp :: Word64 +-- > } +-- +-- == Encoding +-- +-- To encode messages with multiple fields, note that functions in the +-- "Proto3.Wire.Encode" module return values in the 'Encode.MessageBuilder' +-- monoid, so we can use `mappend` to combine messages: +-- +-- > encodedEchoResponse :: EchoResponse -> Encode.MessageBuilder +-- > encodedEchoResponse EchoResponse{..} = +-- > Encode.text 1 echoResponseMessage <> +-- > Encode.uint64 2 echoResponseTimestamp +-- +-- However, be careful to always use increasing field numbers, since this is not +-- enforced by the library. +-- +-- == Decoding +-- +-- Messages with many fields can be parsed using the 'Applicative' instance for +-- 'Parser': +-- +-- > decodeEchoResponse :: ByteString -> Either Decode.ParseError EchoResponse +-- > decodeEchoResponse = Decode.parse echoResponseParser +-- > +-- > echoResponseParser :: Decode.Parser Decode.RawMessage EchoResponse +-- > echoResponseParser = EchoResponse <$> (one Decode.text mempty `at` 1) +-- > <*> (one Decode.uint64 0 `at` 2) +-- +-- = Repeated Fields and Embedded Messages +-- +-- Messages can be embedded in fields of other messages. This can be useful +-- when entire sections of a message can be repeated or omitted. +-- +-- Consider the following message types: +-- +-- > message EchoManyRequest { +-- > repeated EchoRequest requests = 1; +-- > } +-- +-- Again, we define a type corresponding to our message: +-- +-- > data EchoManyRequest = EchoManyRequest { echoManyRequestRequests :: Seq EchoRequest } +-- +-- == Encoding +-- +-- Messages can be embedded using `Encode.embedded`. +-- +-- In protocol buffers version 3, all fields are optional. To omit a value for a +-- field, simply do not append it to the 'Encode.MessageBuilder'. +-- +-- Similarly, repeated fields can be encoded by concatenating several values +-- with the same 'FieldNumber'. +-- +-- It can be useful to use 'foldMap' to deal with these cases. +-- +-- > encodeEchoManyRequest :: EchoManyRequest -> Encode.MessageBuilder +-- > encodeEchoManyRequest = +-- > foldMap (Encode.embedded 1 . encodeEchoRequest) +-- > . echoManyRequestRequests +-- +-- == Decoding +-- +-- Embedded messages can be decoded using 'Decode.embedded'. +-- +-- Repeated fields can be decoded using 'repeated'. +-- +-- Repeated embedded messages can be decoded using @repeated . Decode.embedded'@. +-- +-- > decodeEchoManyRequest :: ByteString -> Either Decode.ParseError EchoManyRequest +-- > decodeEchoManyRequest = Decode.parse echoManyRequestParser +-- > +-- > echoManyRequestParser :: Decode.Parser Decode.RawMessage EchoManyRequest +-- > echoManyRequestParser = +-- > EchoManyRequest <$> (repeated (Decode.embedded' echoRequestParser) `at` 1) +{-# LANGUAGE RecordWildCards #-} + +module Proto3.Wire.Tutorial where + +import Data.ByteString ( ByteString ) +import Data.Monoid ( (<>) ) +import Data.Text.Lazy ( Text ) +import Data.Word ( Word64 ) + +import Proto3.Wire +import qualified Proto3.Wire.Encode as Encode +import qualified Proto3.Wire.Decode as Decode + +data EchoRequest = EchoRequest { echoRequestMessage :: Text } + +encodeEchoRequest :: EchoRequest -> Encode.MessageBuilder +encodeEchoRequest EchoRequest{..} = + Encode.text 1 echoRequestMessage + +decodeEchoRequest :: ByteString -> Either Decode.ParseError EchoRequest +decodeEchoRequest = Decode.parse echoRequestParser + +echoRequestParser :: Decode.Parser Decode.RawMessage EchoRequest +echoRequestParser = EchoRequest <$> (one Decode.text mempty `at` 1) + +data EchoResponse = EchoResponse { echoResponseMessage :: Text + , echoResponseTimestamp :: Word64 + } + +encodedEchoResponse :: EchoResponse -> Encode.MessageBuilder +encodedEchoResponse EchoResponse{..} = + Encode.text 1 echoResponseMessage <> + Encode.uint64 2 echoResponseTimestamp + +decodeEchoResponse :: ByteString -> Either Decode.ParseError EchoResponse +decodeEchoResponse = Decode.parse echoResponseParser + +echoResponseParser :: Decode.Parser Decode.RawMessage EchoResponse +echoResponseParser = EchoResponse <$> (one Decode.text mempty `at` 1) + <*> (one Decode.uint64 0 `at` 2) + +data EchoManyRequest = EchoManyRequest { echoManyRequestRequests :: [EchoRequest] + } + +encodeEchoManyRequest :: EchoManyRequest -> Encode.MessageBuilder +encodeEchoManyRequest = foldMap (Encode.embedded 1 . + encodeEchoRequest) . + echoManyRequestRequests + +decodeEchoManyRequest :: ByteString -> Either Decode.ParseError EchoManyRequest +decodeEchoManyRequest = Decode.parse echoManyRequestParser + +echoManyRequestParser :: Decode.Parser Decode.RawMessage EchoManyRequest +echoManyRequestParser = EchoManyRequest <$> (repeated (Decode.embedded' echoRequestParser) `at` 1) diff --git a/src/Proto3/Wire/Types.hs b/src/Proto3/Wire/Types.hs new file mode 100644 --- /dev/null +++ b/src/Proto3/Wire/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +-- | This module defines types which are shared by the encoding and decoding +-- modules. + +module Proto3.Wire.Types + ( -- * Message Structure + FieldNumber(..) + , fieldNumber + , WireType(..) + ) where + +import Control.DeepSeq ( NFData ) +import Data.Hashable ( Hashable ) +import Data.Word ( Word64 ) +import Test.QuickCheck ( Arbitrary(..), choose ) + +-- | A 'FieldNumber' identifies a field inside a protobufs message. +-- +-- This library makes no attempt to generate these automatically, or even make +-- sure that field numbers are provided in increasing order. Such things are +-- left to other, higher-level libraries. +newtype FieldNumber = FieldNumber { getFieldNumber :: Word64 } + deriving (Eq, Ord, Enum, Hashable, NFData, Num) + +instance Show FieldNumber where + show (FieldNumber n) = show n + +instance Arbitrary FieldNumber where + arbitrary = fmap FieldNumber $ choose (1, 536870911) + +-- | Create a 'FieldNumber' given the (one-based) integer which would label +-- the field in the corresponding .proto file. +fieldNumber :: Word64 -> FieldNumber +fieldNumber = FieldNumber + +-- | The (non-deprecated) wire types identified by the Protocol +-- Buffers specification. +data WireType = Varint | Fixed32 | Fixed64 | LengthDelimited + deriving (Show, Eq, Ord) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,203 @@ +{- + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Builder.Internal as BBI +import Data.Either ( isLeft ) +import Data.Maybe ( fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Int +import qualified Data.Text.Lazy as T + +import Proto3.Wire +import qualified Proto3.Wire.Builder as Builder +import qualified Proto3.Wire.Encode as Encode +import qualified Proto3.Wire.Decode as Decode + +import qualified Test.DocTest +import Test.QuickCheck ( (===), Arbitrary ) +import Test.Tasty +import Test.Tasty.HUnit ( (@=?) ) +import qualified Test.Tasty.HUnit as HU +import qualified Test.Tasty.QuickCheck as QC + +main :: IO () +main = do + Test.DocTest.doctest + [ "-isrc" + , "src/Proto3/Wire/Builder.hs" + , "src/Proto3/Wire/Encode.hs" + , "src/Proto3/Wire/Decode.hs" + ] + defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [ roundTripTests + , buildSingleChunk + , decodeNonsense + , varIntHeavyTests + ] + +data StringOrInt64 = TString T.Text | TInt64 Int64 + deriving (Show,Eq) + +instance QC.Arbitrary StringOrInt64 where + arbitrary = QC.oneof [ TString . T.pack <$> QC.arbitrary, TInt64 <$> QC.arbitrary ] + +-- this just stress tesses the fancy varint encodings with more randomness +varIntHeavyTests :: TestTree +varIntHeavyTests = adjustOption (const $ QC.QuickCheckTests 10000) $ + roundTrip "varInt uint test" + (Encode.uint64 (fieldNumber 1)) + (one Decode.uint64 0 `at` fieldNumber 1) + +roundTripTests :: TestTree +roundTripTests = testGroup "Roundtrip tests" + [ roundTrip "int32" + (Encode.int32 (fieldNumber 1)) + (one Decode.int32 0 `at` fieldNumber 1) + , roundTrip "int64" + (Encode.int64 (fieldNumber 1)) + (one Decode.int64 0 `at` fieldNumber 1) + , roundTrip "sint32" + (Encode.sint32 (fieldNumber 1)) + (one Decode.sint32 0 `at` fieldNumber 1) + , roundTrip "sint64" + (Encode.sint64 (fieldNumber 1)) + (one Decode.sint64 0 `at` fieldNumber 1) + , roundTrip "uint32" + (Encode.uint32 (fieldNumber 1)) + (one Decode.uint32 0 `at` fieldNumber 1) + , roundTrip "uint64" + (Encode.uint64 (fieldNumber 1)) + (one Decode.uint64 0 `at` fieldNumber 1) + , roundTrip "fixed32" + (Encode.fixed32 (fieldNumber 1)) + (one Decode.fixed32 0 `at` fieldNumber 1) + , roundTrip "fixed64" + (Encode.fixed64 (fieldNumber 1)) + (one Decode.fixed64 0 `at` fieldNumber 1) + , roundTrip "sfixed32" + (Encode.sfixed32 (fieldNumber 1)) + (one Decode.sfixed32 0 `at` fieldNumber 1) + , roundTrip "sfixed64" + (Encode.sfixed64 (fieldNumber 1)) + (one Decode.sfixed64 0 `at` fieldNumber 1) + , roundTrip "float" + (Encode.float (fieldNumber 1)) + (one Decode.float 0 `at` fieldNumber 1) + , roundTrip "double" + (Encode.double (fieldNumber 1)) + (one Decode.double 0 `at` fieldNumber 1) + , roundTrip "bool" + (Encode.enum (fieldNumber 1)) + (one Decode.bool False `at` fieldNumber 1) + , roundTrip "text" + (Encode.text (fieldNumber 1) . T.pack) + (one (fmap T.unpack Decode.text) mempty `at` + fieldNumber 1) + , roundTrip "embedded" + (Encode.embedded (fieldNumber 1) . + Encode.int32 (fieldNumber 1)) + (fmap (fromMaybe 0) + (Decode.embedded (one Decode.int32 + 0 `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "embeddedList" + (Encode.embedded (fieldNumber 1) . + Encode.packedFixed32 (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (one Decode.packedFixed32 [] + `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "embeddedListUnpacked" + (Encode.embedded (fieldNumber 1) . + (foldMap . Encode.int32) (fieldNumber 1)) + (fmap (fromMaybe [0,1,2,3,4]) + (Decode.embedded (repeated Decode.int32 + `at` + fieldNumber 1)) + `at` fieldNumber 1) + , roundTrip "multiple fields" + (\(a, b) -> Encode.int32 (fieldNumber 1) + a <> + Encode.uint32 (fieldNumber 2) b) + ((,) <$> + one Decode.int32 0 `at` + fieldNumber 1 + <*> one Decode.uint32 0 `at` + fieldNumber 2) + , roundTrip "oneof" + (\case Just (TString text) -> Encode.text (fieldNumber 3) text + Just (TInt64 i) -> Encode.int64 (fieldNumber 2) i + Nothing -> mempty + ) + (oneof Nothing + [ (fieldNumber 2, Just . TInt64 <$> one Decode.int64 0) + , (fieldNumber 3, Just . TString <$> one Decode.text mempty) + ] + ) + , roundTrip "oneof-last" + (\case Just (TString text) -> Encode.text (fieldNumber 3) "something" <> Encode.text (fieldNumber 3) text + Just (TInt64 i) -> Encode.int64 (fieldNumber 2) 20000000 <> Encode.int64 (fieldNumber 2) i + Nothing -> mempty + ) + (oneof Nothing + [ (fieldNumber 2, Just . TInt64 <$> one Decode.int64 0) + , (fieldNumber 3, Just . TString <$> one Decode.text mempty) + ] + ) + + ] + +roundTrip :: (Show a, Eq a, Arbitrary a) + => String + -> (a -> Encode.MessageBuilder) + -> Decode.Parser Decode.RawMessage a + -> TestTree +roundTrip name encode decode = + QC.testProperty name $ + \x -> do + let bytes = Encode.toLazyByteString (encode x) + case Decode.parse decode (BL.toStrict bytes) of + Left _ -> error "Could not decode encoded message" + Right x' -> x === x' + +buildSingleChunk :: TestTree +buildSingleChunk = HU.testCase "Builder creates a single chunk" $ do + let chunks = length . BL.toChunks . Builder.toLazyByteString + + huge = B.replicate (BBI.maximalCopySize + 16) 1 + huge2 = Builder.byteString huge <> Builder.byteString huge + + hugeL = BL.fromChunks [huge, huge] + hugeL2 = Builder.lazyByteString hugeL <> Builder.lazyByteString hugeL + + HU.assertBool "single chunk (strict)" $ chunks huge2 == 1 + HU.assertBool "single chunk (lazy)" $ chunks hugeL2 == 1 + +decodeNonsense :: TestTree +decodeNonsense = HU.testCase "Decoding a nonsensical string fails." $ do + let decoded = Decode.parse (one Decode.fixed64 0 `at` fieldNumber 1) "test" + HU.assertBool "decode fails" $ isLeft decoded