proto3-wire (empty) → 1.0.0
raw patch · 10 files changed
+2119/−0 lines, 10 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, containers, deepseq, doctest, hashable, proto3-wire, safe, tasty, tasty-hunit, tasty-quickcheck, text, unordered-containers
Files
- LICENSE +13/−0
- Setup.hs +2/−0
- proto3-wire.cabal +49/−0
- src/Proto3/Wire.hs +31/−0
- src/Proto3/Wire/Builder.hs +593/−0
- src/Proto3/Wire/Decode.hs +576/−0
- src/Proto3/Wire/Encode.hs +378/−0
- src/Proto3/Wire/Tutorial.hs +218/−0
- src/Proto3/Wire/Types.hs +56/−0
- test/Main.hs +203/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ proto3-wire.cabal view
@@ -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
+ src/Proto3/Wire.hs view
@@ -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
+ src/Proto3/Wire/Builder.hs view
@@ -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 #-}
+ src/Proto3/Wire/Decode.hs view
@@ -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...
+ src/Proto3/Wire/Encode.hs view
@@ -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
+ src/Proto3/Wire/Tutorial.hs view
@@ -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)
+ src/Proto3/Wire/Types.hs view
@@ -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)
+ test/Main.hs view
@@ -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